~nickpapior/siesta/trunk-buds-format0.92
» Revision
616
: Src/buds/sources_mpi/src/bud_LL_Array1D.f90
« back to all changes in this revision
Viewing changes to Src/buds/sources_mpi/src/bud_LL_Array1D.f90
- browse files at revision 616
- compare with another revision
- download diff
- download tarball
- view history from revision 616
- Committer: Nick Papior
- Date: 2017-04-07 12:42:28 UTC
- Revision ID: nickpapior@gmail.com-20170407124228-u5t08yr2p4fhzfeo
Initial commit of buds merged into siesta
Currently I have only enabled buds compilation.
Currently I have only enabled buds compilation.
- files added:
- Src/buds
- Src/buds/.travis
- Src/buds/doc
- Src/buds/include
- Src/buds/setup.makes
- Src/buds/smeka
- Src/buds/smeka/vendor
- Src/buds/sources
- Src/buds/sources/src
- Src/buds/sources/src/mpi
- Src/buds/sources_mpi
- Src/buds/sources_mpi/src
- Src/buds/sources_mpi/src/mpi
- Src/buds/src
- Src/buds/src/mpi
- Src/buds/src/mpi/test
- Src/buds/src/test
- Src/buds/tools
- files modified:
- Src/Makefile
added
removed
Src/buds/sources_mpi/src/bud_LL_Array1D.f90
1
module bud_LL_sArray1D
2
use bud_sArray1D
3
implicit none
4
private
5
integer, parameter :: rr_ = selected_real_kind(p=6) ! single (real*4)
6
integer, parameter :: rd_ = selected_real_kind(p=15) ! double (real*8)
7
integer, parameter :: is_ = selected_int_kind(4) ! short (integer*2)
8
integer, parameter :: ii_ = selected_int_kind(9) ! int (integer*4)
9
integer, parameter :: il_ = selected_int_kind(18) ! long (integer*8)
10
integer, parameter, private :: BUD_ID_LEn = 36
11
character(len=*), parameter, private :: &
12
BUD_MOd = 'BUD_CC2(BUD_MOD,_)BUD_MOD_NAME'
13
character(len=*), parameter, private :: &
14
BUD_TYPe = "LL_sArray1D"
15
type LL_sArray1D
16
type(LL_sArray1D_), pointer :: D => null()
17
integer :: error_ = 0
18
end type LL_sArray1D
19
type LL_sArray1D_
20
type(LL_sArray1D_LList), pointer :: ll => null()
21
type(LL_sArray1D_LList), pointer :: head => null()
22
integer :: refs_ = 0
23
character(len=BUD_ID_LEN) :: id_ = "null_id"
24
end type LL_sArray1D_
25
type LL_sArray1D_LList
26
type(LL_sArray1D_LList), pointer :: prev => null()
27
type(LL_sArray1D_LList), pointer :: next => null()
28
type(sArray1D) :: D
29
end type
30
private :: LL_sArray1D_LList
31
interface new
32
module procedure new_
33
module procedure new_data_
34
end interface
35
public :: new
36
interface assignment(=)
37
module procedure set_data_
38
end interface
39
interface nodes
40
module procedure size_llist_
41
end interface
42
public :: nodes
43
interface size
44
module procedure size_llist_
45
end interface
46
public :: size
47
interface set_data
48
module procedure set_data_
49
module procedure set_data_idx_
50
end interface
51
public :: set_data
52
interface add_node
53
module procedure add_node_
54
module procedure add_node_data_
55
end interface
56
public :: add_node
57
interface get_data
58
module procedure get_node_data_idx_
59
end interface
60
public :: get_data
61
interface get_node
62
module procedure get_node_data_idx_
63
end interface
64
public :: get_node
65
interface set_head
66
module procedure set_head_idx_
67
end interface
68
public :: set_head
69
interface itt_step
70
module procedure itt_step_
71
module procedure itt_step_i_
72
end interface
73
public :: itt_step
74
interface remove_node
75
module procedure remove_node_
76
end interface
77
public :: remove_node
78
interface remove_node_data
79
module procedure remove_node_data_
80
end interface
81
public :: remove_node_data
82
interface copy_list
83
module procedure copy_
84
end interface
85
public :: copy_list
86
public :: LL_sArray1D
87
private :: LL_sArray1D_
88
interface assignment(=)
89
module procedure common_assign_
90
end interface
91
public :: assignment(=)
92
private :: common_assign_
93
interface initialize
94
module procedure common_initialize_
95
end interface
96
public :: initialize
97
private :: common_initialize_
98
interface is_initialized
99
module procedure common_is_initialized_
100
end interface
101
public :: is_initialized
102
private :: common_is_initialized_
103
interface initialized
104
module procedure common_is_initialized_
105
end interface
106
public :: initialized
107
interface is_initd
108
module procedure common_is_initialized_
109
end interface
110
public :: is_initd
111
interface is_same
112
module procedure common_is_same_
113
end interface
114
public :: is_same
115
private :: common_is_same_
116
interface same
117
module procedure common_is_same_
118
end interface
119
public :: same
120
interface delete
121
module procedure common_delete_
122
end interface
123
public :: delete
124
private :: common_delete_
125
interface nullify
126
module procedure common_nullify_
127
end interface
128
public :: nullify
129
private :: common_nullify_
130
interface copy
131
module procedure copy_
132
end interface
133
public :: copy
134
private :: common_copy_
135
interface print
136
module procedure print_
137
end interface
138
public :: print
139
interface references
140
module procedure common_references_
141
end interface
142
public :: references
143
private :: common_references_
144
interface refs
145
module procedure common_references_
146
end interface
147
public :: refs
148
interface set_error
149
module procedure common_set_error_is_
150
module procedure common_set_error_ii_
151
module procedure common_set_error_il_
152
end interface
153
public :: set_error
154
private :: common_set_error_is_
155
private :: common_set_error_ii_
156
private :: common_set_error_il_
157
interface error
158
module procedure common_error_
159
end interface
160
public :: error
161
private :: common_error_
162
contains
163
subroutine common_copy_(from, to)
164
type(LL_sArray1D), intent(in) :: from
165
type(LL_sArray1D), intent(inout) :: to
166
call set_error(to, error(from))
167
end subroutine common_copy_
168
subroutine common_initialize_(this)
169
type(LL_sArray1D), intent(inout) :: this
170
integer :: error
171
call delete(this)
172
allocate(this%D, stat=error)
173
call set_error(this, error)
174
if ( error /= 0 ) return
175
this%D%refs_ = 1
176
call common_tag_object_(this)
177
end subroutine common_initialize_
178
pure function common_is_initialized_(this) result(init)
179
type(LL_sArray1D), intent(in) :: this
180
logical :: init
181
init = associated(this%D)
182
end function common_is_initialized_
183
elemental function common_is_same_(lhs, rhs) result(same)
184
type(LL_sArray1D), intent(in) :: lhs, rhs
185
logical :: same
186
same = is_initd(lhs) .and. is_initd(rhs)
187
if ( .not. same ) return
188
same = associated(lhs%D, target=rhs%D)
189
end function common_is_same_
190
subroutine common_delete_(this)
191
type(LL_sArray1D), intent(inout) :: this
192
integer :: error
193
call set_error(this, 0)
194
if (.not. is_initd(this) ) return
195
this%D%refs_ = this%D%refs_ - 1
196
if ( 0 == this%D%refs_ ) then
197
call delete_(this)
198
deallocate(this%D, stat=error)
199
call set_error(this, error)
200
end if
201
nullify(this%D)
202
end subroutine common_delete_
203
elemental subroutine common_nullify_(this)
204
type(LL_sArray1D), intent(inout) :: this
205
if (.not. is_initd(this) ) return
206
nullify(this%D)
207
end subroutine common_nullify_
208
subroutine common_assign_(lhs, rhs)
209
type(LL_sArray1D), intent(inout) :: lhs
210
type(LL_sArray1D), intent(in) :: rhs
211
call delete(lhs)
212
if ( .not. is_initd(rhs) ) return
213
lhs%D => rhs%D
214
lhs%D%refs_ = rhs%D%refs_ + 1
215
end subroutine common_assign_
216
elemental function common_references_(this) result(refs)
217
type(LL_sArray1D), intent(in) :: this
218
integer :: refs
219
if ( is_initd(this) ) then
220
refs = this%D%refs_
221
else
222
refs = 0
223
end if
224
end function common_references_
225
elemental function common_error_(this) result(error)
226
type(LL_sArray1D), intent(in) :: this
227
integer :: error
228
if ( is_initd(this) ) then
229
error = this%error_
230
else
231
error = 0
232
end if
233
end function common_error_
234
elemental subroutine common_set_error_is_(this, error)
235
type(LL_sArray1D), intent(inout) :: this
236
integer(is_), intent(in) :: error
237
this%error_ = error
238
end subroutine common_set_error_is_
239
elemental subroutine common_set_error_ii_(this, error)
240
type(LL_sArray1D), intent(inout) :: this
241
integer(ii_), intent(in) :: error
242
this%error_ = error
243
end subroutine common_set_error_ii_
244
elemental subroutine common_set_error_il_(this, error)
245
type(LL_sArray1D), intent(inout) :: this
246
integer(il_), intent(in) :: error
247
this%error_ = error
248
end subroutine common_set_error_il_
249
elemental function common_id_(this) result(str)
250
type(LL_sArray1D), intent(in) :: this
251
character(len=BUD_ID_LEn) :: str
252
str = this%D%id_
253
end function common_id_
254
subroutine common_tag_object_(this)
255
type(LL_sArray1D), intent(inout) :: this
256
end subroutine common_tag_object_
257
subroutine delete_(this)
258
type(LL_sArray1D), intent(inout) :: this
259
type(LL_sArray1D_LList), pointer :: head, tmp
260
if ( associated(this%D%head) .and. .not. &
261
associated(this%D%ll) ) then
262
nullify(this%D%head)
263
nullify(this%D%ll)
264
return
265
end if
266
head => this%D%ll
267
if ( associated(head) ) then
268
do while ( associated(head%prev) )
269
if ( associated(head%prev, this%D%ll) ) exit
270
head => head%prev
271
end do
272
if ( associated(head%prev, this%D%ll) ) then
273
head => this%D%ll
274
end if
275
head => head%next
276
tmp => head
277
do while ( associated(head) )
278
if ( associated(head%next, this%D%ll) ) exit
279
head => head%next
280
call delete(tmp%D)
281
deallocate(tmp)
282
tmp => head
283
end do
284
end if
285
if ( associated(this%D%ll) ) then
286
call delete(this%D%ll%D)
287
deallocate(this%D%ll)
288
end if
289
nullify(this%D%ll)
290
nullify(this%D%head)
291
end subroutine delete_
292
subroutine new_(this)
293
type(LL_sArray1D), intent(inout) :: this
294
call initialize(this)
295
end subroutine new_
296
subroutine new_data_(this, D)
297
type(LL_sArray1D), intent(inout) :: this
298
type(sArray1D), intent(in) :: D
299
call new(this)
300
allocate(this%D%ll)
301
this%D%head => this%D%ll
302
this%D%head%D = D
303
end subroutine new_data_
304
subroutine get_ll_headp(this, head)
305
type(LL_sArray1D), intent(in) :: this
306
type(LL_sArray1D_LList), pointer :: head
307
if ( .not. is_initd(this) ) then
308
nullify(head)
309
return
310
end if
311
head => this%D%head
312
do while ( associated(head%prev) )
313
head => head%prev
314
if ( associated(head, this%D%head) ) exit
315
end do
316
end subroutine get_ll_headp
317
subroutine get_ll_tailp(this, tail)
318
type(LL_sArray1D), intent(in) :: this
319
type(LL_sArray1D_LList), pointer :: tail
320
if ( .not. is_initd(this) ) then
321
nullify(tail)
322
return
323
end if
324
tail => this%D%head
325
do while ( associated(tail%next) )
326
tail => tail%next
327
if ( associated(tail, this%D%head) ) exit
328
end do
329
end subroutine get_ll_tailp
330
subroutine get_ll_idxp(this, node, index)
331
type(LL_sArray1D), intent(in), target :: this
332
type(LL_sArray1D_LList), pointer :: node
333
integer, intent(in), optional :: index
334
integer :: lindex
335
nullify(node)
336
if ( .not. is_initd(this) ) return
337
lindex = 0
338
if ( present(index) ) lindex = index
339
node => this%D%head
340
do while ( lindex < 0 .and. associated(node%prev) )
341
node => node%prev
342
lindex = lindex + 1
343
end do
344
do while ( lindex > 0 .and. associated(node%next) )
345
node => node%next
346
lindex = lindex - 1
347
end do
348
if ( lindex /= 0 ) then
349
nullify(node)
350
return
351
end if
352
end subroutine get_ll_idxp
353
subroutine append_node(ll)
354
type(LL_sArray1D_LList), pointer :: ll
355
type(LL_sArray1D_LList), pointer :: tmp => null()
356
if ( .not. associated(ll) ) return
357
allocate(tmp)
358
tmp%next => ll%next
359
tmp%prev => ll
360
if ( associated(ll%next) ) then
361
ll%next%prev => tmp
362
end if
363
ll%next => tmp
364
nullify(tmp)
365
end subroutine append_node
366
function size_llist_(this) result (nnodes)
367
type(LL_sArray1D), intent(in), target :: this
368
integer :: nnodes
369
type(LL_sArray1D_LList), pointer :: head, tmp
370
nnodes = 0
371
if ( .not. is_initd(this) ) return
372
call get_ll_headp(this, head)
373
tmp => head
374
do while ( associated(tmp) )
375
nnodes = nnodes + 1
376
tmp => tmp%next
377
if ( associated(tmp, head) ) exit
378
end do
379
end function size_llist_
380
subroutine add_node_(this)
381
type(LL_sArray1D), intent(inout) :: this
382
type(LL_sArray1D_LList), pointer :: tail
383
if ( .not. is_initd(this) ) then
384
call new(this)
385
allocate(this%D%ll)
386
this%D%head => this%D%ll
387
return
388
end if
389
call get_ll_tailp(this, tail)
390
call append_node(tail)
391
end subroutine add_node_
392
subroutine add_node_data_(this, D)
393
type(LL_sArray1D), intent(inout) :: this
394
type(sArray1D), intent(in) :: D
395
type(LL_sArray1D_LList), pointer :: tail
396
call get_ll_tailp(this, tail)
397
if ( .not. associated(tail) ) then
398
call new(this, D)
399
return
400
end if
401
call append_node(tail)
402
tail%next%D = D
403
end subroutine add_node_data_
404
subroutine set_data_(this, D)
405
type(LL_sArray1D), intent(inout) :: this
406
type(sArray1D), intent(in) :: D
407
if ( is_initd(this) ) then
408
this%D%head%D = D
409
end if
410
end subroutine set_data_
411
subroutine set_data_idx_(this, D, index)
412
type(LL_sArray1D), intent(inout) :: this
413
type(sArray1D), intent(in) :: D
414
integer, intent(in) :: index
415
type(LL_sArray1D_LList), pointer :: node
416
call get_ll_idxp(this, node, index)
417
if ( .not. associated(node) ) return
418
node%D = D
419
end subroutine set_data_idx_
420
subroutine set_head_idx_(this, index)
421
type(LL_sArray1D), intent(inout) :: this
422
integer, intent(in) :: index
423
type(LL_sArray1D_LList), pointer :: node
424
call get_ll_idxp(this, node, index)
425
if ( .not. associated(node) ) return
426
this%D%head => node
427
end subroutine set_head_idx_
428
subroutine get_node_data_idx_(this, D, index)
429
type(LL_sArray1D), intent(in), target :: this
430
type(sArray1D), intent(inout) :: D
431
integer, intent(in), optional :: index
432
type(LL_sArray1D_LList), pointer :: node
433
call delete(D)
434
if ( .not. is_initd(this) ) return
435
call get_ll_idxp(this, node, index)
436
if ( associated(node) ) D = node%D
437
end subroutine get_node_data_idx_
438
function itt_step_(this, itt) result(itterated)
439
type(LL_sArray1D), intent(in) :: this
440
type(LL_sArray1D), intent(inout) :: itt
441
logical :: itterated
442
itterated = .false.
443
if ( .not. is_initd(this) ) then
444
call delete(itt)
445
return
446
end if
447
if ( .not. is_initd(itt) ) then
448
call new(itt)
449
itt%D%head => this%D%head
450
itterated = associated(itt%D%head)
451
else
452
itt%D%head => itt%D%head%next
453
itterated = associated(itt%D%head)
454
if ( itterated ) then
455
itterated = .not. associated(itt%D%head, this%D%head)
456
end if
457
end if
458
if ( .not. itterated ) then
459
call delete(itt)
460
end if
461
end function itt_step_
462
function itt_step_i_(this, itt, i) result(itterated)
463
type(LL_sArray1D), intent(in) :: this
464
type(LL_sArray1D), intent(inout) :: itt
465
integer, intent(in) :: i
466
logical :: itterated
467
integer :: is
468
itterated = .false.
469
if ( .not. is_initd(this) ) then
470
call delete(itt)
471
return
472
end if
473
is = 0
474
if ( .not. is_initd(itt) ) then
475
call new(itt)
476
itt%D%head => this%D%head
477
itterated = associated(itt%D%head)
478
else if ( i > 0 ) then
479
do while ( is /= i )
480
is = is + 1
481
itt%D%head => itt%D%head%next
482
itterated = associated(itt%D%head)
483
if ( itterated ) then
484
itterated = .not. associated(itt%D%head, this%D%head)
485
end if
486
if ( .not. itterated ) exit
487
end do
488
else if ( i < 0 ) then
489
do while ( is /= i )
490
is = is - 1
491
itt%D%head => itt%D%head%prev
492
itterated = associated(itt%D%head)
493
if ( itterated ) then
494
itterated = .not. associated(itt%D%head, this%D%head)
495
end if
496
if ( .not. itterated ) exit
497
end do
498
end if
499
if ( .not. itterated ) then
500
nullify(itt%D%head)
501
call delete(itt)
502
end if
503
end function itt_step_i_
504
subroutine remove_node_(this, index)
505
type(LL_sArray1D), intent(inout), target :: this
506
integer, intent(in) :: index
507
type(LL_sArray1D_LList), pointer :: node, pnode, nnode
508
if ( .not. is_initd(this) ) return
509
call get_ll_idxp(this, node, index)
510
if ( .not. associated(node) ) return
511
pnode => node%prev
512
nnode => node%next
513
nullify(node%prev)
514
nullify(node%next)
515
if ( associated(pnode) ) then
516
pnode%next => nnode
517
end if
518
if ( associated(nnode) ) then
519
nnode%prev => pnode
520
end if
521
call delete(node%D)
522
deallocate(node)
523
end subroutine remove_node_
524
subroutine remove_node_data_(this, index)
525
type(LL_sArray1D), intent(inout), target :: this
526
integer, intent(in), optional :: index
527
type(LL_sArray1D_LList), pointer :: node
528
if ( .not. is_initd(this) ) return
529
call get_ll_idxp(this, node, index)
530
if ( .not. associated(node) ) return
531
call delete(node%D)
532
end subroutine remove_node_data_
533
subroutine copy_(from, to)
534
type(LL_sArray1D), intent(inout) :: from, to
535
type(LL_sArray1D_LList), pointer :: t, f
536
call delete(to)
537
if ( .not. is_initd(from) ) return
538
call new(to)
539
f => from%D%head
540
t => to%D%head
541
t%D = f%D
542
do while ( associated(f%next) )
543
f => f%next
544
allocate(t%next)
545
t%next%prev => t
546
t => t%next
547
t%D = f%D
548
if ( associated(t, to%D%head) ) return
549
end do
550
f => from%D%head
551
t => to%D%head
552
do while ( associated(f%prev) )
553
f => f%prev
554
allocate(t%prev)
555
t%prev%next => t
556
t => t%prev
557
t%D = f%D
558
end do
559
end subroutine copy_
560
subroutine print_(this, info, indent)
561
type(LL_sArray1D), intent(in), target :: this
562
character(len=*), intent(in), optional :: info
563
integer, intent(in), optional :: indent
564
integer :: lindent
565
type(LL_sArray1D_LList), pointer :: node
566
character(len=32) :: fmt
567
character(len=256) :: name
568
name = "LL_sArray1D"
569
if ( present(info) ) name = info
570
lindent = 1
571
if ( present(indent) ) lindent = indent
572
write(fmt, '(a,i0,a)') '(t',lindent,',3a)'
573
if ( .not. is_initd(this) ) then
574
write(*,fmt) "<", trim(name), " not initialized>"
575
return
576
end if
577
write(fmt, '(a,i0,a)') '(t',lindent,',3a,i0,a)'
578
write(*,fmt) "<<", trim(name), " llist, nodes=",nodes(this),">"
579
lindent = lindent + 2 ! step indentation
580
call get_ll_headp(this, node)
581
do while ( associated(node) )
582
if ( associated(node, this%D%head) ) then
583
write(fmt, '(a,i0,a)') '(t',lindent,',a)'
584
call print(node%D, indent = lindent+2)
585
else
586
call print(node%D, indent = lindent)
587
end if
588
node => node%next
589
end do
590
lindent = lindent - 2 ! go back to requested indentation
591
write(fmt, '(a,i0,a)') '(t',lindent,',a,i0,a)'
592
write(*,fmt) " <llist-refs: ", references(this), ">>"
593
end subroutine print_
594
end module
595
module bud_LL_iArray1D
596
use bud_iArray1D
597
implicit none
598
private
599
integer, parameter :: rr_ = selected_real_kind(p=6) ! single (real*4)
600
integer, parameter :: rd_ = selected_real_kind(p=15) ! double (real*8)
601
integer, parameter :: is_ = selected_int_kind(4) ! short (integer*2)
602
integer, parameter :: ii_ = selected_int_kind(9) ! int (integer*4)
603
integer, parameter :: il_ = selected_int_kind(18) ! long (integer*8)
604
integer, parameter, private :: BUD_ID_LEn = 36
605
character(len=*), parameter, private :: &
606
BUD_MOd = 'BUD_CC2(BUD_MOD,_)BUD_MOD_NAME'
607
character(len=*), parameter, private :: &
608
BUD_TYPe = "LL_iArray1D"
609
type LL_iArray1D
610
type(LL_iArray1D_), pointer :: D => null()
611
integer :: error_ = 0
612
end type LL_iArray1D
613
type LL_iArray1D_
614
type(LL_iArray1D_LList), pointer :: ll => null()
615
type(LL_iArray1D_LList), pointer :: head => null()
616
integer :: refs_ = 0
617
character(len=BUD_ID_LEN) :: id_ = "null_id"
618
end type LL_iArray1D_
619
type LL_iArray1D_LList
620
type(LL_iArray1D_LList), pointer :: prev => null()
621
type(LL_iArray1D_LList), pointer :: next => null()
622
type(iArray1D) :: D
623
end type
624
private :: LL_iArray1D_LList
625
interface new
626
module procedure new_
627
module procedure new_data_
628
end interface
629
public :: new
630
interface assignment(=)
631
module procedure set_data_
632
end interface
633
interface nodes
634
module procedure size_llist_
635
end interface
636
public :: nodes
637
interface size
638
module procedure size_llist_
639
end interface
640
public :: size
641
interface set_data
642
module procedure set_data_
643
module procedure set_data_idx_
644
end interface
645
public :: set_data
646
interface add_node
647
module procedure add_node_
648
module procedure add_node_data_
649
end interface
650
public :: add_node
651
interface get_data
652
module procedure get_node_data_idx_
653
end interface
654
public :: get_data
655
interface get_node
656
module procedure get_node_data_idx_
657
end interface
658
public :: get_node
659
interface set_head
660
module procedure set_head_idx_
661
end interface
662
public :: set_head
663
interface itt_step
664
module procedure itt_step_
665
module procedure itt_step_i_
666
end interface
667
public :: itt_step
668
interface remove_node
669
module procedure remove_node_
670
end interface
671
public :: remove_node
672
interface remove_node_data
673
module procedure remove_node_data_
674
end interface
675
public :: remove_node_data
676
interface copy_list
677
module procedure copy_
678
end interface
679
public :: copy_list
680
public :: LL_iArray1D
681
private :: LL_iArray1D_
682
interface assignment(=)
683
module procedure common_assign_
684
end interface
685
public :: assignment(=)
686
private :: common_assign_
687
interface initialize
688
module procedure common_initialize_
689
end interface
690
public :: initialize
691
private :: common_initialize_
692
interface is_initialized
693
module procedure common_is_initialized_
694
end interface
695
public :: is_initialized
696
private :: common_is_initialized_
697
interface initialized
698
module procedure common_is_initialized_
699
end interface
700
public :: initialized
701
interface is_initd
702
module procedure common_is_initialized_
703
end interface
704
public :: is_initd
705
interface is_same
706
module procedure common_is_same_
707
end interface
708
public :: is_same
709
private :: common_is_same_
710
interface same
711
module procedure common_is_same_
712
end interface
713
public :: same
714
interface delete
715
module procedure common_delete_
716
end interface
717
public :: delete
718
private :: common_delete_
719
interface nullify
720
module procedure common_nullify_
721
end interface
722
public :: nullify
723
private :: common_nullify_
724
interface copy
725
module procedure copy_
726
end interface
727
public :: copy
728
private :: common_copy_
729
interface print
730
module procedure print_
731
end interface
732
public :: print
733
interface references
734
module procedure common_references_
735
end interface
736
public :: references
737
private :: common_references_
738
interface refs
739
module procedure common_references_
740
end interface
741
public :: refs
742
interface set_error
743
module procedure common_set_error_is_
744
module procedure common_set_error_ii_
745
module procedure common_set_error_il_
746
end interface
747
public :: set_error
748
private :: common_set_error_is_
749
private :: common_set_error_ii_
750
private :: common_set_error_il_
751
interface error
752
module procedure common_error_
753
end interface
754
public :: error
755
private :: common_error_
756
contains
757
subroutine common_copy_(from, to)
758
type(LL_iArray1D), intent(in) :: from
759
type(LL_iArray1D), intent(inout) :: to
760
call set_error(to, error(from))
761
end subroutine common_copy_
762
subroutine common_initialize_(this)
763
type(LL_iArray1D), intent(inout) :: this
764
integer :: error
765
call delete(this)
766
allocate(this%D, stat=error)
767
call set_error(this, error)
768
if ( error /= 0 ) return
769
this%D%refs_ = 1
770
call common_tag_object_(this)
771
end subroutine common_initialize_
772
pure function common_is_initialized_(this) result(init)
773
type(LL_iArray1D), intent(in) :: this
774
logical :: init
775
init = associated(this%D)
776
end function common_is_initialized_
777
elemental function common_is_same_(lhs, rhs) result(same)
778
type(LL_iArray1D), intent(in) :: lhs, rhs
779
logical :: same
780
same = is_initd(lhs) .and. is_initd(rhs)
781
if ( .not. same ) return
782
same = associated(lhs%D, target=rhs%D)
783
end function common_is_same_
784
subroutine common_delete_(this)
785
type(LL_iArray1D), intent(inout) :: this
786
integer :: error
787
call set_error(this, 0)
788
if (.not. is_initd(this) ) return
789
this%D%refs_ = this%D%refs_ - 1
790
if ( 0 == this%D%refs_ ) then
791
call delete_(this)
792
deallocate(this%D, stat=error)
793
call set_error(this, error)
794
end if
795
nullify(this%D)
796
end subroutine common_delete_
797
elemental subroutine common_nullify_(this)
798
type(LL_iArray1D), intent(inout) :: this
799
if (.not. is_initd(this) ) return
800
nullify(this%D)
801
end subroutine common_nullify_
802
subroutine common_assign_(lhs, rhs)
803
type(LL_iArray1D), intent(inout) :: lhs
804
type(LL_iArray1D), intent(in) :: rhs
805
call delete(lhs)
806
if ( .not. is_initd(rhs) ) return
807
lhs%D => rhs%D
808
lhs%D%refs_ = rhs%D%refs_ + 1
809
end subroutine common_assign_
810
elemental function common_references_(this) result(refs)
811
type(LL_iArray1D), intent(in) :: this
812
integer :: refs
813
if ( is_initd(this) ) then
814
refs = this%D%refs_
815
else
816
refs = 0
817
end if
818
end function common_references_
819
elemental function common_error_(this) result(error)
820
type(LL_iArray1D), intent(in) :: this
821
integer :: error
822
if ( is_initd(this) ) then
823
error = this%error_
824
else
825
error = 0
826
end if
827
end function common_error_
828
elemental subroutine common_set_error_is_(this, error)
829
type(LL_iArray1D), intent(inout) :: this
830
integer(is_), intent(in) :: error
831
this%error_ = error
832
end subroutine common_set_error_is_
833
elemental subroutine common_set_error_ii_(this, error)
834
type(LL_iArray1D), intent(inout) :: this
835
integer(ii_), intent(in) :: error
836
this%error_ = error
837
end subroutine common_set_error_ii_
838
elemental subroutine common_set_error_il_(this, error)
839
type(LL_iArray1D), intent(inout) :: this
840
integer(il_), intent(in) :: error
841
this%error_ = error
842
end subroutine common_set_error_il_
843
elemental function common_id_(this) result(str)
844
type(LL_iArray1D), intent(in) :: this
845
character(len=BUD_ID_LEn) :: str
846
str = this%D%id_
847
end function common_id_
848
subroutine common_tag_object_(this)
849
type(LL_iArray1D), intent(inout) :: this
850
end subroutine common_tag_object_
851
subroutine delete_(this)
852
type(LL_iArray1D), intent(inout) :: this
853
type(LL_iArray1D_LList), pointer :: head, tmp
854
if ( associated(this%D%head) .and. .not. &
855
associated(this%D%ll) ) then
856
nullify(this%D%head)
857
nullify(this%D%ll)
858
return
859
end if
860
head => this%D%ll
861
if ( associated(head) ) then
862
do while ( associated(head%prev) )
863
if ( associated(head%prev, this%D%ll) ) exit
864
head => head%prev
865
end do
866
if ( associated(head%prev, this%D%ll) ) then
867
head => this%D%ll
868
end if
869
head => head%next
870
tmp => head
871
do while ( associated(head) )
872
if ( associated(head%next, this%D%ll) ) exit
873
head => head%next
874
call delete(tmp%D)
875
deallocate(tmp)
876
tmp => head
877
end do
878
end if
879
if ( associated(this%D%ll) ) then
880
call delete(this%D%ll%D)
881
deallocate(this%D%ll)
882
end if
883
nullify(this%D%ll)
884
nullify(this%D%head)
885
end subroutine delete_
886
subroutine new_(this)
887
type(LL_iArray1D), intent(inout) :: this
888
call initialize(this)
889
end subroutine new_
890
subroutine new_data_(this, D)
891
type(LL_iArray1D), intent(inout) :: this
892
type(iArray1D), intent(in) :: D
893
call new(this)
894
allocate(this%D%ll)
895
this%D%head => this%D%ll
896
this%D%head%D = D
897
end subroutine new_data_
898
subroutine get_ll_headp(this, head)
899
type(LL_iArray1D), intent(in) :: this
900
type(LL_iArray1D_LList), pointer :: head
901
if ( .not. is_initd(this) ) then
902
nullify(head)
903
return
904
end if
905
head => this%D%head
906
do while ( associated(head%prev) )
907
head => head%prev
908
if ( associated(head, this%D%head) ) exit
909
end do
910
end subroutine get_ll_headp
911
subroutine get_ll_tailp(this, tail)
912
type(LL_iArray1D), intent(in) :: this
913
type(LL_iArray1D_LList), pointer :: tail
914
if ( .not. is_initd(this) ) then
915
nullify(tail)
916
return
917
end if
918
tail => this%D%head
919
do while ( associated(tail%next) )
920
tail => tail%next
921
if ( associated(tail, this%D%head) ) exit
922
end do
923
end subroutine get_ll_tailp
924
subroutine get_ll_idxp(this, node, index)
925
type(LL_iArray1D), intent(in), target :: this
926
type(LL_iArray1D_LList), pointer :: node
927
integer, intent(in), optional :: index
928
integer :: lindex
929
nullify(node)
930
if ( .not. is_initd(this) ) return
931
lindex = 0
932
if ( present(index) ) lindex = index
933
node => this%D%head
934
do while ( lindex < 0 .and. associated(node%prev) )
935
node => node%prev
936
lindex = lindex + 1
937
end do
938
do while ( lindex > 0 .and. associated(node%next) )
939
node => node%next
940
lindex = lindex - 1
941
end do
942
if ( lindex /= 0 ) then
943
nullify(node)
944
return
945
end if
946
end subroutine get_ll_idxp
947
subroutine append_node(ll)
948
type(LL_iArray1D_LList), pointer :: ll
949
type(LL_iArray1D_LList), pointer :: tmp => null()
950
if ( .not. associated(ll) ) return
951
allocate(tmp)
952
tmp%next => ll%next
953
tmp%prev => ll
954
if ( associated(ll%next) ) then
955
ll%next%prev => tmp
956
end if
957
ll%next => tmp
958
nullify(tmp)
959
end subroutine append_node
960
function size_llist_(this) result (nnodes)
961
type(LL_iArray1D), intent(in), target :: this
962
integer :: nnodes
963
type(LL_iArray1D_LList), pointer :: head, tmp
964
nnodes = 0
965
if ( .not. is_initd(this) ) return
966
call get_ll_headp(this, head)
967
tmp => head
968
do while ( associated(tmp) )
969
nnodes = nnodes + 1
970
tmp => tmp%next
971
if ( associated(tmp, head) ) exit
972
end do
973
end function size_llist_
974
subroutine add_node_(this)
975
type(LL_iArray1D), intent(inout) :: this
976
type(LL_iArray1D_LList), pointer :: tail
977
if ( .not. is_initd(this) ) then
978
call new(this)
979
allocate(this%D%ll)
980
this%D%head => this%D%ll
981
return
982
end if
983
call get_ll_tailp(this, tail)
984
call append_node(tail)
985
end subroutine add_node_
986
subroutine add_node_data_(this, D)
987
type(LL_iArray1D), intent(inout) :: this
988
type(iArray1D), intent(in) :: D
989
type(LL_iArray1D_LList), pointer :: tail
990
call get_ll_tailp(this, tail)
991
if ( .not. associated(tail) ) then
992
call new(this, D)
993
return
994
end if
995
call append_node(tail)
996
tail%next%D = D
997
end subroutine add_node_data_
998
subroutine set_data_(this, D)
999
type(LL_iArray1D), intent(inout) :: this
1000
type(iArray1D), intent(in) :: D
1001
if ( is_initd(this) ) then
1002
this%D%head%D = D
1003
end if
1004
end subroutine set_data_
1005
subroutine set_data_idx_(this, D, index)
1006
type(LL_iArray1D), intent(inout) :: this
1007
type(iArray1D), intent(in) :: D
1008
integer, intent(in) :: index
1009
type(LL_iArray1D_LList), pointer :: node
1010
call get_ll_idxp(this, node, index)
1011
if ( .not. associated(node) ) return
1012
node%D = D
1013
end subroutine set_data_idx_
1014
subroutine set_head_idx_(this, index)
1015
type(LL_iArray1D), intent(inout) :: this
1016
integer, intent(in) :: index
1017
type(LL_iArray1D_LList), pointer :: node
1018
call get_ll_idxp(this, node, index)
1019
if ( .not. associated(node) ) return
1020
this%D%head => node
1021
end subroutine set_head_idx_
1022
subroutine get_node_data_idx_(this, D, index)
1023
type(LL_iArray1D), intent(in), target :: this
1024
type(iArray1D), intent(inout) :: D
1025
integer, intent(in), optional :: index
1026
type(LL_iArray1D_LList), pointer :: node
1027
call delete(D)
1028
if ( .not. is_initd(this) ) return
1029
call get_ll_idxp(this, node, index)
1030
if ( associated(node) ) D = node%D
1031
end subroutine get_node_data_idx_
1032
function itt_step_(this, itt) result(itterated)
1033
type(LL_iArray1D), intent(in) :: this
1034
type(LL_iArray1D), intent(inout) :: itt
1035
logical :: itterated
1036
itterated = .false.
1037
if ( .not. is_initd(this) ) then
1038
call delete(itt)
1039
return
1040
end if
1041
if ( .not. is_initd(itt) ) then
1042
call new(itt)
1043
itt%D%head => this%D%head
1044
itterated = associated(itt%D%head)
1045
else
1046
itt%D%head => itt%D%head%next
1047
itterated = associated(itt%D%head)
1048
if ( itterated ) then
1049
itterated = .not. associated(itt%D%head, this%D%head)
1050
end if
1051
end if
1052
if ( .not. itterated ) then
1053
call delete(itt)
1054
end if
1055
end function itt_step_
1056
function itt_step_i_(this, itt, i) result(itterated)
1057
type(LL_iArray1D), intent(in) :: this
1058
type(LL_iArray1D), intent(inout) :: itt
1059
integer, intent(in) :: i
1060
logical :: itterated
1061
integer :: is
1062
itterated = .false.
1063
if ( .not. is_initd(this) ) then
1064
call delete(itt)
1065
return
1066
end if
1067
is = 0
1068
if ( .not. is_initd(itt) ) then
1069
call new(itt)
1070
itt%D%head => this%D%head
1071
itterated = associated(itt%D%head)
1072
else if ( i > 0 ) then
1073
do while ( is /= i )
1074
is = is + 1
1075
itt%D%head => itt%D%head%next
1076
itterated = associated(itt%D%head)
1077
if ( itterated ) then
1078
itterated = .not. associated(itt%D%head, this%D%head)
1079
end if
1080
if ( .not. itterated ) exit
1081
end do
1082
else if ( i < 0 ) then
1083
do while ( is /= i )
1084
is = is - 1
1085
itt%D%head => itt%D%head%prev
1086
itterated = associated(itt%D%head)
1087
if ( itterated ) then
1088
itterated = .not. associated(itt%D%head, this%D%head)
1089
end if
1090
if ( .not. itterated ) exit
1091
end do
1092
end if
1093
if ( .not. itterated ) then
1094
nullify(itt%D%head)
1095
call delete(itt)
1096
end if
1097
end function itt_step_i_
1098
subroutine remove_node_(this, index)
1099
type(LL_iArray1D), intent(inout), target :: this
1100
integer, intent(in) :: index
1101
type(LL_iArray1D_LList), pointer :: node, pnode, nnode
1102
if ( .not. is_initd(this) ) return
1103
call get_ll_idxp(this, node, index)
1104
if ( .not. associated(node) ) return
1105
pnode => node%prev
1106
nnode => node%next
1107
nullify(node%prev)
1108
nullify(node%next)
1109
if ( associated(pnode) ) then
1110
pnode%next => nnode
1111
end if
1112
if ( associated(nnode) ) then
1113
nnode%prev => pnode
1114
end if
1115
call delete(node%D)
1116
deallocate(node)
1117
end subroutine remove_node_
1118
subroutine remove_node_data_(this, index)
1119
type(LL_iArray1D), intent(inout), target :: this
1120
integer, intent(in), optional :: index
1121
type(LL_iArray1D_LList), pointer :: node
1122
if ( .not. is_initd(this) ) return
1123
call get_ll_idxp(this, node, index)
1124
if ( .not. associated(node) ) return
1125
call delete(node%D)
1126
end subroutine remove_node_data_
1127
subroutine copy_(from, to)
1128
type(LL_iArray1D), intent(inout) :: from, to
1129
type(LL_iArray1D_LList), pointer :: t, f
1130
call delete(to)
1131
if ( .not. is_initd(from) ) return
1132
call new(to)
1133
f => from%D%head
1134
t => to%D%head
1135
t%D = f%D
1136
do while ( associated(f%next) )
1137
f => f%next
1138
allocate(t%next)
1139
t%next%prev => t
1140
t => t%next
1141
t%D = f%D
1142
if ( associated(t, to%D%head) ) return
1143
end do
1144
f => from%D%head
1145
t => to%D%head
1146
do while ( associated(f%prev) )
1147
f => f%prev
1148
allocate(t%prev)
1149
t%prev%next => t
1150
t => t%prev
1151
t%D = f%D
1152
end do
1153
end subroutine copy_
1154
subroutine print_(this, info, indent)
1155
type(LL_iArray1D), intent(in), target :: this
1156
character(len=*), intent(in), optional :: info
1157
integer, intent(in), optional :: indent
1158
integer :: lindent
1159
type(LL_iArray1D_LList), pointer :: node
1160
character(len=32) :: fmt
1161
character(len=256) :: name
1162
name = "LL_iArray1D"
1163
if ( present(info) ) name = info
1164
lindent = 1
1165
if ( present(indent) ) lindent = indent
1166
write(fmt, '(a,i0,a)') '(t',lindent,',3a)'
1167
if ( .not. is_initd(this) ) then
1168
write(*,fmt) "<", trim(name), " not initialized>"
1169
return
1170
end if
1171
write(fmt, '(a,i0,a)') '(t',lindent,',3a,i0,a)'
1172
write(*,fmt) "<<", trim(name), " llist, nodes=",nodes(this),">"
1173
lindent = lindent + 2 ! step indentation
1174
call get_ll_headp(this, node)
1175
do while ( associated(node) )
1176
if ( associated(node, this%D%head) ) then
1177
write(fmt, '(a,i0,a)') '(t',lindent,',a)'
1178
call print(node%D, indent = lindent+2)
1179
else
1180
call print(node%D, indent = lindent)
1181
end if
1182
node => node%next
1183
end do
1184
lindent = lindent - 2 ! go back to requested indentation
1185
write(fmt, '(a,i0,a)') '(t',lindent,',a,i0,a)'
1186
write(*,fmt) " <llist-refs: ", references(this), ">>"
1187
end subroutine print_
1188
end module
1189
module bud_LL_lArray1D
1190
use bud_lArray1D
1191
implicit none
1192
private
1193
integer, parameter :: rr_ = selected_real_kind(p=6) ! single (real*4)
1194
integer, parameter :: rd_ = selected_real_kind(p=15) ! double (real*8)
1195
integer, parameter :: is_ = selected_int_kind(4) ! short (integer*2)
1196
integer, parameter :: ii_ = selected_int_kind(9) ! int (integer*4)
1197
integer, parameter :: il_ = selected_int_kind(18) ! long (integer*8)
1198
integer, parameter, private :: BUD_ID_LEn = 36
1199
character(len=*), parameter, private :: &
1200
BUD_MOd = 'BUD_CC2(BUD_MOD,_)BUD_MOD_NAME'
1201
character(len=*), parameter, private :: &
1202
BUD_TYPe = "LL_lArray1D"
1203
type LL_lArray1D
1204
type(LL_lArray1D_), pointer :: D => null()
1205
integer :: error_ = 0
1206
end type LL_lArray1D
1207
type LL_lArray1D_
1208
type(LL_lArray1D_LList), pointer :: ll => null()
1209
type(LL_lArray1D_LList), pointer :: head => null()
1210
integer :: refs_ = 0
1211
character(len=BUD_ID_LEN) :: id_ = "null_id"
1212
end type LL_lArray1D_
1213
type LL_lArray1D_LList
1214
type(LL_lArray1D_LList), pointer :: prev => null()
1215
type(LL_lArray1D_LList), pointer :: next => null()
1216
type(lArray1D) :: D
1217
end type
1218
private :: LL_lArray1D_LList
1219
interface new
1220
module procedure new_
1221
module procedure new_data_
1222
end interface
1223
public :: new
1224
interface assignment(=)
1225
module procedure set_data_
1226
end interface
1227
interface nodes
1228
module procedure size_llist_
1229
end interface
1230
public :: nodes
1231
interface size
1232
module procedure size_llist_
1233
end interface
1234
public :: size
1235
interface set_data
1236
module procedure set_data_
1237
module procedure set_data_idx_
1238
end interface
1239
public :: set_data
1240
interface add_node
1241
module procedure add_node_
1242
module procedure add_node_data_
1243
end interface
1244
public :: add_node
1245
interface get_data
1246
module procedure get_node_data_idx_
1247
end interface
1248
public :: get_data
1249
interface get_node
1250
module procedure get_node_data_idx_
1251
end interface
1252
public :: get_node
1253
interface set_head
1254
module procedure set_head_idx_
1255
end interface
1256
public :: set_head
1257
interface itt_step
1258
module procedure itt_step_
1259
module procedure itt_step_i_
1260
end interface
1261
public :: itt_step
1262
interface remove_node
1263
module procedure remove_node_
1264
end interface
1265
public :: remove_node
1266
interface remove_node_data
1267
module procedure remove_node_data_
1268
end interface
1269
public :: remove_node_data
1270
interface copy_list
1271
module procedure copy_
1272
end interface
1273
public :: copy_list
1274
public :: LL_lArray1D
1275
private :: LL_lArray1D_
1276
interface assignment(=)
1277
module procedure common_assign_
1278
end interface
1279
public :: assignment(=)
1280
private :: common_assign_
1281
interface initialize
1282
module procedure common_initialize_
1283
end interface
1284
public :: initialize
1285
private :: common_initialize_
1286
interface is_initialized
1287
module procedure common_is_initialized_
1288
end interface
1289
public :: is_initialized
1290
private :: common_is_initialized_
1291
interface initialized
1292
module procedure common_is_initialized_
1293
end interface
1294
public :: initialized
1295
interface is_initd
1296
module procedure common_is_initialized_
1297
end interface
1298
public :: is_initd
1299
interface is_same
1300
module procedure common_is_same_
1301
end interface
1302
public :: is_same
1303
private :: common_is_same_
1304
interface same
1305
module procedure common_is_same_
1306
end interface
1307
public :: same
1308
interface delete
1309
module procedure common_delete_
1310
end interface
1311
public :: delete
1312
private :: common_delete_
1313
interface nullify
1314
module procedure common_nullify_
1315
end interface
1316
public :: nullify
1317
private :: common_nullify_
1318
interface copy
1319
module procedure copy_
1320
end interface
1321
public :: copy
1322
private :: common_copy_
1323
interface print
1324
module procedure print_
1325
end interface
1326
public :: print
1327
interface references
1328
module procedure common_references_
1329
end interface
1330
public :: references
1331
private :: common_references_
1332
interface refs
1333
module procedure common_references_
1334
end interface
1335
public :: refs
1336
interface set_error
1337
module procedure common_set_error_is_
1338
module procedure common_set_error_ii_
1339
module procedure common_set_error_il_
1340
end interface
1341
public :: set_error
1342
private :: common_set_error_is_
1343
private :: common_set_error_ii_
1344
private :: common_set_error_il_
1345
interface error
1346
module procedure common_error_
1347
end interface
1348
public :: error
1349
private :: common_error_
1350
contains
1351
subroutine common_copy_(from, to)
1352
type(LL_lArray1D), intent(in) :: from
1353
type(LL_lArray1D), intent(inout) :: to
1354
call set_error(to, error(from))
1355
end subroutine common_copy_
1356
subroutine common_initialize_(this)
1357
type(LL_lArray1D), intent(inout) :: this
1358
integer :: error
1359
call delete(this)
1360
allocate(this%D, stat=error)
1361
call set_error(this, error)
1362
if ( error /= 0 ) return
1363
this%D%refs_ = 1
1364
call common_tag_object_(this)
1365
end subroutine common_initialize_
1366
pure function common_is_initialized_(this) result(init)
1367
type(LL_lArray1D), intent(in) :: this
1368
logical :: init
1369
init = associated(this%D)
1370
end function common_is_initialized_
1371
elemental function common_is_same_(lhs, rhs) result(same)
1372
type(LL_lArray1D), intent(in) :: lhs, rhs
1373
logical :: same
1374
same = is_initd(lhs) .and. is_initd(rhs)
1375
if ( .not. same ) return
1376
same = associated(lhs%D, target=rhs%D)
1377
end function common_is_same_
1378
subroutine common_delete_(this)
1379
type(LL_lArray1D), intent(inout) :: this
1380
integer :: error
1381
call set_error(this, 0)
1382
if (.not. is_initd(this) ) return
1383
this%D%refs_ = this%D%refs_ - 1
1384
if ( 0 == this%D%refs_ ) then
1385
call delete_(this)
1386
deallocate(this%D, stat=error)
1387
call set_error(this, error)
1388
end if
1389
nullify(this%D)
1390
end subroutine common_delete_
1391
elemental subroutine common_nullify_(this)
1392
type(LL_lArray1D), intent(inout) :: this
1393
if (.not. is_initd(this) ) return
1394
nullify(this%D)
1395
end subroutine common_nullify_
1396
subroutine common_assign_(lhs, rhs)
1397
type(LL_lArray1D), intent(inout) :: lhs
1398
type(LL_lArray1D), intent(in) :: rhs
1399
call delete(lhs)
1400
if ( .not. is_initd(rhs) ) return
1401
lhs%D => rhs%D
1402
lhs%D%refs_ = rhs%D%refs_ + 1
1403
end subroutine common_assign_
1404
elemental function common_references_(this) result(refs)
1405
type(LL_lArray1D), intent(in) :: this
1406
integer :: refs
1407
if ( is_initd(this) ) then
1408
refs = this%D%refs_
1409
else
1410
refs = 0
1411
end if
1412
end function common_references_
1413
elemental function common_error_(this) result(error)
1414
type(LL_lArray1D), intent(in) :: this
1415
integer :: error
1416
if ( is_initd(this) ) then
1417
error = this%error_
1418
else
1419
error = 0
1420
end if
1421
end function common_error_
1422
elemental subroutine common_set_error_is_(this, error)
1423
type(LL_lArray1D), intent(inout) :: this
1424
integer(is_), intent(in) :: error
1425
this%error_ = error
1426
end subroutine common_set_error_is_
1427
elemental subroutine common_set_error_ii_(this, error)
1428
type(LL_lArray1D), intent(inout) :: this
1429
integer(ii_), intent(in) :: error
1430
this%error_ = error
1431
end subroutine common_set_error_ii_
1432
elemental subroutine common_set_error_il_(this, error)
1433
type(LL_lArray1D), intent(inout) :: this
1434
integer(il_), intent(in) :: error
1435
this%error_ = error
1436
end subroutine common_set_error_il_
1437
elemental function common_id_(this) result(str)
1438
type(LL_lArray1D), intent(in) :: this
1439
character(len=BUD_ID_LEn) :: str
1440
str = this%D%id_
1441
end function common_id_
1442
subroutine common_tag_object_(this)
1443
type(LL_lArray1D), intent(inout) :: this
1444
end subroutine common_tag_object_
1445
subroutine delete_(this)
1446
type(LL_lArray1D), intent(inout) :: this
1447
type(LL_lArray1D_LList), pointer :: head, tmp
1448
if ( associated(this%D%head) .and. .not. &
1449
associated(this%D%ll) ) then
1450
nullify(this%D%head)
1451
nullify(this%D%ll)
1452
return
1453
end if
1454
head => this%D%ll
1455
if ( associated(head) ) then
1456
do while ( associated(head%prev) )
1457
if ( associated(head%prev, this%D%ll) ) exit
1458
head => head%prev
1459
end do
1460
if ( associated(head%prev, this%D%ll) ) then
1461
head => this%D%ll
1462
end if
1463
head => head%next
1464
tmp => head
1465
do while ( associated(head) )
1466
if ( associated(head%next, this%D%ll) ) exit
1467
head => head%next
1468
call delete(tmp%D)
1469
deallocate(tmp)
1470
tmp => head
1471
end do
1472
end if
1473
if ( associated(this%D%ll) ) then
1474
call delete(this%D%ll%D)
1475
deallocate(this%D%ll)
1476
end if
1477
nullify(this%D%ll)
1478
nullify(this%D%head)
1479
end subroutine delete_
1480
subroutine new_(this)
1481
type(LL_lArray1D), intent(inout) :: this
1482
call initialize(this)
1483
end subroutine new_
1484
subroutine new_data_(this, D)
1485
type(LL_lArray1D), intent(inout) :: this
1486
type(lArray1D), intent(in) :: D
1487
call new(this)
1488
allocate(this%D%ll)
1489
this%D%head => this%D%ll
1490
this%D%head%D = D
1491
end subroutine new_data_
1492
subroutine get_ll_headp(this, head)
1493
type(LL_lArray1D), intent(in) :: this
1494
type(LL_lArray1D_LList), pointer :: head
1495
if ( .not. is_initd(this) ) then
1496
nullify(head)
1497
return
1498
end if
1499
head => this%D%head
1500
do while ( associated(head%prev) )
1501
head => head%prev
1502
if ( associated(head, this%D%head) ) exit
1503
end do
1504
end subroutine get_ll_headp
1505
subroutine get_ll_tailp(this, tail)
1506
type(LL_lArray1D), intent(in) :: this
1507
type(LL_lArray1D_LList), pointer :: tail
1508
if ( .not. is_initd(this) ) then
1509
nullify(tail)
1510
return
1511
end if
1512
tail => this%D%head
1513
do while ( associated(tail%next) )
1514
tail => tail%next
1515
if ( associated(tail, this%D%head) ) exit
1516
end do
1517
end subroutine get_ll_tailp
1518
subroutine get_ll_idxp(this, node, index)
1519
type(LL_lArray1D), intent(in), target :: this
1520
type(LL_lArray1D_LList), pointer :: node
1521
integer, intent(in), optional :: index
1522
integer :: lindex
1523
nullify(node)
1524
if ( .not. is_initd(this) ) return
1525
lindex = 0
1526
if ( present(index) ) lindex = index
1527
node => this%D%head
1528
do while ( lindex < 0 .and. associated(node%prev) )
1529
node => node%prev
1530
lindex = lindex + 1
1531
end do
1532
do while ( lindex > 0 .and. associated(node%next) )
1533
node => node%next
1534
lindex = lindex - 1
1535
end do
1536
if ( lindex /= 0 ) then
1537
nullify(node)
1538
return
1539
end if
1540
end subroutine get_ll_idxp
1541
subroutine append_node(ll)
1542
type(LL_lArray1D_LList), pointer :: ll
1543
type(LL_lArray1D_LList), pointer :: tmp => null()
1544
if ( .not. associated(ll) ) return
1545
allocate(tmp)
1546
tmp%next => ll%next
1547
tmp%prev => ll
1548
if ( associated(ll%next) ) then
1549
ll%next%prev => tmp
1550
end if
1551
ll%next => tmp
1552
nullify(tmp)
1553
end subroutine append_node
1554
function size_llist_(this) result (nnodes)
1555
type(LL_lArray1D), intent(in), target :: this
1556
integer :: nnodes
1557
type(LL_lArray1D_LList), pointer :: head, tmp
1558
nnodes = 0
1559
if ( .not. is_initd(this) ) return
1560
call get_ll_headp(this, head)
1561
tmp => head
1562
do while ( associated(tmp) )
1563
nnodes = nnodes + 1
1564
tmp => tmp%next
1565
if ( associated(tmp, head) ) exit
1566
end do
1567
end function size_llist_
1568
subroutine add_node_(this)
1569
type(LL_lArray1D), intent(inout) :: this
1570
type(LL_lArray1D_LList), pointer :: tail
1571
if ( .not. is_initd(this) ) then
1572
call new(this)
1573
allocate(this%D%ll)
1574
this%D%head => this%D%ll
1575
return
1576
end if
1577
call get_ll_tailp(this, tail)
1578
call append_node(tail)
1579
end subroutine add_node_
1580
subroutine add_node_data_(this, D)
1581
type(LL_lArray1D), intent(inout) :: this
1582
type(lArray1D), intent(in) :: D
1583
type(LL_lArray1D_LList), pointer :: tail
1584
call get_ll_tailp(this, tail)
1585
if ( .not. associated(tail) ) then
1586
call new(this, D)
1587
return
1588
end if
1589
call append_node(tail)
1590
tail%next%D = D
1591
end subroutine add_node_data_
1592
subroutine set_data_(this, D)
1593
type(LL_lArray1D), intent(inout) :: this
1594
type(lArray1D), intent(in) :: D
1595
if ( is_initd(this) ) then
1596
this%D%head%D = D
1597
end if
1598
end subroutine set_data_
1599
subroutine set_data_idx_(this, D, index)
1600
type(LL_lArray1D), intent(inout) :: this
1601
type(lArray1D), intent(in) :: D
1602
integer, intent(in) :: index
1603
type(LL_lArray1D_LList), pointer :: node
1604
call get_ll_idxp(this, node, index)
1605
if ( .not. associated(node) ) return
1606
node%D = D
1607
end subroutine set_data_idx_
1608
subroutine set_head_idx_(this, index)
1609
type(LL_lArray1D), intent(inout) :: this
1610
integer, intent(in) :: index
1611
type(LL_lArray1D_LList), pointer :: node
1612
call get_ll_idxp(this, node, index)
1613
if ( .not. associated(node) ) return
1614
this%D%head => node
1615
end subroutine set_head_idx_
1616
subroutine get_node_data_idx_(this, D, index)
1617
type(LL_lArray1D), intent(in), target :: this
1618
type(lArray1D), intent(inout) :: D
1619
integer, intent(in), optional :: index
1620
type(LL_lArray1D_LList), pointer :: node
1621
call delete(D)
1622
if ( .not. is_initd(this) ) return
1623
call get_ll_idxp(this, node, index)
1624
if ( associated(node) ) D = node%D
1625
end subroutine get_node_data_idx_
1626
function itt_step_(this, itt) result(itterated)
1627
type(LL_lArray1D), intent(in) :: this
1628
type(LL_lArray1D), intent(inout) :: itt
1629
logical :: itterated
1630
itterated = .false.
1631
if ( .not. is_initd(this) ) then
1632
call delete(itt)
1633
return
1634
end if
1635
if ( .not. is_initd(itt) ) then
1636
call new(itt)
1637
itt%D%head => this%D%head
1638
itterated = associated(itt%D%head)
1639
else
1640
itt%D%head => itt%D%head%next
1641
itterated = associated(itt%D%head)
1642
if ( itterated ) then
1643
itterated = .not. associated(itt%D%head, this%D%head)
1644
end if
1645
end if
1646
if ( .not. itterated ) then
1647
call delete(itt)
1648
end if
1649
end function itt_step_
1650
function itt_step_i_(this, itt, i) result(itterated)
1651
type(LL_lArray1D), intent(in) :: this
1652
type(LL_lArray1D), intent(inout) :: itt
1653
integer, intent(in) :: i
1654
logical :: itterated
1655
integer :: is
1656
itterated = .false.
1657
if ( .not. is_initd(this) ) then
1658
call delete(itt)
1659
return
1660
end if
1661
is = 0
1662
if ( .not. is_initd(itt) ) then
1663
call new(itt)
1664
itt%D%head => this%D%head
1665
itterated = associated(itt%D%head)
1666
else if ( i > 0 ) then
1667
do while ( is /= i )
1668
is = is + 1
1669
itt%D%head => itt%D%head%next
1670
itterated = associated(itt%D%head)
1671
if ( itterated ) then
1672
itterated = .not. associated(itt%D%head, this%D%head)
1673
end if
1674
if ( .not. itterated ) exit
1675
end do
1676
else if ( i < 0 ) then
1677
do while ( is /= i )
1678
is = is - 1
1679
itt%D%head => itt%D%head%prev
1680
itterated = associated(itt%D%head)
1681
if ( itterated ) then
1682
itterated = .not. associated(itt%D%head, this%D%head)
1683
end if
1684
if ( .not. itterated ) exit
1685
end do
1686
end if
1687
if ( .not. itterated ) then
1688
nullify(itt%D%head)
1689
call delete(itt)
1690
end if
1691
end function itt_step_i_
1692
subroutine remove_node_(this, index)
1693
type(LL_lArray1D), intent(inout), target :: this
1694
integer, intent(in) :: index
1695
type(LL_lArray1D_LList), pointer :: node, pnode, nnode
1696
if ( .not. is_initd(this) ) return
1697
call get_ll_idxp(this, node, index)
1698
if ( .not. associated(node) ) return
1699
pnode => node%prev
1700
nnode => node%next
1701
nullify(node%prev)
1702
nullify(node%next)
1703
if ( associated(pnode) ) then
1704
pnode%next => nnode
1705
end if
1706
if ( associated(nnode) ) then
1707
nnode%prev => pnode
1708
end if
1709
call delete(node%D)
1710
deallocate(node)
1711
end subroutine remove_node_
1712
subroutine remove_node_data_(this, index)
1713
type(LL_lArray1D), intent(inout), target :: this
1714
integer, intent(in), optional :: index
1715
type(LL_lArray1D_LList), pointer :: node
1716
if ( .not. is_initd(this) ) return
1717
call get_ll_idxp(this, node, index)
1718
if ( .not. associated(node) ) return
1719
call delete(node%D)
1720
end subroutine remove_node_data_
1721
subroutine copy_(from, to)
1722
type(LL_lArray1D), intent(inout) :: from, to
1723
type(LL_lArray1D_LList), pointer :: t, f
1724
call delete(to)
1725
if ( .not. is_initd(from) ) return
1726
call new(to)
1727
f => from%D%head
1728
t => to%D%head
1729
t%D = f%D
1730
do while ( associated(f%next) )
1731
f => f%next
1732
allocate(t%next)
1733
t%next%prev => t
1734
t => t%next
1735
t%D = f%D
1736
if ( associated(t, to%D%head) ) return
1737
end do
1738
f => from%D%head
1739
t => to%D%head
1740
do while ( associated(f%prev) )
1741
f => f%prev
1742
allocate(t%prev)
1743
t%prev%next => t
1744
t => t%prev
1745
t%D = f%D
1746
end do
1747
end subroutine copy_
1748
subroutine print_(this, info, indent)
1749
type(LL_lArray1D), intent(in), target :: this
1750
character(len=*), intent(in), optional :: info
1751
integer, intent(in), optional :: indent
1752
integer :: lindent
1753
type(LL_lArray1D_LList), pointer :: node
1754
character(len=32) :: fmt
1755
character(len=256) :: name
1756
name = "LL_lArray1D"
1757
if ( present(info) ) name = info
1758
lindent = 1
1759
if ( present(indent) ) lindent = indent
1760
write(fmt, '(a,i0,a)') '(t',lindent,',3a)'
1761
if ( .not. is_initd(this) ) then
1762
write(*,fmt) "<", trim(name), " not initialized>"
1763
return
1764
end if
1765
write(fmt, '(a,i0,a)') '(t',lindent,',3a,i0,a)'
1766
write(*,fmt) "<<", trim(name), " llist, nodes=",nodes(this),">"
1767
lindent = lindent + 2 ! step indentation
1768
call get_ll_headp(this, node)
1769
do while ( associated(node) )
1770
if ( associated(node, this%D%head) ) then
1771
write(fmt, '(a,i0,a)') '(t',lindent,',a)'
1772
call print(node%D, indent = lindent+2)
1773
else
1774
call print(node%D, indent = lindent)
1775
end if
1776
node => node%next
1777
end do
1778
lindent = lindent - 2 ! go back to requested indentation
1779
write(fmt, '(a,i0,a)') '(t',lindent,',a,i0,a)'
1780
write(*,fmt) " <llist-refs: ", references(this), ">>"
1781
end subroutine print_
1782
end module
1783
module bud_LL_rArray1D
1784
use bud_rArray1D
1785
implicit none
1786
private
1787
integer, parameter :: rr_ = selected_real_kind(p=6) ! single (real*4)
1788
integer, parameter :: rd_ = selected_real_kind(p=15) ! double (real*8)
1789
integer, parameter :: is_ = selected_int_kind(4) ! short (integer*2)
1790
integer, parameter :: ii_ = selected_int_kind(9) ! int (integer*4)
1791
integer, parameter :: il_ = selected_int_kind(18) ! long (integer*8)
1792
integer, parameter, private :: BUD_ID_LEn = 36
1793
character(len=*), parameter, private :: &
1794
BUD_MOd = 'BUD_CC2(BUD_MOD,_)BUD_MOD_NAME'
1795
character(len=*), parameter, private :: &
1796
BUD_TYPe = "LL_rArray1D"
1797
type LL_rArray1D
1798
type(LL_rArray1D_), pointer :: D => null()
1799
integer :: error_ = 0
1800
end type LL_rArray1D
1801
type LL_rArray1D_
1802
type(LL_rArray1D_LList), pointer :: ll => null()
1803
type(LL_rArray1D_LList), pointer :: head => null()
1804
integer :: refs_ = 0
1805
character(len=BUD_ID_LEN) :: id_ = "null_id"
1806
end type LL_rArray1D_
1807
type LL_rArray1D_LList
1808
type(LL_rArray1D_LList), pointer :: prev => null()
1809
type(LL_rArray1D_LList), pointer :: next => null()
1810
type(rArray1D) :: D
1811
end type
1812
private :: LL_rArray1D_LList
1813
interface new
1814
module procedure new_
1815
module procedure new_data_
1816
end interface
1817
public :: new
1818
interface assignment(=)
1819
module procedure set_data_
1820
end interface
1821
interface nodes
1822
module procedure size_llist_
1823
end interface
1824
public :: nodes
1825
interface size
1826
module procedure size_llist_
1827
end interface
1828
public :: size
1829
interface set_data
1830
module procedure set_data_
1831
module procedure set_data_idx_
1832
end interface
1833
public :: set_data
1834
interface add_node
1835
module procedure add_node_
1836
module procedure add_node_data_
1837
end interface
1838
public :: add_node
1839
interface get_data
1840
module procedure get_node_data_idx_
1841
end interface
1842
public :: get_data
1843
interface get_node
1844
module procedure get_node_data_idx_
1845
end interface
1846
public :: get_node
1847
interface set_head
1848
module procedure set_head_idx_
1849
end interface
1850
public :: set_head
1851
interface itt_step
1852
module procedure itt_step_
1853
module procedure itt_step_i_
1854
end interface
1855
public :: itt_step
1856
interface remove_node
1857
module procedure remove_node_
1858
end interface
1859
public :: remove_node
1860
interface remove_node_data
1861
module procedure remove_node_data_
1862
end interface
1863
public :: remove_node_data
1864
interface copy_list
1865
module procedure copy_
1866
end interface
1867
public :: copy_list
1868
public :: LL_rArray1D
1869
private :: LL_rArray1D_
1870
interface assignment(=)
1871
module procedure common_assign_
1872
end interface
1873
public :: assignment(=)
1874
private :: common_assign_
1875
interface initialize
1876
module procedure common_initialize_
1877
end interface
1878
public :: initialize
1879
private :: common_initialize_
1880
interface is_initialized
1881
module procedure common_is_initialized_
1882
end interface
1883
public :: is_initialized
1884
private :: common_is_initialized_
1885
interface initialized
1886
module procedure common_is_initialized_
1887
end interface
1888
public :: initialized
1889
interface is_initd
1890
module procedure common_is_initialized_
1891
end interface
1892
public :: is_initd
1893
interface is_same
1894
module procedure common_is_same_
1895
end interface
1896
public :: is_same
1897
private :: common_is_same_
1898
interface same
1899
module procedure common_is_same_
1900
end interface
1901
public :: same
1902
interface delete
1903
module procedure common_delete_
1904
end interface
1905
public :: delete
1906
private :: common_delete_
1907
interface nullify
1908
module procedure common_nullify_
1909
end interface
1910
public :: nullify
1911
private :: common_nullify_
1912
interface copy
1913
module procedure copy_
1914
end interface
1915
public :: copy
1916
private :: common_copy_
1917
interface print
1918
module procedure print_
1919
end interface
1920
public :: print
1921
interface references
1922
module procedure common_references_
1923
end interface
1924
public :: references
1925
private :: common_references_
1926
interface refs
1927
module procedure common_references_
1928
end interface
1929
public :: refs
1930
interface set_error
1931
module procedure common_set_error_is_
1932
module procedure common_set_error_ii_
1933
module procedure common_set_error_il_
1934
end interface
1935
public :: set_error
1936
private :: common_set_error_is_
1937
private :: common_set_error_ii_
1938
private :: common_set_error_il_
1939
interface error
1940
module procedure common_error_
1941
end interface
1942
public :: error
1943
private :: common_error_
1944
contains
1945
subroutine common_copy_(from, to)
1946
type(LL_rArray1D), intent(in) :: from
1947
type(LL_rArray1D), intent(inout) :: to
1948
call set_error(to, error(from))
1949
end subroutine common_copy_
1950
subroutine common_initialize_(this)
1951
type(LL_rArray1D), intent(inout) :: this
1952
integer :: error
1953
call delete(this)
1954
allocate(this%D, stat=error)
1955
call set_error(this, error)
1956
if ( error /= 0 ) return
1957
this%D%refs_ = 1
1958
call common_tag_object_(this)
1959
end subroutine common_initialize_
1960
pure function common_is_initialized_(this) result(init)
1961
type(LL_rArray1D), intent(in) :: this
1962
logical :: init
1963
init = associated(this%D)
1964
end function common_is_initialized_
1965
elemental function common_is_same_(lhs, rhs) result(same)
1966
type(LL_rArray1D), intent(in) :: lhs, rhs
1967
logical :: same
1968
same = is_initd(lhs) .and. is_initd(rhs)
1969
if ( .not. same ) return
1970
same = associated(lhs%D, target=rhs%D)
1971
end function common_is_same_
1972
subroutine common_delete_(this)
1973
type(LL_rArray1D), intent(inout) :: this
1974
integer :: error
1975
call set_error(this, 0)
1976
if (.not. is_initd(this) ) return
1977
this%D%refs_ = this%D%refs_ - 1
1978
if ( 0 == this%D%refs_ ) then
1979
call delete_(this)
1980
deallocate(this%D, stat=error)
1981
call set_error(this, error)
1982
end if
1983
nullify(this%D)
1984
end subroutine common_delete_
1985
elemental subroutine common_nullify_(this)
1986
type(LL_rArray1D), intent(inout) :: this
1987
if (.not. is_initd(this) ) return
1988
nullify(this%D)
1989
end subroutine common_nullify_
1990
subroutine common_assign_(lhs, rhs)
1991
type(LL_rArray1D), intent(inout) :: lhs
1992
type(LL_rArray1D), intent(in) :: rhs
1993
call delete(lhs)
1994
if ( .not. is_initd(rhs) ) return
1995
lhs%D => rhs%D
1996
lhs%D%refs_ = rhs%D%refs_ + 1
1997
end subroutine common_assign_
1998
elemental function common_references_(this) result(refs)
1999
type(LL_rArray1D), intent(in) :: this
2000
integer :: refs
2001
if ( is_initd(this) ) then
2002
refs = this%D%refs_
2003
else
2004
refs = 0
2005
end if
2006
end function common_references_
2007
elemental function common_error_(this) result(error)
2008
type(LL_rArray1D), intent(in) :: this
2009
integer :: error
2010
if ( is_initd(this) ) then
2011
error = this%error_
2012
else
2013
error = 0
2014
end if
2015
end function common_error_
2016
elemental subroutine common_set_error_is_(this, error)
2017
type(LL_rArray1D), intent(inout) :: this
2018
integer(is_), intent(in) :: error
2019
this%error_ = error
2020
end subroutine common_set_error_is_
2021
elemental subroutine common_set_error_ii_(this, error)
2022
type(LL_rArray1D), intent(inout) :: this
2023
integer(ii_), intent(in) :: error
2024
this%error_ = error
2025
end subroutine common_set_error_ii_
2026
elemental subroutine common_set_error_il_(this, error)
2027
type(LL_rArray1D), intent(inout) :: this
2028
integer(il_), intent(in) :: error
2029
this%error_ = error
2030
end subroutine common_set_error_il_
2031
elemental function common_id_(this) result(str)
2032
type(LL_rArray1D), intent(in) :: this
2033
character(len=BUD_ID_LEn) :: str
2034
str = this%D%id_
2035
end function common_id_
2036
subroutine common_tag_object_(this)
2037
type(LL_rArray1D), intent(inout) :: this
2038
end subroutine common_tag_object_
2039
subroutine delete_(this)
2040
type(LL_rArray1D), intent(inout) :: this
2041
type(LL_rArray1D_LList), pointer :: head, tmp
2042
if ( associated(this%D%head) .and. .not. &
2043
associated(this%D%ll) ) then
2044
nullify(this%D%head)
2045
nullify(this%D%ll)
2046
return
2047
end if
2048
head => this%D%ll
2049
if ( associated(head) ) then
2050
do while ( associated(head%prev) )
2051
if ( associated(head%prev, this%D%ll) ) exit
2052
head => head%prev
2053
end do
2054
if ( associated(head%prev, this%D%ll) ) then
2055
head => this%D%ll
2056
end if
2057
head => head%next
2058
tmp => head
2059
do while ( associated(head) )
2060
if ( associated(head%next, this%D%ll) ) exit
2061
head => head%next
2062
call delete(tmp%D)
2063
deallocate(tmp)
2064
tmp => head
2065
end do
2066
end if
2067
if ( associated(this%D%ll) ) then
2068
call delete(this%D%ll%D)
2069
deallocate(this%D%ll)
2070
end if
2071
nullify(this%D%ll)
2072
nullify(this%D%head)
2073
end subroutine delete_
2074
subroutine new_(this)
2075
type(LL_rArray1D), intent(inout) :: this
2076
call initialize(this)
2077
end subroutine new_
2078
subroutine new_data_(this, D)
2079
type(LL_rArray1D), intent(inout) :: this
2080
type(rArray1D), intent(in) :: D
2081
call new(this)
2082
allocate(this%D%ll)
2083
this%D%head => this%D%ll
2084
this%D%head%D = D
2085
end subroutine new_data_
2086
subroutine get_ll_headp(this, head)
2087
type(LL_rArray1D), intent(in) :: this
2088
type(LL_rArray1D_LList), pointer :: head
2089
if ( .not. is_initd(this) ) then
2090
nullify(head)
2091
return
2092
end if
2093
head => this%D%head
2094
do while ( associated(head%prev) )
2095
head => head%prev
2096
if ( associated(head, this%D%head) ) exit
2097
end do
2098
end subroutine get_ll_headp
2099
subroutine get_ll_tailp(this, tail)
2100
type(LL_rArray1D), intent(in) :: this
2101
type(LL_rArray1D_LList), pointer :: tail
2102
if ( .not. is_initd(this) ) then
2103
nullify(tail)
2104
return
2105
end if
2106
tail => this%D%head
2107
do while ( associated(tail%next) )
2108
tail => tail%next
2109
if ( associated(tail, this%D%head) ) exit
2110
end do
2111
end subroutine get_ll_tailp
2112
subroutine get_ll_idxp(this, node, index)
2113
type(LL_rArray1D), intent(in), target :: this
2114
type(LL_rArray1D_LList), pointer :: node
2115
integer, intent(in), optional :: index
2116
integer :: lindex
2117
nullify(node)
2118
if ( .not. is_initd(this) ) return
2119
lindex = 0
2120
if ( present(index) ) lindex = index
2121
node => this%D%head
2122
do while ( lindex < 0 .and. associated(node%prev) )
2123
node => node%prev
2124
lindex = lindex + 1
2125
end do
2126
do while ( lindex > 0 .and. associated(node%next) )
2127
node => node%next
2128
lindex = lindex - 1
2129
end do
2130
if ( lindex /= 0 ) then
2131
nullify(node)
2132
return
2133
end if
2134
end subroutine get_ll_idxp
2135
subroutine append_node(ll)
2136
type(LL_rArray1D_LList), pointer :: ll
2137
type(LL_rArray1D_LList), pointer :: tmp => null()
2138
if ( .not. associated(ll) ) return
2139
allocate(tmp)
2140
tmp%next => ll%next
2141
tmp%prev => ll
2142
if ( associated(ll%next) ) then
2143
ll%next%prev => tmp
2144
end if
2145
ll%next => tmp
2146
nullify(tmp)
2147
end subroutine append_node
2148
function size_llist_(this) result (nnodes)
2149
type(LL_rArray1D), intent(in), target :: this
2150
integer :: nnodes
2151
type(LL_rArray1D_LList), pointer :: head, tmp
2152
nnodes = 0
2153
if ( .not. is_initd(this) ) return
2154
call get_ll_headp(this, head)
2155
tmp => head
2156
do while ( associated(tmp) )
2157
nnodes = nnodes + 1
2158
tmp => tmp%next
2159
if ( associated(tmp, head) ) exit
2160
end do
2161
end function size_llist_
2162
subroutine add_node_(this)
2163
type(LL_rArray1D), intent(inout) :: this
2164
type(LL_rArray1D_LList), pointer :: tail
2165
if ( .not. is_initd(this) ) then
2166
call new(this)
2167
allocate(this%D%ll)
2168
this%D%head => this%D%ll
2169
return
2170
end if
2171
call get_ll_tailp(this, tail)
2172
call append_node(tail)
2173
end subroutine add_node_
2174
subroutine add_node_data_(this, D)
2175
type(LL_rArray1D), intent(inout) :: this
2176
type(rArray1D), intent(in) :: D
2177
type(LL_rArray1D_LList), pointer :: tail
2178
call get_ll_tailp(this, tail)
2179
if ( .not. associated(tail) ) then
2180
call new(this, D)
2181
return
2182
end if
2183
call append_node(tail)
2184
tail%next%D = D
2185
end subroutine add_node_data_
2186
subroutine set_data_(this, D)
2187
type(LL_rArray1D), intent(inout) :: this
2188
type(rArray1D), intent(in) :: D
2189
if ( is_initd(this) ) then
2190
this%D%head%D = D
2191
end if
2192
end subroutine set_data_
2193
subroutine set_data_idx_(this, D, index)
2194
type(LL_rArray1D), intent(inout) :: this
2195
type(rArray1D), intent(in) :: D
2196
integer, intent(in) :: index
2197
type(LL_rArray1D_LList), pointer :: node
2198
call get_ll_idxp(this, node, index)
2199
if ( .not. associated(node) ) return
2200
node%D = D
2201
end subroutine set_data_idx_
2202
subroutine set_head_idx_(this, index)
2203
type(LL_rArray1D), intent(inout) :: this
2204
integer, intent(in) :: index
2205
type(LL_rArray1D_LList), pointer :: node
2206
call get_ll_idxp(this, node, index)
2207
if ( .not. associated(node) ) return
2208
this%D%head => node
2209
end subroutine set_head_idx_
2210
subroutine get_node_data_idx_(this, D, index)
2211
type(LL_rArray1D), intent(in), target :: this
2212
type(rArray1D), intent(inout) :: D
2213
integer, intent(in), optional :: index
2214
type(LL_rArray1D_LList), pointer :: node
2215
call delete(D)
2216
if ( .not. is_initd(this) ) return
2217
call get_ll_idxp(this, node, index)
2218
if ( associated(node) ) D = node%D
2219
end subroutine get_node_data_idx_
2220
function itt_step_(this, itt) result(itterated)
2221
type(LL_rArray1D), intent(in) :: this
2222
type(LL_rArray1D), intent(inout) :: itt
2223
logical :: itterated
2224
itterated = .false.
2225
if ( .not. is_initd(this) ) then
2226
call delete(itt)
2227
return
2228
end if
2229
if ( .not. is_initd(itt) ) then
2230
call new(itt)
2231
itt%D%head => this%D%head
2232
itterated = associated(itt%D%head)
2233
else
2234
itt%D%head => itt%D%head%next
2235
itterated = associated(itt%D%head)
2236
if ( itterated ) then
2237
itterated = .not. associated(itt%D%head, this%D%head)
2238
end if
2239
end if
2240
if ( .not. itterated ) then
2241
call delete(itt)
2242
end if
2243
end function itt_step_
2244
function itt_step_i_(this, itt, i) result(itterated)
2245
type(LL_rArray1D), intent(in) :: this
2246
type(LL_rArray1D), intent(inout) :: itt
2247
integer, intent(in) :: i
2248
logical :: itterated
2249
integer :: is
2250
itterated = .false.
2251
if ( .not. is_initd(this) ) then
2252
call delete(itt)
2253
return
2254
end if
2255
is = 0
2256
if ( .not. is_initd(itt) ) then
2257
call new(itt)
2258
itt%D%head => this%D%head
2259
itterated = associated(itt%D%head)
2260
else if ( i > 0 ) then
2261
do while ( is /= i )
2262
is = is + 1
2263
itt%D%head => itt%D%head%next
2264
itterated = associated(itt%D%head)
2265
if ( itterated ) then
2266
itterated = .not. associated(itt%D%head, this%D%head)
2267
end if
2268
if ( .not. itterated ) exit
2269
end do
2270
else if ( i < 0 ) then
2271
do while ( is /= i )
2272
is = is - 1
2273
itt%D%head => itt%D%head%prev
2274
itterated = associated(itt%D%head)
2275
if ( itterated ) then
2276
itterated = .not. associated(itt%D%head, this%D%head)
2277
end if
2278
if ( .not. itterated ) exit
2279
end do
2280
end if
2281
if ( .not. itterated ) then
2282
nullify(itt%D%head)
2283
call delete(itt)
2284
end if
2285
end function itt_step_i_
2286
subroutine remove_node_(this, index)
2287
type(LL_rArray1D), intent(inout), target :: this
2288
integer, intent(in) :: index
2289
type(LL_rArray1D_LList), pointer :: node, pnode, nnode
2290
if ( .not. is_initd(this) ) return
2291
call get_ll_idxp(this, node, index)
2292
if ( .not. associated(node) ) return
2293
pnode => node%prev
2294
nnode => node%next
2295
nullify(node%prev)
2296
nullify(node%next)
2297
if ( associated(pnode) ) then
2298
pnode%next => nnode
2299
end if
2300
if ( associated(nnode) ) then
2301
nnode%prev => pnode
2302
end if
2303
call delete(node%D)
2304
deallocate(node)
2305
end subroutine remove_node_
2306
subroutine remove_node_data_(this, index)
2307
type(LL_rArray1D), intent(inout), target :: this
2308
integer, intent(in), optional :: index
2309
type(LL_rArray1D_LList), pointer :: node
2310
if ( .not. is_initd(this) ) return
2311
call get_ll_idxp(this, node, index)
2312
if ( .not. associated(node) ) return
2313
call delete(node%D)
2314
end subroutine remove_node_data_
2315
subroutine copy_(from, to)
2316
type(LL_rArray1D), intent(inout) :: from, to
2317
type(LL_rArray1D_LList), pointer :: t, f
2318
call delete(to)
2319
if ( .not. is_initd(from) ) return
2320
call new(to)
2321
f => from%D%head
2322
t => to%D%head
2323
t%D = f%D
2324
do while ( associated(f%next) )
2325
f => f%next
2326
allocate(t%next)
2327
t%next%prev => t
2328
t => t%next
2329
t%D = f%D
2330
if ( associated(t, to%D%head) ) return
2331
end do
2332
f => from%D%head
2333
t => to%D%head
2334
do while ( associated(f%prev) )
2335
f => f%prev
2336
allocate(t%prev)
2337
t%prev%next => t
2338
t => t%prev
2339
t%D = f%D
2340
end do
2341
end subroutine copy_
2342
subroutine print_(this, info, indent)
2343
type(LL_rArray1D), intent(in), target :: this
2344
character(len=*), intent(in), optional :: info
2345
integer, intent(in), optional :: indent
2346
integer :: lindent
2347
type(LL_rArray1D_LList), pointer :: node
2348
character(len=32) :: fmt
2349
character(len=256) :: name
2350
name = "LL_rArray1D"
2351
if ( present(info) ) name = info
2352
lindent = 1
2353
if ( present(indent) ) lindent = indent
2354
write(fmt, '(a,i0,a)') '(t',lindent,',3a)'
2355
if ( .not. is_initd(this) ) then
2356
write(*,fmt) "<", trim(name), " not initialized>"
2357
return
2358
end if
2359
write(fmt, '(a,i0,a)') '(t',lindent,',3a,i0,a)'
2360
write(*,fmt) "<<", trim(name), " llist, nodes=",nodes(this),">"
2361
lindent = lindent + 2 ! step indentation
2362
call get_ll_headp(this, node)
2363
do while ( associated(node) )
2364
if ( associated(node, this%D%head) ) then
2365
write(fmt, '(a,i0,a)') '(t',lindent,',a)'
2366
call print(node%D, indent = lindent+2)
2367
else
2368
call print(node%D, indent = lindent)
2369
end if
2370
node => node%next
2371
end do
2372
lindent = lindent - 2 ! go back to requested indentation
2373
write(fmt, '(a,i0,a)') '(t',lindent,',a,i0,a)'
2374
write(*,fmt) " <llist-refs: ", references(this), ">>"
2375
end subroutine print_
2376
end module
2377
module bud_LL_dArray1D
2378
use bud_dArray1D
2379
implicit none
2380
private
2381
integer, parameter :: rr_ = selected_real_kind(p=6) ! single (real*4)
2382
integer, parameter :: rd_ = selected_real_kind(p=15) ! double (real*8)
2383
integer, parameter :: is_ = selected_int_kind(4) ! short (integer*2)
2384
integer, parameter :: ii_ = selected_int_kind(9) ! int (integer*4)
2385
integer, parameter :: il_ = selected_int_kind(18) ! long (integer*8)
2386
integer, parameter, private :: BUD_ID_LEn = 36
2387
character(len=*), parameter, private :: &
2388
BUD_MOd = 'BUD_CC2(BUD_MOD,_)BUD_MOD_NAME'
2389
character(len=*), parameter, private :: &
2390
BUD_TYPe = "LL_dArray1D"
2391
type LL_dArray1D
2392
type(LL_dArray1D_), pointer :: D => null()
2393
integer :: error_ = 0
2394
end type LL_dArray1D
2395
type LL_dArray1D_
2396
type(LL_dArray1D_LList), pointer :: ll => null()
2397
type(LL_dArray1D_LList), pointer :: head => null()
2398
integer :: refs_ = 0
2399
character(len=BUD_ID_LEN) :: id_ = "null_id"
2400
end type LL_dArray1D_
2401
type LL_dArray1D_LList
2402
type(LL_dArray1D_LList), pointer :: prev => null()
2403
type(LL_dArray1D_LList), pointer :: next => null()
2404
type(dArray1D) :: D
2405
end type
2406
private :: LL_dArray1D_LList
2407
interface new
2408
module procedure new_
2409
module procedure new_data_
2410
end interface
2411
public :: new
2412
interface assignment(=)
2413
module procedure set_data_
2414
end interface
2415
interface nodes
2416
module procedure size_llist_
2417
end interface
2418
public :: nodes
2419
interface size
2420
module procedure size_llist_
2421
end interface
2422
public :: size
2423
interface set_data
2424
module procedure set_data_
2425
module procedure set_data_idx_
2426
end interface
2427
public :: set_data
2428
interface add_node
2429
module procedure add_node_
2430
module procedure add_node_data_
2431
end interface
2432
public :: add_node
2433
interface get_data
2434
module procedure get_node_data_idx_
2435
end interface
2436
public :: get_data
2437
interface get_node
2438
module procedure get_node_data_idx_
2439
end interface
2440
public :: get_node
2441
interface set_head
2442
module procedure set_head_idx_
2443
end interface
2444
public :: set_head
2445
interface itt_step
2446
module procedure itt_step_
2447
module procedure itt_step_i_
2448
end interface
2449
public :: itt_step
2450
interface remove_node
2451
module procedure remove_node_
2452
end interface
2453
public :: remove_node
2454
interface remove_node_data
2455
module procedure remove_node_data_
2456
end interface
2457
public :: remove_node_data
2458
interface copy_list
2459
module procedure copy_
2460
end interface
2461
public :: copy_list
2462
public :: LL_dArray1D
2463
private :: LL_dArray1D_
2464
interface assignment(=)
2465
module procedure common_assign_
2466
end interface
2467
public :: assignment(=)
2468
private :: common_assign_
2469
interface initialize
2470
module procedure common_initialize_
2471
end interface
2472
public :: initialize
2473
private :: common_initialize_
2474
interface is_initialized
2475
module procedure common_is_initialized_
2476
end interface
2477
public :: is_initialized
2478
private :: common_is_initialized_
2479
interface initialized
2480
module procedure common_is_initialized_
2481
end interface
2482
public :: initialized
2483
interface is_initd
2484
module procedure common_is_initialized_
2485
end interface
2486
public :: is_initd
2487
interface is_same
2488
module procedure common_is_same_
2489
end interface
2490
public :: is_same
2491
private :: common_is_same_
2492
interface same
2493
module procedure common_is_same_
2494
end interface
2495
public :: same
2496
interface delete
2497
module procedure common_delete_
2498
end interface
2499
public :: delete
2500
private :: common_delete_
2501
interface nullify
2502
module procedure common_nullify_
2503
end interface
2504
public :: nullify
2505
private :: common_nullify_
2506
interface copy
2507
module procedure copy_
2508
end interface
2509
public :: copy
2510
private :: common_copy_
2511
interface print
2512
module procedure print_
2513
end interface
2514
public :: print
2515
interface references
2516
module procedure common_references_
2517
end interface
2518
public :: references
2519
private :: common_references_
2520
interface refs
2521
module procedure common_references_
2522
end interface
2523
public :: refs
2524
interface set_error
2525
module procedure common_set_error_is_
2526
module procedure common_set_error_ii_
2527
module procedure common_set_error_il_
2528
end interface
2529
public :: set_error
2530
private :: common_set_error_is_
2531
private :: common_set_error_ii_
2532
private :: common_set_error_il_
2533
interface error
2534
module procedure common_error_
2535
end interface
2536
public :: error
2537
private :: common_error_
2538
contains
2539
subroutine common_copy_(from, to)
2540
type(LL_dArray1D), intent(in) :: from
2541
type(LL_dArray1D), intent(inout) :: to
2542
call set_error(to, error(from))
2543
end subroutine common_copy_
2544
subroutine common_initialize_(this)
2545
type(LL_dArray1D), intent(inout) :: this
2546
integer :: error
2547
call delete(this)
2548
allocate(this%D, stat=error)
2549
call set_error(this, error)
2550
if ( error /= 0 ) return
2551
this%D%refs_ = 1
2552
call common_tag_object_(this)
2553
end subroutine common_initialize_
2554
pure function common_is_initialized_(this) result(init)
2555
type(LL_dArray1D), intent(in) :: this
2556
logical :: init
2557
init = associated(this%D)
2558
end function common_is_initialized_
2559
elemental function common_is_same_(lhs, rhs) result(same)
2560
type(LL_dArray1D), intent(in) :: lhs, rhs
2561
logical :: same
2562
same = is_initd(lhs) .and. is_initd(rhs)
2563
if ( .not. same ) return
2564
same = associated(lhs%D, target=rhs%D)
2565
end function common_is_same_
2566
subroutine common_delete_(this)
2567
type(LL_dArray1D), intent(inout) :: this
2568
integer :: error
2569
call set_error(this, 0)
2570
if (.not. is_initd(this) ) return
2571
this%D%refs_ = this%D%refs_ - 1
2572
if ( 0 == this%D%refs_ ) then
2573
call delete_(this)
2574
deallocate(this%D, stat=error)
2575
call set_error(this, error)
2576
end if
2577
nullify(this%D)
2578
end subroutine common_delete_
2579
elemental subroutine common_nullify_(this)
2580
type(LL_dArray1D), intent(inout) :: this
2581
if (.not. is_initd(this) ) return
2582
nullify(this%D)
2583
end subroutine common_nullify_
2584
subroutine common_assign_(lhs, rhs)
2585
type(LL_dArray1D), intent(inout) :: lhs
2586
type(LL_dArray1D), intent(in) :: rhs
2587
call delete(lhs)
2588
if ( .not. is_initd(rhs) ) return
2589
lhs%D => rhs%D
2590
lhs%D%refs_ = rhs%D%refs_ + 1
2591
end subroutine common_assign_
2592
elemental function common_references_(this) result(refs)
2593
type(LL_dArray1D), intent(in) :: this
2594
integer :: refs
2595
if ( is_initd(this) ) then
2596
refs = this%D%refs_
2597
else
2598
refs = 0
2599
end if
2600
end function common_references_
2601
elemental function common_error_(this) result(error)
2602
type(LL_dArray1D), intent(in) :: this
2603
integer :: error
2604
if ( is_initd(this) ) then
2605
error = this%error_
2606
else
2607
error = 0
2608
end if
2609
end function common_error_
2610
elemental subroutine common_set_error_is_(this, error)
2611
type(LL_dArray1D), intent(inout) :: this
2612
integer(is_), intent(in) :: error
2613
this%error_ = error
2614
end subroutine common_set_error_is_
2615
elemental subroutine common_set_error_ii_(this, error)
2616
type(LL_dArray1D), intent(inout) :: this
2617
integer(ii_), intent(in) :: error
2618
this%error_ = error
2619
end subroutine common_set_error_ii_
2620
elemental subroutine common_set_error_il_(this, error)
2621
type(LL_dArray1D), intent(inout) :: this
2622
integer(il_), intent(in) :: error
2623
this%error_ = error
2624
end subroutine common_set_error_il_
2625
elemental function common_id_(this) result(str)
2626
type(LL_dArray1D), intent(in) :: this
2627
character(len=BUD_ID_LEn) :: str
2628
str = this%D%id_
2629
end function common_id_
2630
subroutine common_tag_object_(this)
2631
type(LL_dArray1D), intent(inout) :: this
2632
end subroutine common_tag_object_
2633
subroutine delete_(this)
2634
type(LL_dArray1D), intent(inout) :: this
2635
type(LL_dArray1D_LList), pointer :: head, tmp
2636
if ( associated(this%D%head) .and. .not. &
2637
associated(this%D%ll) ) then
2638
nullify(this%D%head)
2639
nullify(this%D%ll)
2640
return
2641
end if
2642
head => this%D%ll
2643
if ( associated(head) ) then
2644
do while ( associated(head%prev) )
2645
if ( associated(head%prev, this%D%ll) ) exit
2646
head => head%prev
2647
end do
2648
if ( associated(head%prev, this%D%ll) ) then
2649
head => this%D%ll
2650
end if
2651
head => head%next
2652
tmp => head
2653
do while ( associated(head) )
2654
if ( associated(head%next, this%D%ll) ) exit
2655
head => head%next
2656
call delete(tmp%D)
2657
deallocate(tmp)
2658
tmp => head
2659
end do
2660
end if
2661
if ( associated(this%D%ll) ) then
2662
call delete(this%D%ll%D)
2663
deallocate(this%D%ll)
2664
end if
2665
nullify(this%D%ll)
2666
nullify(this%D%head)
2667
end subroutine delete_
2668
subroutine new_(this)
2669
type(LL_dArray1D), intent(inout) :: this
2670
call initialize(this)
2671
end subroutine new_
2672
subroutine new_data_(this, D)
2673
type(LL_dArray1D), intent(inout) :: this
2674
type(dArray1D), intent(in) :: D
2675
call new(this)
2676
allocate(this%D%ll)
2677
this%D%head => this%D%ll
2678
this%D%head%D = D
2679
end subroutine new_data_
2680
subroutine get_ll_headp(this, head)
2681
type(LL_dArray1D), intent(in) :: this
2682
type(LL_dArray1D_LList), pointer :: head
2683
if ( .not. is_initd(this) ) then
2684
nullify(head)
2685
return
2686
end if
2687
head => this%D%head
2688
do while ( associated(head%prev) )
2689
head => head%prev
2690
if ( associated(head, this%D%head) ) exit
2691
end do
2692
end subroutine get_ll_headp
2693
subroutine get_ll_tailp(this, tail)
2694
type(LL_dArray1D), intent(in) :: this
2695
type(LL_dArray1D_LList), pointer :: tail
2696
if ( .not. is_initd(this) ) then
2697
nullify(tail)
2698
return
2699
end if
2700
tail => this%D%head
2701
do while ( associated(tail%next) )
2702
tail => tail%next
2703
if ( associated(tail, this%D%head) ) exit
2704
end do
2705
end subroutine get_ll_tailp
2706
subroutine get_ll_idxp(this, node, index)
2707
type(LL_dArray1D), intent(in), target :: this
2708
type(LL_dArray1D_LList), pointer :: node
2709
integer, intent(in), optional :: index
2710
integer :: lindex
2711
nullify(node)
2712
if ( .not. is_initd(this) ) return
2713
lindex = 0
2714
if ( present(index) ) lindex = index
2715
node => this%D%head
2716
do while ( lindex < 0 .and. associated(node%prev) )
2717
node => node%prev
2718
lindex = lindex + 1
2719
end do
2720
do while ( lindex > 0 .and. associated(node%next) )
2721
node => node%next
2722
lindex = lindex - 1
2723
end do
2724
if ( lindex /= 0 ) then
2725
nullify(node)
2726
return
2727
end if
2728
end subroutine get_ll_idxp
2729
subroutine append_node(ll)
2730
type(LL_dArray1D_LList), pointer :: ll
2731
type(LL_dArray1D_LList), pointer :: tmp => null()
2732
if ( .not. associated(ll) ) return
2733
allocate(tmp)
2734
tmp%next => ll%next
2735
tmp%prev => ll
2736
if ( associated(ll%next) ) then
2737
ll%next%prev => tmp
2738
end if
2739
ll%next => tmp
2740
nullify(tmp)
2741
end subroutine append_node
2742
function size_llist_(this) result (nnodes)
2743
type(LL_dArray1D), intent(in), target :: this
2744
integer :: nnodes
2745
type(LL_dArray1D_LList), pointer :: head, tmp
2746
nnodes = 0
2747
if ( .not. is_initd(this) ) return
2748
call get_ll_headp(this, head)
2749
tmp => head
2750
do while ( associated(tmp) )
2751
nnodes = nnodes + 1
2752
tmp => tmp%next
2753
if ( associated(tmp, head) ) exit
2754
end do
2755
end function size_llist_
2756
subroutine add_node_(this)
2757
type(LL_dArray1D), intent(inout) :: this
2758
type(LL_dArray1D_LList), pointer :: tail
2759
if ( .not. is_initd(this) ) then
2760
call new(this)
2761
allocate(this%D%ll)
2762
this%D%head => this%D%ll
2763
return
2764
end if
2765
call get_ll_tailp(this, tail)
2766
call append_node(tail)
2767
end subroutine add_node_
2768
subroutine add_node_data_(this, D)
2769
type(LL_dArray1D), intent(inout) :: this
2770
type(dArray1D), intent(in) :: D
2771
type(LL_dArray1D_LList), pointer :: tail
2772
call get_ll_tailp(this, tail)
2773
if ( .not. associated(tail) ) then
2774
call new(this, D)
2775
return
2776
end if
2777
call append_node(tail)
2778
tail%next%D = D
2779
end subroutine add_node_data_
2780
subroutine set_data_(this, D)
2781
type(LL_dArray1D), intent(inout) :: this
2782
type(dArray1D), intent(in) :: D
2783
if ( is_initd(this) ) then
2784
this%D%head%D = D
2785
end if
2786
end subroutine set_data_
2787
subroutine set_data_idx_(this, D, index)
2788
type(LL_dArray1D), intent(inout) :: this
2789
type(dArray1D), intent(in) :: D
2790
integer, intent(in) :: index
2791
type(LL_dArray1D_LList), pointer :: node
2792
call get_ll_idxp(this, node, index)
2793
if ( .not. associated(node) ) return
2794
node%D = D
2795
end subroutine set_data_idx_
2796
subroutine set_head_idx_(this, index)
2797
type(LL_dArray1D), intent(inout) :: this
2798
integer, intent(in) :: index
2799
type(LL_dArray1D_LList), pointer :: node
2800
call get_ll_idxp(this, node, index)
2801
if ( .not. associated(node) ) return
2802
this%D%head => node
2803
end subroutine set_head_idx_
2804
subroutine get_node_data_idx_(this, D, index)
2805
type(LL_dArray1D), intent(in), target :: this
2806
type(dArray1D), intent(inout) :: D
2807
integer, intent(in), optional :: index
2808
type(LL_dArray1D_LList), pointer :: node
2809
call delete(D)
2810
if ( .not. is_initd(this) ) return
2811
call get_ll_idxp(this, node, index)
2812
if ( associated(node) ) D = node%D
2813
end subroutine get_node_data_idx_
2814
function itt_step_(this, itt) result(itterated)
2815
type(LL_dArray1D), intent(in) :: this
2816
type(LL_dArray1D), intent(inout) :: itt
2817
logical :: itterated
2818
itterated = .false.
2819
if ( .not. is_initd(this) ) then
2820
call delete(itt)
2821
return
2822
end if
2823
if ( .not. is_initd(itt) ) then
2824
call new(itt)
2825
itt%D%head => this%D%head
2826
itterated = associated(itt%D%head)
2827
else
2828
itt%D%head => itt%D%head%next
2829
itterated = associated(itt%D%head)
2830
if ( itterated ) then
2831
itterated = .not. associated(itt%D%head, this%D%head)
2832
end if
2833
end if
2834
if ( .not. itterated ) then
2835
call delete(itt)
2836
end if
2837
end function itt_step_
2838
function itt_step_i_(this, itt, i) result(itterated)
2839
type(LL_dArray1D), intent(in) :: this
2840
type(LL_dArray1D), intent(inout) :: itt
2841
integer, intent(in) :: i
2842
logical :: itterated
2843
integer :: is
2844
itterated = .false.
2845
if ( .not. is_initd(this) ) then
2846
call delete(itt)
2847
return
2848
end if
2849
is = 0
2850
if ( .not. is_initd(itt) ) then
2851
call new(itt)
2852
itt%D%head => this%D%head
2853
itterated = associated(itt%D%head)
2854
else if ( i > 0 ) then
2855
do while ( is /= i )
2856
is = is + 1
2857
itt%D%head => itt%D%head%next
2858
itterated = associated(itt%D%head)
2859
if ( itterated ) then
2860
itterated = .not. associated(itt%D%head, this%D%head)
2861
end if
2862
if ( .not. itterated ) exit
2863
end do
2864
else if ( i < 0 ) then
2865
do while ( is /= i )
2866
is = is - 1
2867
itt%D%head => itt%D%head%prev
2868
itterated = associated(itt%D%head)
2869
if ( itterated ) then
2870
itterated = .not. associated(itt%D%head, this%D%head)
2871
end if
2872
if ( .not. itterated ) exit
2873
end do
2874
end if
2875
if ( .not. itterated ) then
2876
nullify(itt%D%head)
2877
call delete(itt)
2878
end if
2879
end function itt_step_i_
2880
subroutine remove_node_(this, index)
2881
type(LL_dArray1D), intent(inout), target :: this
2882
integer, intent(in) :: index
2883
type(LL_dArray1D_LList), pointer :: node, pnode, nnode
2884
if ( .not. is_initd(this) ) return
2885
call get_ll_idxp(this, node, index)
2886
if ( .not. associated(node) ) return
2887
pnode => node%prev
2888
nnode => node%next
2889
nullify(node%prev)
2890
nullify(node%next)
2891
if ( associated(pnode) ) then
2892
pnode%next => nnode
2893
end if
2894
if ( associated(nnode) ) then
2895
nnode%prev => pnode
2896
end if
2897
call delete(node%D)
2898
deallocate(node)
2899
end subroutine remove_node_
2900
subroutine remove_node_data_(this, index)
2901
type(LL_dArray1D), intent(inout), target :: this
2902
integer, intent(in), optional :: index
2903
type(LL_dArray1D_LList), pointer :: node
2904
if ( .not. is_initd(this) ) return
2905
call get_ll_idxp(this, node, index)
2906
if ( .not. associated(node) ) return
2907
call delete(node%D)
2908
end subroutine remove_node_data_
2909
subroutine copy_(from, to)
2910
type(LL_dArray1D), intent(inout) :: from, to
2911
type(LL_dArray1D_LList), pointer :: t, f
2912
call delete(to)
2913
if ( .not. is_initd(from) ) return
2914
call new(to)
2915
f => from%D%head
2916
t => to%D%head
2917
t%D = f%D
2918
do while ( associated(f%next) )
2919
f => f%next
2920
allocate(t%next)
2921
t%next%prev => t
2922
t => t%next
2923
t%D = f%D
2924
if ( associated(t, to%D%head) ) return
2925
end do
2926
f => from%D%head
2927
t => to%D%head
2928
do while ( associated(f%prev) )
2929
f => f%prev
2930
allocate(t%prev)
2931
t%prev%next => t
2932
t => t%prev
2933
t%D = f%D
2934
end do
2935
end subroutine copy_
2936
subroutine print_(this, info, indent)
2937
type(LL_dArray1D), intent(in), target :: this
2938
character(len=*), intent(in), optional :: info
2939
integer, intent(in), optional :: indent
2940
integer :: lindent
2941
type(LL_dArray1D_LList), pointer :: node
2942
character(len=32) :: fmt
2943
character(len=256) :: name
2944
name = "LL_dArray1D"
2945
if ( present(info) ) name = info
2946
lindent = 1
2947
if ( present(indent) ) lindent = indent
2948
write(fmt, '(a,i0,a)') '(t',lindent,',3a)'
2949
if ( .not. is_initd(this) ) then
2950
write(*,fmt) "<", trim(name), " not initialized>"
2951
return
2952
end if
2953
write(fmt, '(a,i0,a)') '(t',lindent,',3a,i0,a)'
2954
write(*,fmt) "<<", trim(name), " llist, nodes=",nodes(this),">"
2955
lindent = lindent + 2 ! step indentation
2956
call get_ll_headp(this, node)
2957
do while ( associated(node) )
2958
if ( associated(node, this%D%head) ) then
2959
write(fmt, '(a,i0,a)') '(t',lindent,',a)'
2960
call print(node%D, indent = lindent+2)
2961
else
2962
call print(node%D, indent = lindent)
2963
end if
2964
node => node%next
2965
end do
2966
lindent = lindent - 2 ! go back to requested indentation
2967
write(fmt, '(a,i0,a)') '(t',lindent,',a,i0,a)'
2968
write(*,fmt) " <llist-refs: ", references(this), ">>"
2969
end subroutine print_
2970
end module
2971
module bud_LL_cArray1D
2972
use bud_cArray1D
2973
implicit none
2974
private
2975
integer, parameter :: rr_ = selected_real_kind(p=6) ! single (real*4)
2976
integer, parameter :: rd_ = selected_real_kind(p=15) ! double (real*8)
2977
integer, parameter :: is_ = selected_int_kind(4) ! short (integer*2)
2978
integer, parameter :: ii_ = selected_int_kind(9) ! int (integer*4)
2979
integer, parameter :: il_ = selected_int_kind(18) ! long (integer*8)
2980
integer, parameter, private :: BUD_ID_LEn = 36
2981
character(len=*), parameter, private :: &
2982
BUD_MOd = 'BUD_CC2(BUD_MOD,_)BUD_MOD_NAME'
2983
character(len=*), parameter, private :: &
2984
BUD_TYPe = "LL_cArray1D"
2985
type LL_cArray1D
2986
type(LL_cArray1D_), pointer :: D => null()
2987
integer :: error_ = 0
2988
end type LL_cArray1D
2989
type LL_cArray1D_
2990
type(LL_cArray1D_LList), pointer :: ll => null()
2991
type(LL_cArray1D_LList), pointer :: head => null()
2992
integer :: refs_ = 0
2993
character(len=BUD_ID_LEN) :: id_ = "null_id"
2994
end type LL_cArray1D_
2995
type LL_cArray1D_LList
2996
type(LL_cArray1D_LList), pointer :: prev => null()
2997
type(LL_cArray1D_LList), pointer :: next => null()
2998
type(cArray1D) :: D
2999
end type
3000
private :: LL_cArray1D_LList
3001
interface new
3002
module procedure new_
3003
module procedure new_data_
3004
end interface
3005
public :: new
3006
interface assignment(=)
3007
module procedure set_data_
3008
end interface
3009
interface nodes
3010
module procedure size_llist_
3011
end interface
3012
public :: nodes
3013
interface size
3014
module procedure size_llist_
3015
end interface
3016
public :: size
3017
interface set_data
3018
module procedure set_data_
3019
module procedure set_data_idx_
3020
end interface
3021
public :: set_data
3022
interface add_node
3023
module procedure add_node_
3024
module procedure add_node_data_
3025
end interface
3026
public :: add_node
3027
interface get_data
3028
module procedure get_node_data_idx_
3029
end interface
3030
public :: get_data
3031
interface get_node
3032
module procedure get_node_data_idx_
3033
end interface
3034
public :: get_node
3035
interface set_head
3036
module procedure set_head_idx_
3037
end interface
3038
public :: set_head
3039
interface itt_step
3040
module procedure itt_step_
3041
module procedure itt_step_i_
3042
end interface
3043
public :: itt_step
3044
interface remove_node
3045
module procedure remove_node_
3046
end interface
3047
public :: remove_node
3048
interface remove_node_data
3049
module procedure remove_node_data_
3050
end interface
3051
public :: remove_node_data
3052
interface copy_list
3053
module procedure copy_
3054
end interface
3055
public :: copy_list
3056
public :: LL_cArray1D
3057
private :: LL_cArray1D_
3058
interface assignment(=)
3059
module procedure common_assign_
3060
end interface
3061
public :: assignment(=)
3062
private :: common_assign_
3063
interface initialize
3064
module procedure common_initialize_
3065
end interface
3066
public :: initialize
3067
private :: common_initialize_
3068
interface is_initialized
3069
module procedure common_is_initialized_
3070
end interface
3071
public :: is_initialized
3072
private :: common_is_initialized_
3073
interface initialized
3074
module procedure common_is_initialized_
3075
end interface
3076
public :: initialized
3077
interface is_initd
3078
module procedure common_is_initialized_
3079
end interface
3080
public :: is_initd
3081
interface is_same
3082
module procedure common_is_same_
3083
end interface
3084
public :: is_same
3085
private :: common_is_same_
3086
interface same
3087
module procedure common_is_same_
3088
end interface
3089
public :: same
3090
interface delete
3091
module procedure common_delete_
3092
end interface
3093
public :: delete
3094
private :: common_delete_
3095
interface nullify
3096
module procedure common_nullify_
3097
end interface
3098
public :: nullify
3099
private :: common_nullify_
3100
interface copy
3101
module procedure copy_
3102
end interface
3103
public :: copy
3104
private :: common_copy_
3105
interface print
3106
module procedure print_
3107
end interface
3108
public :: print
3109
interface references
3110
module procedure common_references_
3111
end interface
3112
public :: references
3113
private :: common_references_
3114
interface refs
3115
module procedure common_references_
3116
end interface
3117
public :: refs
3118
interface set_error
3119
module procedure common_set_error_is_
3120
module procedure common_set_error_ii_
3121
module procedure common_set_error_il_
3122
end interface
3123
public :: set_error
3124
private :: common_set_error_is_
3125
private :: common_set_error_ii_
3126
private :: common_set_error_il_
3127
interface error
3128
module procedure common_error_
3129
end interface
3130
public :: error
3131
private :: common_error_
3132
contains
3133
subroutine common_copy_(from, to)
3134
type(LL_cArray1D), intent(in) :: from
3135
type(LL_cArray1D), intent(inout) :: to
3136
call set_error(to, error(from))
3137
end subroutine common_copy_
3138
subroutine common_initialize_(this)
3139
type(LL_cArray1D), intent(inout) :: this
3140
integer :: error
3141
call delete(this)
3142
allocate(this%D, stat=error)
3143
call set_error(this, error)
3144
if ( error /= 0 ) return
3145
this%D%refs_ = 1
3146
call common_tag_object_(this)
3147
end subroutine common_initialize_
3148
pure function common_is_initialized_(this) result(init)
3149
type(LL_cArray1D), intent(in) :: this
3150
logical :: init
3151
init = associated(this%D)
3152
end function common_is_initialized_
3153
elemental function common_is_same_(lhs, rhs) result(same)
3154
type(LL_cArray1D), intent(in) :: lhs, rhs
3155
logical :: same
3156
same = is_initd(lhs) .and. is_initd(rhs)
3157
if ( .not. same ) return
3158
same = associated(lhs%D, target=rhs%D)
3159
end function common_is_same_
3160
subroutine common_delete_(this)
3161
type(LL_cArray1D), intent(inout) :: this
3162
integer :: error
3163
call set_error(this, 0)
3164
if (.not. is_initd(this) ) return
3165
this%D%refs_ = this%D%refs_ - 1
3166
if ( 0 == this%D%refs_ ) then
3167
call delete_(this)
3168
deallocate(this%D, stat=error)
3169
call set_error(this, error)
3170
end if
3171
nullify(this%D)
3172
end subroutine common_delete_
3173
elemental subroutine common_nullify_(this)
3174
type(LL_cArray1D), intent(inout) :: this
3175
if (.not. is_initd(this) ) return
3176
nullify(this%D)
3177
end subroutine common_nullify_
3178
subroutine common_assign_(lhs, rhs)
3179
type(LL_cArray1D), intent(inout) :: lhs
3180
type(LL_cArray1D), intent(in) :: rhs
3181
call delete(lhs)
3182
if ( .not. is_initd(rhs) ) return
3183
lhs%D => rhs%D
3184
lhs%D%refs_ = rhs%D%refs_ + 1
3185
end subroutine common_assign_
3186
elemental function common_references_(this) result(refs)
3187
type(LL_cArray1D), intent(in) :: this
3188
integer :: refs
3189
if ( is_initd(this) ) then
3190
refs = this%D%refs_
3191
else
3192
refs = 0
3193
end if
3194
end function common_references_
3195
elemental function common_error_(this) result(error)
3196
type(LL_cArray1D), intent(in) :: this
3197
integer :: error
3198
if ( is_initd(this) ) then
3199
error = this%error_
3200
else
3201
error = 0
3202
end if
3203
end function common_error_
3204
elemental subroutine common_set_error_is_(this, error)
3205
type(LL_cArray1D), intent(inout) :: this
3206
integer(is_), intent(in) :: error
3207
this%error_ = error
3208
end subroutine common_set_error_is_
3209
elemental subroutine common_set_error_ii_(this, error)
3210
type(LL_cArray1D), intent(inout) :: this
3211
integer(ii_), intent(in) :: error
3212
this%error_ = error
3213
end subroutine common_set_error_ii_
3214
elemental subroutine common_set_error_il_(this, error)
3215
type(LL_cArray1D), intent(inout) :: this
3216
integer(il_), intent(in) :: error
3217
this%error_ = error
3218
end subroutine common_set_error_il_
3219
elemental function common_id_(this) result(str)
3220
type(LL_cArray1D), intent(in) :: this
3221
character(len=BUD_ID_LEn) :: str
3222
str = this%D%id_
3223
end function common_id_
3224
subroutine common_tag_object_(this)
3225
type(LL_cArray1D), intent(inout) :: this
3226
end subroutine common_tag_object_
3227
subroutine delete_(this)
3228
type(LL_cArray1D), intent(inout) :: this
3229
type(LL_cArray1D_LList), pointer :: head, tmp
3230
if ( associated(this%D%head) .and. .not. &
3231
associated(this%D%ll) ) then
3232
nullify(this%D%head)
3233
nullify(this%D%ll)
3234
return
3235
end if
3236
head => this%D%ll
3237
if ( associated(head) ) then
3238
do while ( associated(head%prev) )
3239
if ( associated(head%prev, this%D%ll) ) exit
3240
head => head%prev
3241
end do
3242
if ( associated(head%prev, this%D%ll) ) then
3243
head => this%D%ll
3244
end if
3245
head => head%next
3246
tmp => head
3247
do while ( associated(head) )
3248
if ( associated(head%next, this%D%ll) ) exit
3249
head => head%next
3250
call delete(tmp%D)
3251
deallocate(tmp)
3252
tmp => head
3253
end do
3254
end if
3255
if ( associated(this%D%ll) ) then
3256
call delete(this%D%ll%D)
3257
deallocate(this%D%ll)
3258
end if
3259
nullify(this%D%ll)
3260
nullify(this%D%head)
3261
end subroutine delete_
3262
subroutine new_(this)
3263
type(LL_cArray1D), intent(inout) :: this
3264
call initialize(this)
3265
end subroutine new_
3266
subroutine new_data_(this, D)
3267
type(LL_cArray1D), intent(inout) :: this
3268
type(cArray1D), intent(in) :: D
3269
call new(this)
3270
allocate(this%D%ll)
3271
this%D%head => this%D%ll
3272
this%D%head%D = D
3273
end subroutine new_data_
3274
subroutine get_ll_headp(this, head)
3275
type(LL_cArray1D), intent(in) :: this
3276
type(LL_cArray1D_LList), pointer :: head
3277
if ( .not. is_initd(this) ) then
3278
nullify(head)
3279
return
3280
end if
3281
head => this%D%head
3282
do while ( associated(head%prev) )
3283
head => head%prev
3284
if ( associated(head, this%D%head) ) exit
3285
end do
3286
end subroutine get_ll_headp
3287
subroutine get_ll_tailp(this, tail)
3288
type(LL_cArray1D), intent(in) :: this
3289
type(LL_cArray1D_LList), pointer :: tail
3290
if ( .not. is_initd(this) ) then
3291
nullify(tail)
3292
return
3293
end if
3294
tail => this%D%head
3295
do while ( associated(tail%next) )
3296
tail => tail%next
3297
if ( associated(tail, this%D%head) ) exit
3298
end do
3299
end subroutine get_ll_tailp
3300
subroutine get_ll_idxp(this, node, index)
3301
type(LL_cArray1D), intent(in), target :: this
3302
type(LL_cArray1D_LList), pointer :: node
3303
integer, intent(in), optional :: index
3304
integer :: lindex
3305
nullify(node)
3306
if ( .not. is_initd(this) ) return
3307
lindex = 0
3308
if ( present(index) ) lindex = index
3309
node => this%D%head
3310
do while ( lindex < 0 .and. associated(node%prev) )
3311
node => node%prev
3312
lindex = lindex + 1
3313
end do
3314
do while ( lindex > 0 .and. associated(node%next) )
3315
node => node%next
3316
lindex = lindex - 1
3317
end do
3318
if ( lindex /= 0 ) then
3319
nullify(node)
3320
return
3321
end if
3322
end subroutine get_ll_idxp
3323
subroutine append_node(ll)
3324
type(LL_cArray1D_LList), pointer :: ll
3325
type(LL_cArray1D_LList), pointer :: tmp => null()
3326
if ( .not. associated(ll) ) return
3327
allocate(tmp)
3328
tmp%next => ll%next
3329
tmp%prev => ll
3330
if ( associated(ll%next) ) then
3331
ll%next%prev => tmp
3332
end if
3333
ll%next => tmp
3334
nullify(tmp)
3335
end subroutine append_node
3336
function size_llist_(this) result (nnodes)
3337
type(LL_cArray1D), intent(in), target :: this
3338
integer :: nnodes
3339
type(LL_cArray1D_LList), pointer :: head, tmp
3340
nnodes = 0
3341
if ( .not. is_initd(this) ) return
3342
call get_ll_headp(this, head)
3343
tmp => head
3344
do while ( associated(tmp) )
3345
nnodes = nnodes + 1
3346
tmp => tmp%next
3347
if ( associated(tmp, head) ) exit
3348
end do
3349
end function size_llist_
3350
subroutine add_node_(this)
3351
type(LL_cArray1D), intent(inout) :: this
3352
type(LL_cArray1D_LList), pointer :: tail
3353
if ( .not. is_initd(this) ) then
3354
call new(this)
3355
allocate(this%D%ll)
3356
this%D%head => this%D%ll
3357
return
3358
end if
3359
call get_ll_tailp(this, tail)
3360
call append_node(tail)
3361
end subroutine add_node_
3362
subroutine add_node_data_(this, D)
3363
type(LL_cArray1D), intent(inout) :: this
3364
type(cArray1D), intent(in) :: D
3365
type(LL_cArray1D_LList), pointer :: tail
3366
call get_ll_tailp(this, tail)
3367
if ( .not. associated(tail) ) then
3368
call new(this, D)
3369
return
3370
end if
3371
call append_node(tail)
3372
tail%next%D = D
3373
end subroutine add_node_data_
3374
subroutine set_data_(this, D)
3375
type(LL_cArray1D), intent(inout) :: this
3376
type(cArray1D), intent(in) :: D
3377
if ( is_initd(this) ) then
3378
this%D%head%D = D
3379
end if
3380
end subroutine set_data_
3381
subroutine set_data_idx_(this, D, index)
3382
type(LL_cArray1D), intent(inout) :: this
3383
type(cArray1D), intent(in) :: D
3384
integer, intent(in) :: index
3385
type(LL_cArray1D_LList), pointer :: node
3386
call get_ll_idxp(this, node, index)
3387
if ( .not. associated(node) ) return
3388
node%D = D
3389
end subroutine set_data_idx_
3390
subroutine set_head_idx_(this, index)
3391
type(LL_cArray1D), intent(inout) :: this
3392
integer, intent(in) :: index
3393
type(LL_cArray1D_LList), pointer :: node
3394
call get_ll_idxp(this, node, index)
3395
if ( .not. associated(node) ) return
3396
this%D%head => node
3397
end subroutine set_head_idx_
3398
subroutine get_node_data_idx_(this, D, index)
3399
type(LL_cArray1D), intent(in), target :: this
3400
type(cArray1D), intent(inout) :: D
3401
integer, intent(in), optional :: index
3402
type(LL_cArray1D_LList), pointer :: node
3403
call delete(D)
3404
if ( .not. is_initd(this) ) return
3405
call get_ll_idxp(this, node, index)
3406
if ( associated(node) ) D = node%D
3407
end subroutine get_node_data_idx_
3408
function itt_step_(this, itt) result(itterated)
3409
type(LL_cArray1D), intent(in) :: this
3410
type(LL_cArray1D), intent(inout) :: itt
3411
logical :: itterated
3412
itterated = .false.
3413
if ( .not. is_initd(this) ) then
3414
call delete(itt)
3415
return
3416
end if
3417
if ( .not. is_initd(itt) ) then
3418
call new(itt)
3419
itt%D%head => this%D%head
3420
itterated = associated(itt%D%head)
3421
else
3422
itt%D%head => itt%D%head%next
3423
itterated = associated(itt%D%head)
3424
if ( itterated ) then
3425
itterated = .not. associated(itt%D%head, this%D%head)
3426
end if
3427
end if
3428
if ( .not. itterated ) then
3429
call delete(itt)
3430
end if
3431
end function itt_step_
3432
function itt_step_i_(this, itt, i) result(itterated)
3433
type(LL_cArray1D), intent(in) :: this
3434
type(LL_cArray1D), intent(inout) :: itt
3435
integer, intent(in) :: i
3436
logical :: itterated
3437
integer :: is
3438
itterated = .false.
3439
if ( .not. is_initd(this) ) then
3440
call delete(itt)
3441
return
3442
end if
3443
is = 0
3444
if ( .not. is_initd(itt) ) then
3445
call new(itt)
3446
itt%D%head => this%D%head
3447
itterated = associated(itt%D%head)
3448
else if ( i > 0 ) then
3449
do while ( is /= i )
3450
is = is + 1
3451
itt%D%head => itt%D%head%next
3452
itterated = associated(itt%D%head)
3453
if ( itterated ) then
3454
itterated = .not. associated(itt%D%head, this%D%head)
3455
end if
3456
if ( .not. itterated ) exit
3457
end do
3458
else if ( i < 0 ) then
3459
do while ( is /= i )
3460
is = is - 1
3461
itt%D%head => itt%D%head%prev
3462
itterated = associated(itt%D%head)
3463
if ( itterated ) then
3464
itterated = .not. associated(itt%D%head, this%D%head)
3465
end if
3466
if ( .not. itterated ) exit
3467
end do
3468
end if
3469
if ( .not. itterated ) then
3470
nullify(itt%D%head)
3471
call delete(itt)
3472
end if
3473
end function itt_step_i_
3474
subroutine remove_node_(this, index)
3475
type(LL_cArray1D), intent(inout), target :: this
3476
integer, intent(in) :: index
3477
type(LL_cArray1D_LList), pointer :: node, pnode, nnode
3478
if ( .not. is_initd(this) ) return
3479
call get_ll_idxp(this, node, index)
3480
if ( .not. associated(node) ) return
3481
pnode => node%prev
3482
nnode => node%next
3483
nullify(node%prev)
3484
nullify(node%next)
3485
if ( associated(pnode) ) then
3486
pnode%next => nnode
3487
end if
3488
if ( associated(nnode) ) then
3489
nnode%prev => pnode
3490
end if
3491
call delete(node%D)
3492
deallocate(node)
3493
end subroutine remove_node_
3494
subroutine remove_node_data_(this, index)
3495
type(LL_cArray1D), intent(inout), target :: this
3496
integer, intent(in), optional :: index
3497
type(LL_cArray1D_LList), pointer :: node
3498
if ( .not. is_initd(this) ) return
3499
call get_ll_idxp(this, node, index)
3500
if ( .not. associated(node) ) return
3501
call delete(node%D)
3502
end subroutine remove_node_data_
3503
subroutine copy_(from, to)
3504
type(LL_cArray1D), intent(inout) :: from, to
3505
type(LL_cArray1D_LList), pointer :: t, f
3506
call delete(to)
3507
if ( .not. is_initd(from) ) return
3508
call new(to)
3509
f => from%D%head
3510
t => to%D%head
3511
t%D = f%D
3512
do while ( associated(f%next) )
3513
f => f%next
3514
allocate(t%next)
3515
t%next%prev => t
3516
t => t%next
3517
t%D = f%D
3518
if ( associated(t, to%D%head) ) return
3519
end do
3520
f => from%D%head
3521
t => to%D%head
3522
do while ( associated(f%prev) )
3523
f => f%prev
3524
allocate(t%prev)
3525
t%prev%next => t
3526
t => t%prev
3527
t%D = f%D
3528
end do
3529
end subroutine copy_
3530
subroutine print_(this, info, indent)
3531
type(LL_cArray1D), intent(in), target :: this
3532
character(len=*), intent(in), optional :: info
3533
integer, intent(in), optional :: indent
3534
integer :: lindent
3535
type(LL_cArray1D_LList), pointer :: node
3536
character(len=32) :: fmt
3537
character(len=256) :: name
3538
name = "LL_cArray1D"
3539
if ( present(info) ) name = info
3540
lindent = 1
3541
if ( present(indent) ) lindent = indent
3542
write(fmt, '(a,i0,a)') '(t',lindent,',3a)'
3543
if ( .not. is_initd(this) ) then
3544
write(*,fmt) "<", trim(name), " not initialized>"
3545
return
3546
end if
3547
write(fmt, '(a,i0,a)') '(t',lindent,',3a,i0,a)'
3548
write(*,fmt) "<<", trim(name), " llist, nodes=",nodes(this),">"
3549
lindent = lindent + 2 ! step indentation
3550
call get_ll_headp(this, node)
3551
do while ( associated(node) )
3552
if ( associated(node, this%D%head) ) then
3553
write(fmt, '(a,i0,a)') '(t',lindent,',a)'
3554
call print(node%D, indent = lindent+2)
3555
else
3556
call print(node%D, indent = lindent)
3557
end if
3558
node => node%next
3559
end do
3560
lindent = lindent - 2 ! go back to requested indentation
3561
write(fmt, '(a,i0,a)') '(t',lindent,',a,i0,a)'
3562
write(*,fmt) " <llist-refs: ", references(this), ">>"
3563
end subroutine print_
3564
end module
3565
module bud_LL_zArray1D
3566
use bud_zArray1D
3567
implicit none
3568
private
3569
integer, parameter :: rr_ = selected_real_kind(p=6) ! single (real*4)
3570
integer, parameter :: rd_ = selected_real_kind(p=15) ! double (real*8)
3571
integer, parameter :: is_ = selected_int_kind(4) ! short (integer*2)
3572
integer, parameter :: ii_ = selected_int_kind(9) ! int (integer*4)
3573
integer, parameter :: il_ = selected_int_kind(18) ! long (integer*8)
3574
integer, parameter, private :: BUD_ID_LEn = 36
3575
character(len=*), parameter, private :: &
3576
BUD_MOd = 'BUD_CC2(BUD_MOD,_)BUD_MOD_NAME'
3577
character(len=*), parameter, private :: &
3578
BUD_TYPe = "LL_zArray1D"
3579
type LL_zArray1D
3580
type(LL_zArray1D_), pointer :: D => null()
3581
integer :: error_ = 0
3582
end type LL_zArray1D
3583
type LL_zArray1D_
3584
type(LL_zArray1D_LList), pointer :: ll => null()
3585
type(LL_zArray1D_LList), pointer :: head => null()
3586
integer :: refs_ = 0
3587
character(len=BUD_ID_LEN) :: id_ = "null_id"
3588
end type LL_zArray1D_
3589
type LL_zArray1D_LList
3590
type(LL_zArray1D_LList), pointer :: prev => null()
3591
type(LL_zArray1D_LList), pointer :: next => null()
3592
type(zArray1D) :: D
3593
end type
3594
private :: LL_zArray1D_LList
3595
interface new
3596
module procedure new_
3597
module procedure new_data_
3598
end interface
3599
public :: new
3600
interface assignment(=)
3601
module procedure set_data_
3602
end interface
3603
interface nodes
3604
module procedure size_llist_
3605
end interface
3606
public :: nodes
3607
interface size
3608
module procedure size_llist_
3609
end interface
3610
public :: size
3611
interface set_data
3612
module procedure set_data_
3613
module procedure set_data_idx_
3614
end interface
3615
public :: set_data
3616
interface add_node
3617
module procedure add_node_
3618
module procedure add_node_data_
3619
end interface
3620
public :: add_node
3621
interface get_data
3622
module procedure get_node_data_idx_
3623
end interface
3624
public :: get_data
3625
interface get_node
3626
module procedure get_node_data_idx_
3627
end interface
3628
public :: get_node
3629
interface set_head
3630
module procedure set_head_idx_
3631
end interface
3632
public :: set_head
3633
interface itt_step
3634
module procedure itt_step_
3635
module procedure itt_step_i_
3636
end interface
3637
public :: itt_step
3638
interface remove_node
3639
module procedure remove_node_
3640
end interface
3641
public :: remove_node
3642
interface remove_node_data
3643
module procedure remove_node_data_
3644
end interface
3645
public :: remove_node_data
3646
interface copy_list
3647
module procedure copy_
3648
end interface
3649
public :: copy_list
3650
public :: LL_zArray1D
3651
private :: LL_zArray1D_
3652
interface assignment(=)
3653
module procedure common_assign_
3654
end interface
3655
public :: assignment(=)
3656
private :: common_assign_
3657
interface initialize
3658
module procedure common_initialize_
3659
end interface
3660
public :: initialize
3661
private :: common_initialize_
3662
interface is_initialized
3663
module procedure common_is_initialized_
3664
end interface
3665
public :: is_initialized
3666
private :: common_is_initialized_
3667
interface initialized
3668
module procedure common_is_initialized_
3669
end interface
3670
public :: initialized
3671
interface is_initd
3672
module procedure common_is_initialized_
3673
end interface
3674
public :: is_initd
3675
interface is_same
3676
module procedure common_is_same_
3677
end interface
3678
public :: is_same
3679
private :: common_is_same_
3680
interface same
3681
module procedure common_is_same_
3682
end interface
3683
public :: same
3684
interface delete
3685
module procedure common_delete_
3686
end interface
3687
public :: delete
3688
private :: common_delete_
3689
interface nullify
3690
module procedure common_nullify_
3691
end interface
3692
public :: nullify
3693
private :: common_nullify_
3694
interface copy
3695
module procedure copy_
3696
end interface
3697
public :: copy
3698
private :: common_copy_
3699
interface print
3700
module procedure print_
3701
end interface
3702
public :: print
3703
interface references
3704
module procedure common_references_
3705
end interface
3706
public :: references
3707
private :: common_references_
3708
interface refs
3709
module procedure common_references_
3710
end interface
3711
public :: refs
3712
interface set_error
3713
module procedure common_set_error_is_
3714
module procedure common_set_error_ii_
3715
module procedure common_set_error_il_
3716
end interface
3717
public :: set_error
3718
private :: common_set_error_is_
3719
private :: common_set_error_ii_
3720
private :: common_set_error_il_
3721
interface error
3722
module procedure common_error_
3723
end interface
3724
public :: error
3725
private :: common_error_
3726
contains
3727
subroutine common_copy_(from, to)
3728
type(LL_zArray1D), intent(in) :: from
3729
type(LL_zArray1D), intent(inout) :: to
3730
call set_error(to, error(from))
3731
end subroutine common_copy_
3732
subroutine common_initialize_(this)
3733
type(LL_zArray1D), intent(inout) :: this
3734
integer :: error
3735
call delete(this)
3736
allocate(this%D, stat=error)
3737
call set_error(this, error)
3738
if ( error /= 0 ) return
3739
this%D%refs_ = 1
3740
call common_tag_object_(this)
3741
end subroutine common_initialize_
3742
pure function common_is_initialized_(this) result(init)
3743
type(LL_zArray1D), intent(in) :: this
3744
logical :: init
3745
init = associated(this%D)
3746
end function common_is_initialized_
3747
elemental function common_is_same_(lhs, rhs) result(same)
3748
type(LL_zArray1D), intent(in) :: lhs, rhs
3749
logical :: same
3750
same = is_initd(lhs) .and. is_initd(rhs)
3751
if ( .not. same ) return
3752
same = associated(lhs%D, target=rhs%D)
3753
end function common_is_same_
3754
subroutine common_delete_(this)
3755
type(LL_zArray1D), intent(inout) :: this
3756
integer :: error
3757
call set_error(this, 0)
3758
if (.not. is_initd(this) ) return
3759
this%D%refs_ = this%D%refs_ - 1
3760
if ( 0 == this%D%refs_ ) then
3761
call delete_(this)
3762
deallocate(this%D, stat=error)
3763
call set_error(this, error)
3764
end if
3765
nullify(this%D)
3766
end subroutine common_delete_
3767
elemental subroutine common_nullify_(this)
3768
type(LL_zArray1D), intent(inout) :: this
3769
if (.not. is_initd(this) ) return
3770
nullify(this%D)
3771
end subroutine common_nullify_
3772
subroutine common_assign_(lhs, rhs)
3773
type(LL_zArray1D), intent(inout) :: lhs
3774
type(LL_zArray1D), intent(in) :: rhs
3775
call delete(lhs)
3776
if ( .not. is_initd(rhs) ) return
3777
lhs%D => rhs%D
3778
lhs%D%refs_ = rhs%D%refs_ + 1
3779
end subroutine common_assign_
3780
elemental function common_references_(this) result(refs)
3781
type(LL_zArray1D), intent(in) :: this
3782
integer :: refs
3783
if ( is_initd(this) ) then
3784
refs = this%D%refs_
3785
else
3786
refs = 0
3787
end if
3788
end function common_references_
3789
elemental function common_error_(this) result(error)
3790
type(LL_zArray1D), intent(in) :: this
3791
integer :: error
3792
if ( is_initd(this) ) then
3793
error = this%error_
3794
else
3795
error = 0
3796
end if
3797
end function common_error_
3798
elemental subroutine common_set_error_is_(this, error)
3799
type(LL_zArray1D), intent(inout) :: this
3800
integer(is_), intent(in) :: error
3801
this%error_ = error
3802
end subroutine common_set_error_is_
3803
elemental subroutine common_set_error_ii_(this, error)
3804
type(LL_zArray1D), intent(inout) :: this
3805
integer(ii_), intent(in) :: error
3806
this%error_ = error
3807
end subroutine common_set_error_ii_
3808
elemental subroutine common_set_error_il_(this, error)
3809
type(LL_zArray1D), intent(inout) :: this
3810
integer(il_), intent(in) :: error
3811
this%error_ = error
3812
end subroutine common_set_error_il_
3813
elemental function common_id_(this) result(str)
3814
type(LL_zArray1D), intent(in) :: this
3815
character(len=BUD_ID_LEn) :: str
3816
str = this%D%id_
3817
end function common_id_
3818
subroutine common_tag_object_(this)
3819
type(LL_zArray1D), intent(inout) :: this
3820
end subroutine common_tag_object_
3821
subroutine delete_(this)
3822
type(LL_zArray1D), intent(inout) :: this
3823
type(LL_zArray1D_LList), pointer :: head, tmp
3824
if ( associated(this%D%head) .and. .not. &
3825
associated(this%D%ll) ) then
3826
nullify(this%D%head)
3827
nullify(this%D%ll)
3828
return
3829
end if
3830
head => this%D%ll
3831
if ( associated(head) ) then
3832
do while ( associated(head%prev) )
3833
if ( associated(head%prev, this%D%ll) ) exit
3834
head => head%prev
3835
end do
3836
if ( associated(head%prev, this%D%ll) ) then
3837
head => this%D%ll
3838
end if
3839
head => head%next
3840
tmp => head
3841
do while ( associated(head) )
3842
if ( associated(head%next, this%D%ll) ) exit
3843
head => head%next
3844
call delete(tmp%D)
3845
deallocate(tmp)
3846
tmp => head
3847
end do
3848
end if
3849
if ( associated(this%D%ll) ) then
3850
call delete(this%D%ll%D)
3851
deallocate(this%D%ll)
3852
end if
3853
nullify(this%D%ll)
3854
nullify(this%D%head)
3855
end subroutine delete_
3856
subroutine new_(this)
3857
type(LL_zArray1D), intent(inout) :: this
3858
call initialize(this)
3859
end subroutine new_
3860
subroutine new_data_(this, D)
3861
type(LL_zArray1D), intent(inout) :: this
3862
type(zArray1D), intent(in) :: D
3863
call new(this)
3864
allocate(this%D%ll)
3865
this%D%head => this%D%ll
3866
this%D%head%D = D
3867
end subroutine new_data_
3868
subroutine get_ll_headp(this, head)
3869
type(LL_zArray1D), intent(in) :: this
3870
type(LL_zArray1D_LList), pointer :: head
3871
if ( .not. is_initd(this) ) then
3872
nullify(head)
3873
return
3874
end if
3875
head => this%D%head
3876
do while ( associated(head%prev) )
3877
head => head%prev
3878
if ( associated(head, this%D%head) ) exit
3879
end do
3880
end subroutine get_ll_headp
3881
subroutine get_ll_tailp(this, tail)
3882
type(LL_zArray1D), intent(in) :: this
3883
type(LL_zArray1D_LList), pointer :: tail
3884
if ( .not. is_initd(this) ) then
3885
nullify(tail)
3886
return
3887
end if
3888
tail => this%D%head
3889
do while ( associated(tail%next) )
3890
tail => tail%next
3891
if ( associated(tail, this%D%head) ) exit
3892
end do
3893
end subroutine get_ll_tailp
3894
subroutine get_ll_idxp(this, node, index)
3895
type(LL_zArray1D), intent(in), target :: this
3896
type(LL_zArray1D_LList), pointer :: node
3897
integer, intent(in), optional :: index
3898
integer :: lindex
3899
nullify(node)
3900
if ( .not. is_initd(this) ) return
3901
lindex = 0
3902
if ( present(index) ) lindex = index
3903
node => this%D%head
3904
do while ( lindex < 0 .and. associated(node%prev) )
3905
node => node%prev
3906
lindex = lindex + 1
3907
end do
3908
do while ( lindex > 0 .and. associated(node%next) )
3909
node => node%next
3910
lindex = lindex - 1
3911
end do
3912
if ( lindex /= 0 ) then
3913
nullify(node)
3914
return
3915
end if
3916
end subroutine get_ll_idxp
3917
subroutine append_node(ll)
3918
type(LL_zArray1D_LList), pointer :: ll
3919
type(LL_zArray1D_LList), pointer :: tmp => null()
3920
if ( .not. associated(ll) ) return
3921
allocate(tmp)
3922
tmp%next => ll%next
3923
tmp%prev => ll
3924
if ( associated(ll%next) ) then
3925
ll%next%prev => tmp
3926
end if
3927
ll%next => tmp
3928
nullify(tmp)
3929
end subroutine append_node
3930
function size_llist_(this) result (nnodes)
3931
type(LL_zArray1D), intent(in), target :: this
3932
integer :: nnodes
3933
type(LL_zArray1D_LList), pointer :: head, tmp
3934
nnodes = 0
3935
if ( .not. is_initd(this) ) return
3936
call get_ll_headp(this, head)
3937
tmp => head
3938
do while ( associated(tmp) )
3939
nnodes = nnodes + 1
3940
tmp => tmp%next
3941
if ( associated(tmp, head) ) exit
3942
end do
3943
end function size_llist_
3944
subroutine add_node_(this)
3945
type(LL_zArray1D), intent(inout) :: this
3946
type(LL_zArray1D_LList), pointer :: tail
3947
if ( .not. is_initd(this) ) then
3948
call new(this)
3949
allocate(this%D%ll)
3950
this%D%head => this%D%ll
3951
return
3952
end if
3953
call get_ll_tailp(this, tail)
3954
call append_node(tail)
3955
end subroutine add_node_
3956
subroutine add_node_data_(this, D)
3957
type(LL_zArray1D), intent(inout) :: this
3958
type(zArray1D), intent(in) :: D
3959
type(LL_zArray1D_LList), pointer :: tail
3960
call get_ll_tailp(this, tail)
3961
if ( .not. associated(tail) ) then
3962
call new(this, D)
3963
return
3964
end if
3965
call append_node(tail)
3966
tail%next%D = D
3967
end subroutine add_node_data_
3968
subroutine set_data_(this, D)
3969
type(LL_zArray1D), intent(inout) :: this
3970
type(zArray1D), intent(in) :: D
3971
if ( is_initd(this) ) then
3972
this%D%head%D = D
3973
end if
3974
end subroutine set_data_
3975
subroutine set_data_idx_(this, D, index)
3976
type(LL_zArray1D), intent(inout) :: this
3977
type(zArray1D), intent(in) :: D
3978
integer, intent(in) :: index
3979
type(LL_zArray1D_LList), pointer :: node
3980
call get_ll_idxp(this, node, index)
3981
if ( .not. associated(node) ) return
3982
node%D = D
3983
end subroutine set_data_idx_
3984
subroutine set_head_idx_(this, index)
3985
type(LL_zArray1D), intent(inout) :: this
3986
integer, intent(in) :: index
3987
type(LL_zArray1D_LList), pointer :: node
3988
call get_ll_idxp(this, node, index)
3989
if ( .not. associated(node) ) return
3990
this%D%head => node
3991
end subroutine set_head_idx_
3992
subroutine get_node_data_idx_(this, D, index)
3993
type(LL_zArray1D), intent(in), target :: this
3994
type(zArray1D), intent(inout) :: D
3995
integer, intent(in), optional :: index
3996
type(LL_zArray1D_LList), pointer :: node
3997
call delete(D)
3998
if ( .not. is_initd(this) ) return
3999
call get_ll_idxp(this, node, index)
4000
if ( associated(node) ) D = node%D
4001
end subroutine get_node_data_idx_
4002
function itt_step_(this, itt) result(itterated)
4003
type(LL_zArray1D), intent(in) :: this
4004
type(LL_zArray1D), intent(inout) :: itt
4005
logical :: itterated
4006
itterated = .false.
4007
if ( .not. is_initd(this) ) then
4008
call delete(itt)
4009
return
4010
end if
4011
if ( .not. is_initd(itt) ) then
4012
call new(itt)
4013
itt%D%head => this%D%head
4014
itterated = associated(itt%D%head)
4015
else
4016
itt%D%head => itt%D%head%next
4017
itterated = associated(itt%D%head)
4018
if ( itterated ) then
4019
itterated = .not. associated(itt%D%head, this%D%head)
4020
end if
4021
end if
4022
if ( .not. itterated ) then
4023
call delete(itt)
4024
end if
4025
end function itt_step_
4026
function itt_step_i_(this, itt, i) result(itterated)
4027
type(LL_zArray1D), intent(in) :: this
4028
type(LL_zArray1D), intent(inout) :: itt
4029
integer, intent(in) :: i
4030
logical :: itterated
4031
integer :: is
4032
itterated = .false.
4033
if ( .not. is_initd(this) ) then
4034
call delete(itt)
4035
return
4036
end if
4037
is = 0
4038
if ( .not. is_initd(itt) ) then
4039
call new(itt)
4040
itt%D%head => this%D%head
4041
itterated = associated(itt%D%head)
4042
else if ( i > 0 ) then
4043
do while ( is /= i )
4044
is = is + 1
4045
itt%D%head => itt%D%head%next
4046
itterated = associated(itt%D%head)
4047
if ( itterated ) then
4048
itterated = .not. associated(itt%D%head, this%D%head)
4049
end if
4050
if ( .not. itterated ) exit
4051
end do
4052
else if ( i < 0 ) then
4053
do while ( is /= i )
4054
is = is - 1
4055
itt%D%head => itt%D%head%prev
4056
itterated = associated(itt%D%head)
4057
if ( itterated ) then
4058
itterated = .not. associated(itt%D%head, this%D%head)
4059
end if
4060
if ( .not. itterated ) exit
4061
end do
4062
end if
4063
if ( .not. itterated ) then
4064
nullify(itt%D%head)
4065
call delete(itt)
4066
end if
4067
end function itt_step_i_
4068
subroutine remove_node_(this, index)
4069
type(LL_zArray1D), intent(inout), target :: this
4070
integer, intent(in) :: index
4071
type(LL_zArray1D_LList), pointer :: node, pnode, nnode
4072
if ( .not. is_initd(this) ) return
4073
call get_ll_idxp(this, node, index)
4074
if ( .not. associated(node) ) return
4075
pnode => node%prev
4076
nnode => node%next
4077
nullify(node%prev)
4078
nullify(node%next)
4079
if ( associated(pnode) ) then
4080
pnode%next => nnode
4081
end if
4082
if ( associated(nnode) ) then
4083
nnode%prev => pnode
4084
end if
4085
call delete(node%D)
4086
deallocate(node)
4087
end subroutine remove_node_
4088
subroutine remove_node_data_(this, index)
4089
type(LL_zArray1D), intent(inout), target :: this
4090
integer, intent(in), optional :: index
4091
type(LL_zArray1D_LList), pointer :: node
4092
if ( .not. is_initd(this) ) return
4093
call get_ll_idxp(this, node, index)
4094
if ( .not. associated(node) ) return
4095
call delete(node%D)
4096
end subroutine remove_node_data_
4097
subroutine copy_(from, to)
4098
type(LL_zArray1D), intent(inout) :: from, to
4099
type(LL_zArray1D_LList), pointer :: t, f
4100
call delete(to)
4101
if ( .not. is_initd(from) ) return
4102
call new(to)
4103
f => from%D%head
4104
t => to%D%head
4105
t%D = f%D
4106
do while ( associated(f%next) )
4107
f => f%next
4108
allocate(t%next)
4109
t%next%prev => t
4110
t => t%next
4111
t%D = f%D
4112
if ( associated(t, to%D%head) ) return
4113
end do
4114
f => from%D%head
4115
t => to%D%head
4116
do while ( associated(f%prev) )
4117
f => f%prev
4118
allocate(t%prev)
4119
t%prev%next => t
4120
t => t%prev
4121
t%D = f%D
4122
end do
4123
end subroutine copy_
4124
subroutine print_(this, info, indent)
4125
type(LL_zArray1D), intent(in), target :: this
4126
character(len=*), intent(in), optional :: info
4127
integer, intent(in), optional :: indent
4128
integer :: lindent
4129
type(LL_zArray1D_LList), pointer :: node
4130
character(len=32) :: fmt
4131
character(len=256) :: name
4132
name = "LL_zArray1D"
4133
if ( present(info) ) name = info
4134
lindent = 1
4135
if ( present(indent) ) lindent = indent
4136
write(fmt, '(a,i0,a)') '(t',lindent,',3a)'
4137
if ( .not. is_initd(this) ) then
4138
write(*,fmt) "<", trim(name), " not initialized>"
4139
return
4140
end if
4141
write(fmt, '(a,i0,a)') '(t',lindent,',3a,i0,a)'
4142
write(*,fmt) "<<", trim(name), " llist, nodes=",nodes(this),">"
4143
lindent = lindent + 2 ! step indentation
4144
call get_ll_headp(this, node)
4145
do while ( associated(node) )
4146
if ( associated(node, this%D%head) ) then
4147
write(fmt, '(a,i0,a)') '(t',lindent,',a)'
4148
call print(node%D, indent = lindent+2)
4149
else
4150
call print(node%D, indent = lindent)
4151
end if
4152
node => node%next
4153
end do
4154
lindent = lindent - 2 ! go back to requested indentation
4155
write(fmt, '(a,i0,a)') '(t',lindent,',a,i0,a)'
4156
write(*,fmt) " <llist-refs: ", references(this), ">>"
4157
end subroutine print_
4158
end module
Loggerhead is a web-based interface for Breezy
Version: 2.0.1