~nickpapior/siesta/trunk-buds-format0.92
» Revision
616
: Src/buds/sources_mpi/src/bud_SM_CSC0_Array3D.f90
« back to all changes in this revision
Viewing changes to Src/buds/sources_mpi/src/bud_SM_CSC0_Array3D.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_SM_CSC0_Array3D.f90
1
module bud_iCSC0_b3D
2
use bud_iSM_CSC0
3
use bud_bArray3D
4
implicit none
5
private
6
integer, parameter :: rr_ = selected_real_kind(p=6) ! single (real*4)
7
integer, parameter :: rd_ = selected_real_kind(p=15) ! double (real*8)
8
integer, parameter :: is_ = selected_int_kind(4) ! short (integer*2)
9
integer, parameter :: ii_ = selected_int_kind(9) ! int (integer*4)
10
integer, parameter :: il_ = selected_int_kind(18) ! long (integer*8)
11
integer, parameter, private :: BUD_ID_LEn = 36
12
character(len=*), parameter, private :: &
13
BUD_MOd = 'BUD_CC2(BUD_MOD,_)BUD_MOD_NAME'
14
character(len=*), parameter, private :: &
15
BUD_TYPe = "iCSC0_b3D"
16
integer(ii_), parameter :: ONE = 1_ii_
17
integer(ii_), parameter :: ZERO = 0_ii_
18
interface matrix_p
19
module procedure matrix_p_
20
end interface
21
public :: matrix_p
22
interface sparse_matrix
23
module procedure get_elem1_
24
end interface
25
public :: sparse_matrix
26
interface sparse_matrix_p
27
module procedure get_elem1p_
28
end interface
29
public :: sparse_matrix_p
30
interface sparse_index
31
module procedure sparse_index_
32
end interface
33
public :: sparse_index
34
interface dimensions
35
module procedure dimensions_
36
end interface
37
public :: dimensions
38
interface array
39
module procedure get_elem2_
40
end interface
41
public :: array
42
interface array_p
43
module procedure get_elem2p_
44
end interface
45
public :: array_p
46
interface add_element
47
module procedure add_element_
48
end interface
49
public :: add_element
50
type iCSC0_b3D
51
type(iCSC0_b3D_), pointer :: D => null()
52
integer :: error_ = 0
53
end type iCSC0_b3D
54
type iCSC0_b3D_
55
type(iSM_CSC0) :: e1
56
type(bArray3D) :: e2
57
integer :: sm_idx = 3
58
integer :: refs_ = 0
59
character(len=BUD_ID_LEN) :: id_ = "null_id"
60
end type iCSC0_b3D_
61
interface new
62
module procedure new_
63
module procedure new_data_
64
end interface
65
public :: new
66
interface assignment(=)
67
module procedure get_elem1_assign_
68
module procedure get_elem2_assign_
69
module procedure set_elem1_
70
module procedure set_elem2_
71
end interface
72
interface element
73
module procedure get_elem1_
74
module procedure get_elem2_
75
end interface
76
interface set_element
77
module procedure set_elem1_
78
module procedure set_elem2_
79
end interface
80
interface element1
81
module procedure get_elem1_
82
end interface
83
public :: element1
84
interface set_element1
85
module procedure set_elem1_
86
end interface
87
public :: set_element1
88
interface element1_p
89
module procedure get_elem1p_
90
end interface
91
public :: element1_p
92
interface element2
93
module procedure get_elem2_
94
end interface
95
public :: element2
96
interface set_element2
97
module procedure set_elem2_
98
end interface
99
public :: set_element2
100
interface element2_p
101
module procedure get_elem2p_
102
end interface
103
public :: element2_p
104
public :: iCSC0_b3D
105
private :: iCSC0_b3D_
106
interface assignment(=)
107
module procedure common_assign_
108
end interface
109
public :: assignment(=)
110
private :: common_assign_
111
interface initialize
112
module procedure common_initialize_
113
end interface
114
public :: initialize
115
private :: common_initialize_
116
interface is_initialized
117
module procedure common_is_initialized_
118
end interface
119
public :: is_initialized
120
private :: common_is_initialized_
121
interface initialized
122
module procedure common_is_initialized_
123
end interface
124
public :: initialized
125
interface is_initd
126
module procedure common_is_initialized_
127
end interface
128
public :: is_initd
129
interface is_same
130
module procedure common_is_same_
131
end interface
132
public :: is_same
133
private :: common_is_same_
134
interface same
135
module procedure common_is_same_
136
end interface
137
public :: same
138
interface delete
139
module procedure common_delete_
140
end interface
141
public :: delete
142
private :: common_delete_
143
interface nullify
144
module procedure common_nullify_
145
end interface
146
public :: nullify
147
private :: common_nullify_
148
interface copy
149
module procedure copy_
150
end interface
151
public :: copy
152
private :: common_copy_
153
interface print
154
module procedure print_
155
end interface
156
public :: print
157
interface read
158
module procedure read_
159
end interface
160
public :: read
161
interface write
162
module procedure write_
163
end interface
164
public :: write
165
interface references
166
module procedure common_references_
167
end interface
168
public :: references
169
private :: common_references_
170
interface refs
171
module procedure common_references_
172
end interface
173
public :: refs
174
interface set_error
175
module procedure common_set_error_is_
176
module procedure common_set_error_ii_
177
module procedure common_set_error_il_
178
end interface
179
public :: set_error
180
private :: common_set_error_is_
181
private :: common_set_error_ii_
182
private :: common_set_error_il_
183
interface error
184
module procedure common_error_
185
end interface
186
public :: error
187
private :: common_error_
188
contains
189
subroutine common_copy_(from, to)
190
type(iCSC0_b3D), intent(in) :: from
191
type(iCSC0_b3D), intent(inout) :: to
192
call set_error(to, error(from))
193
end subroutine common_copy_
194
subroutine common_initialize_(this)
195
type(iCSC0_b3D), intent(inout) :: this
196
integer :: error
197
call delete(this)
198
allocate(this%D, stat=error)
199
call set_error(this, error)
200
if ( error /= 0 ) return
201
this%D%refs_ = 1
202
call common_tag_object_(this)
203
end subroutine common_initialize_
204
pure function common_is_initialized_(this) result(init)
205
type(iCSC0_b3D), intent(in) :: this
206
logical :: init
207
init = associated(this%D)
208
end function common_is_initialized_
209
elemental function common_is_same_(lhs, rhs) result(same)
210
type(iCSC0_b3D), intent(in) :: lhs, rhs
211
logical :: same
212
same = is_initd(lhs) .and. is_initd(rhs)
213
if ( .not. same ) return
214
same = associated(lhs%D, target=rhs%D)
215
end function common_is_same_
216
subroutine common_delete_(this)
217
type(iCSC0_b3D), intent(inout) :: this
218
integer :: error
219
call set_error(this, 0)
220
if (.not. is_initd(this) ) return
221
this%D%refs_ = this%D%refs_ - 1
222
if ( 0 == this%D%refs_ ) then
223
call delete_(this)
224
deallocate(this%D, stat=error)
225
call set_error(this, error)
226
end if
227
nullify(this%D)
228
end subroutine common_delete_
229
elemental subroutine common_nullify_(this)
230
type(iCSC0_b3D), intent(inout) :: this
231
if (.not. is_initd(this) ) return
232
nullify(this%D)
233
end subroutine common_nullify_
234
subroutine common_assign_(lhs, rhs)
235
type(iCSC0_b3D), intent(inout) :: lhs
236
type(iCSC0_b3D), intent(in) :: rhs
237
call delete(lhs)
238
if ( .not. is_initd(rhs) ) return
239
lhs%D => rhs%D
240
lhs%D%refs_ = rhs%D%refs_ + 1
241
end subroutine common_assign_
242
elemental function common_references_(this) result(refs)
243
type(iCSC0_b3D), intent(in) :: this
244
integer :: refs
245
if ( is_initd(this) ) then
246
refs = this%D%refs_
247
else
248
refs = 0
249
end if
250
end function common_references_
251
elemental function common_error_(this) result(error)
252
type(iCSC0_b3D), intent(in) :: this
253
integer :: error
254
if ( is_initd(this) ) then
255
error = this%error_
256
else
257
error = 0
258
end if
259
end function common_error_
260
elemental subroutine common_set_error_is_(this, error)
261
type(iCSC0_b3D), intent(inout) :: this
262
integer(is_), intent(in) :: error
263
this%error_ = error
264
end subroutine common_set_error_is_
265
elemental subroutine common_set_error_ii_(this, error)
266
type(iCSC0_b3D), intent(inout) :: this
267
integer(ii_), intent(in) :: error
268
this%error_ = error
269
end subroutine common_set_error_ii_
270
elemental subroutine common_set_error_il_(this, error)
271
type(iCSC0_b3D), intent(inout) :: this
272
integer(il_), intent(in) :: error
273
this%error_ = error
274
end subroutine common_set_error_il_
275
elemental function common_id_(this) result(str)
276
type(iCSC0_b3D), intent(in) :: this
277
character(len=BUD_ID_LEn) :: str
278
str = this%D%id_
279
end function common_id_
280
subroutine common_tag_object_(this)
281
type(iCSC0_b3D), intent(inout) :: this
282
end subroutine common_tag_object_
283
subroutine delete_(this)
284
type(iCSC0_b3D), intent(inout) :: this
285
call set_error(this, 0)
286
call delete(this%D%e1)
287
if ( 0 /= error(this%D%e1) ) &
288
call set_error(this, error(this%D%e1))
289
call delete(this%D%e2)
290
if ( 0 /= error(this%D%e2) ) &
291
call set_error(this, error(this%D%e2))
292
end subroutine delete_
293
subroutine copy_(from, to)
294
type(iCSC0_b3D), intent(in) :: from
295
type(iCSC0_b3D), intent(inout) :: to
296
call delete(to)
297
if ( .not. is_initd(from) ) return
298
call initialize(to)
299
call common_copy_(from, to)
300
call copy(from%D%e1, to%D%e1)
301
call copy(from%D%e2, to%D%e2)
302
end subroutine copy_
303
subroutine new_data_(this, a, b &
304
)
305
type(iCSC0_b3D), intent(inout) :: this
306
type(iSM_CSC0), intent(inout) :: a
307
type(bArray3D), intent(inout) :: b
308
call new(this)
309
this%D%e1 = a
310
this%D%e2 = b
311
end subroutine new_data_
312
subroutine new_(this)
313
type(iCSC0_b3D), intent(inout) :: this
314
call initialize(this)
315
end subroutine new_
316
subroutine get_elem1_(this, item)
317
type(iCSC0_b3D), intent(in) :: this
318
type(iSM_CSC0), intent(inout) :: item
319
if ( .not. is_initd(this) ) then
320
call delete(item)
321
else
322
item = this%D% e1
323
end if
324
end subroutine
325
subroutine get_elem1_assign_(item, this)
326
type(iSM_CSC0), intent(inout) :: item
327
type(iCSC0_b3D), intent(in) :: this
328
if ( .not. is_initd(this) ) then
329
call delete(item)
330
else
331
item = this%D% e1
332
end if
333
end subroutine
334
subroutine set_elem1_(this, item)
335
type(iCSC0_b3D), intent(inout) :: this
336
type(iSM_CSC0), intent(in) :: item
337
if ( .not. is_initd(this) ) return
338
this%D% e1 = item
339
end subroutine
340
function get_elem1p_(this) result(p)
341
type(iCSC0_b3D), intent(inout) :: this
342
type(iSM_CSC0), pointer :: p
343
if ( .not. is_initd(this) ) then
344
nullify(p)
345
else
346
p => this%D% e1
347
end if
348
end function
349
subroutine get_elem2_(this, item)
350
type(iCSC0_b3D), intent(in) :: this
351
type(bArray3D), intent(inout) :: item
352
if ( .not. is_initd(this) ) then
353
call delete(item)
354
else
355
item = this%D% e2
356
end if
357
end subroutine
358
subroutine get_elem2_assign_(item, this)
359
type(bArray3D), intent(inout) :: item
360
type(iCSC0_b3D), intent(in) :: this
361
if ( .not. is_initd(this) ) then
362
call delete(item)
363
else
364
item = this%D% e2
365
end if
366
end subroutine
367
subroutine set_elem2_(this, item)
368
type(iCSC0_b3D), intent(inout) :: this
369
type(bArray3D), intent(in) :: item
370
if ( .not. is_initd(this) ) return
371
this%D% e2 = item
372
end subroutine
373
function get_elem2p_(this) result(p)
374
type(iCSC0_b3D), intent(inout) :: this
375
type(bArray3D), pointer :: p
376
if ( .not. is_initd(this) ) then
377
nullify(p)
378
else
379
p => this%D% e2
380
end if
381
end function
382
subroutine print_(this, info, indent)
383
type(iCSC0_b3D), intent(in) :: this
384
character(len=*), intent(in), optional :: info
385
integer, intent(in), optional :: indent
386
integer :: lindent
387
character(len=32) :: fmt
388
character(len=256) :: name
389
name = "iCSC0_b3D"
390
if ( present(info) ) name = info
391
lindent = 1
392
if ( present(indent) ) lindent = indent
393
write(fmt, '(a,i0,a)') '(t',lindent,',3a)'
394
if ( .not. is_initd(this) ) then
395
write(*,fmt) "<", trim(name), " not initialized>"
396
return
397
end if
398
write(fmt, '(a,i0,a)') '(t',lindent,',3a)'
399
lindent = lindent + 2 ! step indentation
400
write(*,fmt) "<<", trim(name), " coll>"
401
call print(this%D%e1, indent = lindent)
402
call print(this%D%e2, indent = lindent)
403
lindent = lindent - 2 ! go back to requested indentation
404
write(fmt, '(a,i0,a)') '(t',lindent,',a,i0,a)'
405
write(*,fmt) " <coll-refs: ", references(this), ">>"
406
end subroutine print_
407
function matrix_p_(this) result(p)
408
type(iCSC0_b3D), intent(in) :: this
409
logical, pointer :: p (:,:,:)
410
p => array_p(this%D%e2)
411
end function matrix_p_
412
function sparse_index_(this) result(idx)
413
type(iCSC0_b3D), intent(in) :: this
414
integer :: idx
415
idx = this%D%sm_idx
416
end function sparse_index_
417
pure function dimensions_(this) result(d)
418
type(iCSC0_b3D), intent(in) :: this
419
integer :: d
420
if ( is_initd(this) ) then
421
d = 3
422
else
423
d = -1
424
end if
425
end function dimensions_
426
recursive subroutine add_element_(this, ir, ic, val)
427
type(iCSC0_b3D), intent(inout) :: this
428
integer(ii_), intent(in) :: ir, ic
429
logical, intent(in) :: val
430
type(iSM_CSC0) :: sm
431
type(iCSC0_b3D) :: nthis
432
integer(ii_) :: i, c, ix, nr, nc, npc
433
logical, pointer :: p (:,:,:)
434
if ( .not. is_initd(this) ) return
435
sm = this
436
call add_element(sm, ir, ic, dry_run = .true.)
437
if ( error(sm) /= 0 ) then
438
call delete(sm)
439
call set_error(this, -1)
440
return
441
end if
442
call add_element(sm, ir, ic)
443
i = index(sm, ir, ic)
444
p => matrix_p(this)
445
select case ( sparse_index(this) )
446
case ( 1 )
447
p(i,:,:) = val
448
case ( 2 )
449
p(:,i,:) = val
450
case ( 3 )
451
p(:,:,i) = val
452
end select
453
call delete(sm)
454
end subroutine add_element_
455
subroutine write_(f, this, only_array)
456
use bud_File
457
type( File ), intent(inout) :: f
458
type(iCSC0_b3D), intent(inout) :: this
459
logical, intent(in), optional :: only_array
460
type(iSM_CSC0) :: sm
461
type(bArray3D) :: arr
462
logical :: lonly_array
463
if ( .not. is_open(f) ) return
464
if ( .not. is_initd(this) ) return
465
lonly_array = .false.
466
if ( present(only_array) ) lonly_array = only_array
467
sm = this
468
arr = this
469
if ( .not. is_finalized(sm) ) then
470
call delete(sm)
471
call delete(arr)
472
call set_error(this, -1)
473
return
474
end if
475
if ( .not. lonly_array ) then
476
call write(f, sm)
477
end if
478
call write(f, arr)
479
call delete(sm)
480
call delete(arr)
481
end subroutine write_
482
subroutine read_(f, this, sm)
483
use bud_File
484
type( File ), intent(inout) :: f
485
type(iCSC0_b3D), intent(inout) :: this
486
type(iSM_CSC0), intent(inout), optional :: sm
487
type(iSM_CSC0) :: lsm
488
type(bArray3D) :: arr
489
if ( .not. is_open(f) ) return
490
if ( present(sm) ) then
491
lsm = sm
492
else
493
call read(f, lsm)
494
end if
495
call read(f, arr)
496
call new(this, lsm, arr)
497
call delete(lsm)
498
end subroutine read_
499
end module
500
module bud_iCSC0_r3D
501
use bud_iSM_CSC0
502
use bud_rArray3D
503
implicit none
504
private
505
integer, parameter :: rr_ = selected_real_kind(p=6) ! single (real*4)
506
integer, parameter :: rd_ = selected_real_kind(p=15) ! double (real*8)
507
integer, parameter :: is_ = selected_int_kind(4) ! short (integer*2)
508
integer, parameter :: ii_ = selected_int_kind(9) ! int (integer*4)
509
integer, parameter :: il_ = selected_int_kind(18) ! long (integer*8)
510
integer, parameter, private :: BUD_ID_LEn = 36
511
character(len=*), parameter, private :: &
512
BUD_MOd = 'BUD_CC2(BUD_MOD,_)BUD_MOD_NAME'
513
character(len=*), parameter, private :: &
514
BUD_TYPe = "iCSC0_r3D"
515
integer(ii_), parameter :: ONE = 1_ii_
516
integer(ii_), parameter :: ZERO = 0_ii_
517
interface matrix_p
518
module procedure matrix_p_
519
end interface
520
public :: matrix_p
521
interface sparse_matrix
522
module procedure get_elem1_
523
end interface
524
public :: sparse_matrix
525
interface sparse_matrix_p
526
module procedure get_elem1p_
527
end interface
528
public :: sparse_matrix_p
529
interface sparse_index
530
module procedure sparse_index_
531
end interface
532
public :: sparse_index
533
interface dimensions
534
module procedure dimensions_
535
end interface
536
public :: dimensions
537
interface array
538
module procedure get_elem2_
539
end interface
540
public :: array
541
interface array_p
542
module procedure get_elem2p_
543
end interface
544
public :: array_p
545
interface add_element
546
module procedure add_element_
547
end interface
548
public :: add_element
549
type iCSC0_r3D
550
type(iCSC0_r3D_), pointer :: D => null()
551
integer :: error_ = 0
552
end type iCSC0_r3D
553
type iCSC0_r3D_
554
type(iSM_CSC0) :: e1
555
type(rArray3D) :: e2
556
integer :: sm_idx = 3
557
integer :: refs_ = 0
558
character(len=BUD_ID_LEN) :: id_ = "null_id"
559
end type iCSC0_r3D_
560
interface new
561
module procedure new_
562
module procedure new_data_
563
end interface
564
public :: new
565
interface assignment(=)
566
module procedure get_elem1_assign_
567
module procedure get_elem2_assign_
568
module procedure set_elem1_
569
module procedure set_elem2_
570
end interface
571
interface element
572
module procedure get_elem1_
573
module procedure get_elem2_
574
end interface
575
interface set_element
576
module procedure set_elem1_
577
module procedure set_elem2_
578
end interface
579
interface element1
580
module procedure get_elem1_
581
end interface
582
public :: element1
583
interface set_element1
584
module procedure set_elem1_
585
end interface
586
public :: set_element1
587
interface element1_p
588
module procedure get_elem1p_
589
end interface
590
public :: element1_p
591
interface element2
592
module procedure get_elem2_
593
end interface
594
public :: element2
595
interface set_element2
596
module procedure set_elem2_
597
end interface
598
public :: set_element2
599
interface element2_p
600
module procedure get_elem2p_
601
end interface
602
public :: element2_p
603
public :: iCSC0_r3D
604
private :: iCSC0_r3D_
605
interface assignment(=)
606
module procedure common_assign_
607
end interface
608
public :: assignment(=)
609
private :: common_assign_
610
interface initialize
611
module procedure common_initialize_
612
end interface
613
public :: initialize
614
private :: common_initialize_
615
interface is_initialized
616
module procedure common_is_initialized_
617
end interface
618
public :: is_initialized
619
private :: common_is_initialized_
620
interface initialized
621
module procedure common_is_initialized_
622
end interface
623
public :: initialized
624
interface is_initd
625
module procedure common_is_initialized_
626
end interface
627
public :: is_initd
628
interface is_same
629
module procedure common_is_same_
630
end interface
631
public :: is_same
632
private :: common_is_same_
633
interface same
634
module procedure common_is_same_
635
end interface
636
public :: same
637
interface delete
638
module procedure common_delete_
639
end interface
640
public :: delete
641
private :: common_delete_
642
interface nullify
643
module procedure common_nullify_
644
end interface
645
public :: nullify
646
private :: common_nullify_
647
interface copy
648
module procedure copy_
649
end interface
650
public :: copy
651
private :: common_copy_
652
interface print
653
module procedure print_
654
end interface
655
public :: print
656
interface read
657
module procedure read_
658
end interface
659
public :: read
660
interface write
661
module procedure write_
662
end interface
663
public :: write
664
interface references
665
module procedure common_references_
666
end interface
667
public :: references
668
private :: common_references_
669
interface refs
670
module procedure common_references_
671
end interface
672
public :: refs
673
interface set_error
674
module procedure common_set_error_is_
675
module procedure common_set_error_ii_
676
module procedure common_set_error_il_
677
end interface
678
public :: set_error
679
private :: common_set_error_is_
680
private :: common_set_error_ii_
681
private :: common_set_error_il_
682
interface error
683
module procedure common_error_
684
end interface
685
public :: error
686
private :: common_error_
687
contains
688
subroutine common_copy_(from, to)
689
type(iCSC0_r3D), intent(in) :: from
690
type(iCSC0_r3D), intent(inout) :: to
691
call set_error(to, error(from))
692
end subroutine common_copy_
693
subroutine common_initialize_(this)
694
type(iCSC0_r3D), intent(inout) :: this
695
integer :: error
696
call delete(this)
697
allocate(this%D, stat=error)
698
call set_error(this, error)
699
if ( error /= 0 ) return
700
this%D%refs_ = 1
701
call common_tag_object_(this)
702
end subroutine common_initialize_
703
pure function common_is_initialized_(this) result(init)
704
type(iCSC0_r3D), intent(in) :: this
705
logical :: init
706
init = associated(this%D)
707
end function common_is_initialized_
708
elemental function common_is_same_(lhs, rhs) result(same)
709
type(iCSC0_r3D), intent(in) :: lhs, rhs
710
logical :: same
711
same = is_initd(lhs) .and. is_initd(rhs)
712
if ( .not. same ) return
713
same = associated(lhs%D, target=rhs%D)
714
end function common_is_same_
715
subroutine common_delete_(this)
716
type(iCSC0_r3D), intent(inout) :: this
717
integer :: error
718
call set_error(this, 0)
719
if (.not. is_initd(this) ) return
720
this%D%refs_ = this%D%refs_ - 1
721
if ( 0 == this%D%refs_ ) then
722
call delete_(this)
723
deallocate(this%D, stat=error)
724
call set_error(this, error)
725
end if
726
nullify(this%D)
727
end subroutine common_delete_
728
elemental subroutine common_nullify_(this)
729
type(iCSC0_r3D), intent(inout) :: this
730
if (.not. is_initd(this) ) return
731
nullify(this%D)
732
end subroutine common_nullify_
733
subroutine common_assign_(lhs, rhs)
734
type(iCSC0_r3D), intent(inout) :: lhs
735
type(iCSC0_r3D), intent(in) :: rhs
736
call delete(lhs)
737
if ( .not. is_initd(rhs) ) return
738
lhs%D => rhs%D
739
lhs%D%refs_ = rhs%D%refs_ + 1
740
end subroutine common_assign_
741
elemental function common_references_(this) result(refs)
742
type(iCSC0_r3D), intent(in) :: this
743
integer :: refs
744
if ( is_initd(this) ) then
745
refs = this%D%refs_
746
else
747
refs = 0
748
end if
749
end function common_references_
750
elemental function common_error_(this) result(error)
751
type(iCSC0_r3D), intent(in) :: this
752
integer :: error
753
if ( is_initd(this) ) then
754
error = this%error_
755
else
756
error = 0
757
end if
758
end function common_error_
759
elemental subroutine common_set_error_is_(this, error)
760
type(iCSC0_r3D), intent(inout) :: this
761
integer(is_), intent(in) :: error
762
this%error_ = error
763
end subroutine common_set_error_is_
764
elemental subroutine common_set_error_ii_(this, error)
765
type(iCSC0_r3D), intent(inout) :: this
766
integer(ii_), intent(in) :: error
767
this%error_ = error
768
end subroutine common_set_error_ii_
769
elemental subroutine common_set_error_il_(this, error)
770
type(iCSC0_r3D), intent(inout) :: this
771
integer(il_), intent(in) :: error
772
this%error_ = error
773
end subroutine common_set_error_il_
774
elemental function common_id_(this) result(str)
775
type(iCSC0_r3D), intent(in) :: this
776
character(len=BUD_ID_LEn) :: str
777
str = this%D%id_
778
end function common_id_
779
subroutine common_tag_object_(this)
780
type(iCSC0_r3D), intent(inout) :: this
781
end subroutine common_tag_object_
782
subroutine delete_(this)
783
type(iCSC0_r3D), intent(inout) :: this
784
call set_error(this, 0)
785
call delete(this%D%e1)
786
if ( 0 /= error(this%D%e1) ) &
787
call set_error(this, error(this%D%e1))
788
call delete(this%D%e2)
789
if ( 0 /= error(this%D%e2) ) &
790
call set_error(this, error(this%D%e2))
791
end subroutine delete_
792
subroutine copy_(from, to)
793
type(iCSC0_r3D), intent(in) :: from
794
type(iCSC0_r3D), intent(inout) :: to
795
call delete(to)
796
if ( .not. is_initd(from) ) return
797
call initialize(to)
798
call common_copy_(from, to)
799
call copy(from%D%e1, to%D%e1)
800
call copy(from%D%e2, to%D%e2)
801
end subroutine copy_
802
subroutine new_data_(this, a, b &
803
)
804
type(iCSC0_r3D), intent(inout) :: this
805
type(iSM_CSC0), intent(inout) :: a
806
type(rArray3D), intent(inout) :: b
807
call new(this)
808
this%D%e1 = a
809
this%D%e2 = b
810
end subroutine new_data_
811
subroutine new_(this)
812
type(iCSC0_r3D), intent(inout) :: this
813
call initialize(this)
814
end subroutine new_
815
subroutine get_elem1_(this, item)
816
type(iCSC0_r3D), intent(in) :: this
817
type(iSM_CSC0), intent(inout) :: item
818
if ( .not. is_initd(this) ) then
819
call delete(item)
820
else
821
item = this%D% e1
822
end if
823
end subroutine
824
subroutine get_elem1_assign_(item, this)
825
type(iSM_CSC0), intent(inout) :: item
826
type(iCSC0_r3D), intent(in) :: this
827
if ( .not. is_initd(this) ) then
828
call delete(item)
829
else
830
item = this%D% e1
831
end if
832
end subroutine
833
subroutine set_elem1_(this, item)
834
type(iCSC0_r3D), intent(inout) :: this
835
type(iSM_CSC0), intent(in) :: item
836
if ( .not. is_initd(this) ) return
837
this%D% e1 = item
838
end subroutine
839
function get_elem1p_(this) result(p)
840
type(iCSC0_r3D), intent(inout) :: this
841
type(iSM_CSC0), pointer :: p
842
if ( .not. is_initd(this) ) then
843
nullify(p)
844
else
845
p => this%D% e1
846
end if
847
end function
848
subroutine get_elem2_(this, item)
849
type(iCSC0_r3D), intent(in) :: this
850
type(rArray3D), intent(inout) :: item
851
if ( .not. is_initd(this) ) then
852
call delete(item)
853
else
854
item = this%D% e2
855
end if
856
end subroutine
857
subroutine get_elem2_assign_(item, this)
858
type(rArray3D), intent(inout) :: item
859
type(iCSC0_r3D), intent(in) :: this
860
if ( .not. is_initd(this) ) then
861
call delete(item)
862
else
863
item = this%D% e2
864
end if
865
end subroutine
866
subroutine set_elem2_(this, item)
867
type(iCSC0_r3D), intent(inout) :: this
868
type(rArray3D), intent(in) :: item
869
if ( .not. is_initd(this) ) return
870
this%D% e2 = item
871
end subroutine
872
function get_elem2p_(this) result(p)
873
type(iCSC0_r3D), intent(inout) :: this
874
type(rArray3D), pointer :: p
875
if ( .not. is_initd(this) ) then
876
nullify(p)
877
else
878
p => this%D% e2
879
end if
880
end function
881
subroutine print_(this, info, indent)
882
type(iCSC0_r3D), intent(in) :: this
883
character(len=*), intent(in), optional :: info
884
integer, intent(in), optional :: indent
885
integer :: lindent
886
character(len=32) :: fmt
887
character(len=256) :: name
888
name = "iCSC0_r3D"
889
if ( present(info) ) name = info
890
lindent = 1
891
if ( present(indent) ) lindent = indent
892
write(fmt, '(a,i0,a)') '(t',lindent,',3a)'
893
if ( .not. is_initd(this) ) then
894
write(*,fmt) "<", trim(name), " not initialized>"
895
return
896
end if
897
write(fmt, '(a,i0,a)') '(t',lindent,',3a)'
898
lindent = lindent + 2 ! step indentation
899
write(*,fmt) "<<", trim(name), " coll>"
900
call print(this%D%e1, indent = lindent)
901
call print(this%D%e2, indent = lindent)
902
lindent = lindent - 2 ! go back to requested indentation
903
write(fmt, '(a,i0,a)') '(t',lindent,',a,i0,a)'
904
write(*,fmt) " <coll-refs: ", references(this), ">>"
905
end subroutine print_
906
function matrix_p_(this) result(p)
907
type(iCSC0_r3D), intent(in) :: this
908
real(rr_), pointer :: p (:,:,:)
909
p => array_p(this%D%e2)
910
end function matrix_p_
911
function sparse_index_(this) result(idx)
912
type(iCSC0_r3D), intent(in) :: this
913
integer :: idx
914
idx = this%D%sm_idx
915
end function sparse_index_
916
pure function dimensions_(this) result(d)
917
type(iCSC0_r3D), intent(in) :: this
918
integer :: d
919
if ( is_initd(this) ) then
920
d = 3
921
else
922
d = -1
923
end if
924
end function dimensions_
925
recursive subroutine add_element_(this, ir, ic, val)
926
type(iCSC0_r3D), intent(inout) :: this
927
integer(ii_), intent(in) :: ir, ic
928
real(rr_), intent(in) :: val
929
type(iSM_CSC0) :: sm
930
type(iCSC0_r3D) :: nthis
931
integer(ii_) :: i, c, ix, nr, nc, npc
932
real(rr_), pointer :: p (:,:,:)
933
if ( .not. is_initd(this) ) return
934
sm = this
935
call add_element(sm, ir, ic, dry_run = .true.)
936
if ( error(sm) /= 0 ) then
937
call delete(sm)
938
call set_error(this, -1)
939
return
940
end if
941
call add_element(sm, ir, ic)
942
i = index(sm, ir, ic)
943
p => matrix_p(this)
944
select case ( sparse_index(this) )
945
case ( 1 )
946
p(i,:,:) = val
947
case ( 2 )
948
p(:,i,:) = val
949
case ( 3 )
950
p(:,:,i) = val
951
end select
952
call delete(sm)
953
end subroutine add_element_
954
subroutine write_(f, this, only_array)
955
use bud_File
956
type( File ), intent(inout) :: f
957
type(iCSC0_r3D), intent(inout) :: this
958
logical, intent(in), optional :: only_array
959
type(iSM_CSC0) :: sm
960
type(rArray3D) :: arr
961
logical :: lonly_array
962
if ( .not. is_open(f) ) return
963
if ( .not. is_initd(this) ) return
964
lonly_array = .false.
965
if ( present(only_array) ) lonly_array = only_array
966
sm = this
967
arr = this
968
if ( .not. is_finalized(sm) ) then
969
call delete(sm)
970
call delete(arr)
971
call set_error(this, -1)
972
return
973
end if
974
if ( .not. lonly_array ) then
975
call write(f, sm)
976
end if
977
call write(f, arr)
978
call delete(sm)
979
call delete(arr)
980
end subroutine write_
981
subroutine read_(f, this, sm)
982
use bud_File
983
type( File ), intent(inout) :: f
984
type(iCSC0_r3D), intent(inout) :: this
985
type(iSM_CSC0), intent(inout), optional :: sm
986
type(iSM_CSC0) :: lsm
987
type(rArray3D) :: arr
988
if ( .not. is_open(f) ) return
989
if ( present(sm) ) then
990
lsm = sm
991
else
992
call read(f, lsm)
993
end if
994
call read(f, arr)
995
call new(this, lsm, arr)
996
call delete(lsm)
997
end subroutine read_
998
end module
999
module bud_iCSC0_d3D
1000
use bud_iSM_CSC0
1001
use bud_dArray3D
1002
implicit none
1003
private
1004
integer, parameter :: rr_ = selected_real_kind(p=6) ! single (real*4)
1005
integer, parameter :: rd_ = selected_real_kind(p=15) ! double (real*8)
1006
integer, parameter :: is_ = selected_int_kind(4) ! short (integer*2)
1007
integer, parameter :: ii_ = selected_int_kind(9) ! int (integer*4)
1008
integer, parameter :: il_ = selected_int_kind(18) ! long (integer*8)
1009
integer, parameter, private :: BUD_ID_LEn = 36
1010
character(len=*), parameter, private :: &
1011
BUD_MOd = 'BUD_CC2(BUD_MOD,_)BUD_MOD_NAME'
1012
character(len=*), parameter, private :: &
1013
BUD_TYPe = "iCSC0_d3D"
1014
integer(ii_), parameter :: ONE = 1_ii_
1015
integer(ii_), parameter :: ZERO = 0_ii_
1016
interface matrix_p
1017
module procedure matrix_p_
1018
end interface
1019
public :: matrix_p
1020
interface sparse_matrix
1021
module procedure get_elem1_
1022
end interface
1023
public :: sparse_matrix
1024
interface sparse_matrix_p
1025
module procedure get_elem1p_
1026
end interface
1027
public :: sparse_matrix_p
1028
interface sparse_index
1029
module procedure sparse_index_
1030
end interface
1031
public :: sparse_index
1032
interface dimensions
1033
module procedure dimensions_
1034
end interface
1035
public :: dimensions
1036
interface array
1037
module procedure get_elem2_
1038
end interface
1039
public :: array
1040
interface array_p
1041
module procedure get_elem2p_
1042
end interface
1043
public :: array_p
1044
interface add_element
1045
module procedure add_element_
1046
end interface
1047
public :: add_element
1048
type iCSC0_d3D
1049
type(iCSC0_d3D_), pointer :: D => null()
1050
integer :: error_ = 0
1051
end type iCSC0_d3D
1052
type iCSC0_d3D_
1053
type(iSM_CSC0) :: e1
1054
type(dArray3D) :: e2
1055
integer :: sm_idx = 3
1056
integer :: refs_ = 0
1057
character(len=BUD_ID_LEN) :: id_ = "null_id"
1058
end type iCSC0_d3D_
1059
interface new
1060
module procedure new_
1061
module procedure new_data_
1062
end interface
1063
public :: new
1064
interface assignment(=)
1065
module procedure get_elem1_assign_
1066
module procedure get_elem2_assign_
1067
module procedure set_elem1_
1068
module procedure set_elem2_
1069
end interface
1070
interface element
1071
module procedure get_elem1_
1072
module procedure get_elem2_
1073
end interface
1074
interface set_element
1075
module procedure set_elem1_
1076
module procedure set_elem2_
1077
end interface
1078
interface element1
1079
module procedure get_elem1_
1080
end interface
1081
public :: element1
1082
interface set_element1
1083
module procedure set_elem1_
1084
end interface
1085
public :: set_element1
1086
interface element1_p
1087
module procedure get_elem1p_
1088
end interface
1089
public :: element1_p
1090
interface element2
1091
module procedure get_elem2_
1092
end interface
1093
public :: element2
1094
interface set_element2
1095
module procedure set_elem2_
1096
end interface
1097
public :: set_element2
1098
interface element2_p
1099
module procedure get_elem2p_
1100
end interface
1101
public :: element2_p
1102
public :: iCSC0_d3D
1103
private :: iCSC0_d3D_
1104
interface assignment(=)
1105
module procedure common_assign_
1106
end interface
1107
public :: assignment(=)
1108
private :: common_assign_
1109
interface initialize
1110
module procedure common_initialize_
1111
end interface
1112
public :: initialize
1113
private :: common_initialize_
1114
interface is_initialized
1115
module procedure common_is_initialized_
1116
end interface
1117
public :: is_initialized
1118
private :: common_is_initialized_
1119
interface initialized
1120
module procedure common_is_initialized_
1121
end interface
1122
public :: initialized
1123
interface is_initd
1124
module procedure common_is_initialized_
1125
end interface
1126
public :: is_initd
1127
interface is_same
1128
module procedure common_is_same_
1129
end interface
1130
public :: is_same
1131
private :: common_is_same_
1132
interface same
1133
module procedure common_is_same_
1134
end interface
1135
public :: same
1136
interface delete
1137
module procedure common_delete_
1138
end interface
1139
public :: delete
1140
private :: common_delete_
1141
interface nullify
1142
module procedure common_nullify_
1143
end interface
1144
public :: nullify
1145
private :: common_nullify_
1146
interface copy
1147
module procedure copy_
1148
end interface
1149
public :: copy
1150
private :: common_copy_
1151
interface print
1152
module procedure print_
1153
end interface
1154
public :: print
1155
interface read
1156
module procedure read_
1157
end interface
1158
public :: read
1159
interface write
1160
module procedure write_
1161
end interface
1162
public :: write
1163
interface references
1164
module procedure common_references_
1165
end interface
1166
public :: references
1167
private :: common_references_
1168
interface refs
1169
module procedure common_references_
1170
end interface
1171
public :: refs
1172
interface set_error
1173
module procedure common_set_error_is_
1174
module procedure common_set_error_ii_
1175
module procedure common_set_error_il_
1176
end interface
1177
public :: set_error
1178
private :: common_set_error_is_
1179
private :: common_set_error_ii_
1180
private :: common_set_error_il_
1181
interface error
1182
module procedure common_error_
1183
end interface
1184
public :: error
1185
private :: common_error_
1186
contains
1187
subroutine common_copy_(from, to)
1188
type(iCSC0_d3D), intent(in) :: from
1189
type(iCSC0_d3D), intent(inout) :: to
1190
call set_error(to, error(from))
1191
end subroutine common_copy_
1192
subroutine common_initialize_(this)
1193
type(iCSC0_d3D), intent(inout) :: this
1194
integer :: error
1195
call delete(this)
1196
allocate(this%D, stat=error)
1197
call set_error(this, error)
1198
if ( error /= 0 ) return
1199
this%D%refs_ = 1
1200
call common_tag_object_(this)
1201
end subroutine common_initialize_
1202
pure function common_is_initialized_(this) result(init)
1203
type(iCSC0_d3D), intent(in) :: this
1204
logical :: init
1205
init = associated(this%D)
1206
end function common_is_initialized_
1207
elemental function common_is_same_(lhs, rhs) result(same)
1208
type(iCSC0_d3D), intent(in) :: lhs, rhs
1209
logical :: same
1210
same = is_initd(lhs) .and. is_initd(rhs)
1211
if ( .not. same ) return
1212
same = associated(lhs%D, target=rhs%D)
1213
end function common_is_same_
1214
subroutine common_delete_(this)
1215
type(iCSC0_d3D), intent(inout) :: this
1216
integer :: error
1217
call set_error(this, 0)
1218
if (.not. is_initd(this) ) return
1219
this%D%refs_ = this%D%refs_ - 1
1220
if ( 0 == this%D%refs_ ) then
1221
call delete_(this)
1222
deallocate(this%D, stat=error)
1223
call set_error(this, error)
1224
end if
1225
nullify(this%D)
1226
end subroutine common_delete_
1227
elemental subroutine common_nullify_(this)
1228
type(iCSC0_d3D), intent(inout) :: this
1229
if (.not. is_initd(this) ) return
1230
nullify(this%D)
1231
end subroutine common_nullify_
1232
subroutine common_assign_(lhs, rhs)
1233
type(iCSC0_d3D), intent(inout) :: lhs
1234
type(iCSC0_d3D), intent(in) :: rhs
1235
call delete(lhs)
1236
if ( .not. is_initd(rhs) ) return
1237
lhs%D => rhs%D
1238
lhs%D%refs_ = rhs%D%refs_ + 1
1239
end subroutine common_assign_
1240
elemental function common_references_(this) result(refs)
1241
type(iCSC0_d3D), intent(in) :: this
1242
integer :: refs
1243
if ( is_initd(this) ) then
1244
refs = this%D%refs_
1245
else
1246
refs = 0
1247
end if
1248
end function common_references_
1249
elemental function common_error_(this) result(error)
1250
type(iCSC0_d3D), intent(in) :: this
1251
integer :: error
1252
if ( is_initd(this) ) then
1253
error = this%error_
1254
else
1255
error = 0
1256
end if
1257
end function common_error_
1258
elemental subroutine common_set_error_is_(this, error)
1259
type(iCSC0_d3D), intent(inout) :: this
1260
integer(is_), intent(in) :: error
1261
this%error_ = error
1262
end subroutine common_set_error_is_
1263
elemental subroutine common_set_error_ii_(this, error)
1264
type(iCSC0_d3D), intent(inout) :: this
1265
integer(ii_), intent(in) :: error
1266
this%error_ = error
1267
end subroutine common_set_error_ii_
1268
elemental subroutine common_set_error_il_(this, error)
1269
type(iCSC0_d3D), intent(inout) :: this
1270
integer(il_), intent(in) :: error
1271
this%error_ = error
1272
end subroutine common_set_error_il_
1273
elemental function common_id_(this) result(str)
1274
type(iCSC0_d3D), intent(in) :: this
1275
character(len=BUD_ID_LEn) :: str
1276
str = this%D%id_
1277
end function common_id_
1278
subroutine common_tag_object_(this)
1279
type(iCSC0_d3D), intent(inout) :: this
1280
end subroutine common_tag_object_
1281
subroutine delete_(this)
1282
type(iCSC0_d3D), intent(inout) :: this
1283
call set_error(this, 0)
1284
call delete(this%D%e1)
1285
if ( 0 /= error(this%D%e1) ) &
1286
call set_error(this, error(this%D%e1))
1287
call delete(this%D%e2)
1288
if ( 0 /= error(this%D%e2) ) &
1289
call set_error(this, error(this%D%e2))
1290
end subroutine delete_
1291
subroutine copy_(from, to)
1292
type(iCSC0_d3D), intent(in) :: from
1293
type(iCSC0_d3D), intent(inout) :: to
1294
call delete(to)
1295
if ( .not. is_initd(from) ) return
1296
call initialize(to)
1297
call common_copy_(from, to)
1298
call copy(from%D%e1, to%D%e1)
1299
call copy(from%D%e2, to%D%e2)
1300
end subroutine copy_
1301
subroutine new_data_(this, a, b &
1302
)
1303
type(iCSC0_d3D), intent(inout) :: this
1304
type(iSM_CSC0), intent(inout) :: a
1305
type(dArray3D), intent(inout) :: b
1306
call new(this)
1307
this%D%e1 = a
1308
this%D%e2 = b
1309
end subroutine new_data_
1310
subroutine new_(this)
1311
type(iCSC0_d3D), intent(inout) :: this
1312
call initialize(this)
1313
end subroutine new_
1314
subroutine get_elem1_(this, item)
1315
type(iCSC0_d3D), intent(in) :: this
1316
type(iSM_CSC0), intent(inout) :: item
1317
if ( .not. is_initd(this) ) then
1318
call delete(item)
1319
else
1320
item = this%D% e1
1321
end if
1322
end subroutine
1323
subroutine get_elem1_assign_(item, this)
1324
type(iSM_CSC0), intent(inout) :: item
1325
type(iCSC0_d3D), intent(in) :: this
1326
if ( .not. is_initd(this) ) then
1327
call delete(item)
1328
else
1329
item = this%D% e1
1330
end if
1331
end subroutine
1332
subroutine set_elem1_(this, item)
1333
type(iCSC0_d3D), intent(inout) :: this
1334
type(iSM_CSC0), intent(in) :: item
1335
if ( .not. is_initd(this) ) return
1336
this%D% e1 = item
1337
end subroutine
1338
function get_elem1p_(this) result(p)
1339
type(iCSC0_d3D), intent(inout) :: this
1340
type(iSM_CSC0), pointer :: p
1341
if ( .not. is_initd(this) ) then
1342
nullify(p)
1343
else
1344
p => this%D% e1
1345
end if
1346
end function
1347
subroutine get_elem2_(this, item)
1348
type(iCSC0_d3D), intent(in) :: this
1349
type(dArray3D), intent(inout) :: item
1350
if ( .not. is_initd(this) ) then
1351
call delete(item)
1352
else
1353
item = this%D% e2
1354
end if
1355
end subroutine
1356
subroutine get_elem2_assign_(item, this)
1357
type(dArray3D), intent(inout) :: item
1358
type(iCSC0_d3D), intent(in) :: this
1359
if ( .not. is_initd(this) ) then
1360
call delete(item)
1361
else
1362
item = this%D% e2
1363
end if
1364
end subroutine
1365
subroutine set_elem2_(this, item)
1366
type(iCSC0_d3D), intent(inout) :: this
1367
type(dArray3D), intent(in) :: item
1368
if ( .not. is_initd(this) ) return
1369
this%D% e2 = item
1370
end subroutine
1371
function get_elem2p_(this) result(p)
1372
type(iCSC0_d3D), intent(inout) :: this
1373
type(dArray3D), pointer :: p
1374
if ( .not. is_initd(this) ) then
1375
nullify(p)
1376
else
1377
p => this%D% e2
1378
end if
1379
end function
1380
subroutine print_(this, info, indent)
1381
type(iCSC0_d3D), intent(in) :: this
1382
character(len=*), intent(in), optional :: info
1383
integer, intent(in), optional :: indent
1384
integer :: lindent
1385
character(len=32) :: fmt
1386
character(len=256) :: name
1387
name = "iCSC0_d3D"
1388
if ( present(info) ) name = info
1389
lindent = 1
1390
if ( present(indent) ) lindent = indent
1391
write(fmt, '(a,i0,a)') '(t',lindent,',3a)'
1392
if ( .not. is_initd(this) ) then
1393
write(*,fmt) "<", trim(name), " not initialized>"
1394
return
1395
end if
1396
write(fmt, '(a,i0,a)') '(t',lindent,',3a)'
1397
lindent = lindent + 2 ! step indentation
1398
write(*,fmt) "<<", trim(name), " coll>"
1399
call print(this%D%e1, indent = lindent)
1400
call print(this%D%e2, indent = lindent)
1401
lindent = lindent - 2 ! go back to requested indentation
1402
write(fmt, '(a,i0,a)') '(t',lindent,',a,i0,a)'
1403
write(*,fmt) " <coll-refs: ", references(this), ">>"
1404
end subroutine print_
1405
function matrix_p_(this) result(p)
1406
type(iCSC0_d3D), intent(in) :: this
1407
real(rd_), pointer :: p (:,:,:)
1408
p => array_p(this%D%e2)
1409
end function matrix_p_
1410
function sparse_index_(this) result(idx)
1411
type(iCSC0_d3D), intent(in) :: this
1412
integer :: idx
1413
idx = this%D%sm_idx
1414
end function sparse_index_
1415
pure function dimensions_(this) result(d)
1416
type(iCSC0_d3D), intent(in) :: this
1417
integer :: d
1418
if ( is_initd(this) ) then
1419
d = 3
1420
else
1421
d = -1
1422
end if
1423
end function dimensions_
1424
recursive subroutine add_element_(this, ir, ic, val)
1425
type(iCSC0_d3D), intent(inout) :: this
1426
integer(ii_), intent(in) :: ir, ic
1427
real(rd_), intent(in) :: val
1428
type(iSM_CSC0) :: sm
1429
type(iCSC0_d3D) :: nthis
1430
integer(ii_) :: i, c, ix, nr, nc, npc
1431
real(rd_), pointer :: p (:,:,:)
1432
if ( .not. is_initd(this) ) return
1433
sm = this
1434
call add_element(sm, ir, ic, dry_run = .true.)
1435
if ( error(sm) /= 0 ) then
1436
call delete(sm)
1437
call set_error(this, -1)
1438
return
1439
end if
1440
call add_element(sm, ir, ic)
1441
i = index(sm, ir, ic)
1442
p => matrix_p(this)
1443
select case ( sparse_index(this) )
1444
case ( 1 )
1445
p(i,:,:) = val
1446
case ( 2 )
1447
p(:,i,:) = val
1448
case ( 3 )
1449
p(:,:,i) = val
1450
end select
1451
call delete(sm)
1452
end subroutine add_element_
1453
subroutine write_(f, this, only_array)
1454
use bud_File
1455
type( File ), intent(inout) :: f
1456
type(iCSC0_d3D), intent(inout) :: this
1457
logical, intent(in), optional :: only_array
1458
type(iSM_CSC0) :: sm
1459
type(dArray3D) :: arr
1460
logical :: lonly_array
1461
if ( .not. is_open(f) ) return
1462
if ( .not. is_initd(this) ) return
1463
lonly_array = .false.
1464
if ( present(only_array) ) lonly_array = only_array
1465
sm = this
1466
arr = this
1467
if ( .not. is_finalized(sm) ) then
1468
call delete(sm)
1469
call delete(arr)
1470
call set_error(this, -1)
1471
return
1472
end if
1473
if ( .not. lonly_array ) then
1474
call write(f, sm)
1475
end if
1476
call write(f, arr)
1477
call delete(sm)
1478
call delete(arr)
1479
end subroutine write_
1480
subroutine read_(f, this, sm)
1481
use bud_File
1482
type( File ), intent(inout) :: f
1483
type(iCSC0_d3D), intent(inout) :: this
1484
type(iSM_CSC0), intent(inout), optional :: sm
1485
type(iSM_CSC0) :: lsm
1486
type(dArray3D) :: arr
1487
if ( .not. is_open(f) ) return
1488
if ( present(sm) ) then
1489
lsm = sm
1490
else
1491
call read(f, lsm)
1492
end if
1493
call read(f, arr)
1494
call new(this, lsm, arr)
1495
call delete(lsm)
1496
end subroutine read_
1497
end module
1498
module bud_iCSC0_c3D
1499
use bud_iSM_CSC0
1500
use bud_cArray3D
1501
implicit none
1502
private
1503
integer, parameter :: rr_ = selected_real_kind(p=6) ! single (real*4)
1504
integer, parameter :: rd_ = selected_real_kind(p=15) ! double (real*8)
1505
integer, parameter :: is_ = selected_int_kind(4) ! short (integer*2)
1506
integer, parameter :: ii_ = selected_int_kind(9) ! int (integer*4)
1507
integer, parameter :: il_ = selected_int_kind(18) ! long (integer*8)
1508
integer, parameter, private :: BUD_ID_LEn = 36
1509
character(len=*), parameter, private :: &
1510
BUD_MOd = 'BUD_CC2(BUD_MOD,_)BUD_MOD_NAME'
1511
character(len=*), parameter, private :: &
1512
BUD_TYPe = "iCSC0_c3D"
1513
integer(ii_), parameter :: ONE = 1_ii_
1514
integer(ii_), parameter :: ZERO = 0_ii_
1515
interface matrix_p
1516
module procedure matrix_p_
1517
end interface
1518
public :: matrix_p
1519
interface sparse_matrix
1520
module procedure get_elem1_
1521
end interface
1522
public :: sparse_matrix
1523
interface sparse_matrix_p
1524
module procedure get_elem1p_
1525
end interface
1526
public :: sparse_matrix_p
1527
interface sparse_index
1528
module procedure sparse_index_
1529
end interface
1530
public :: sparse_index
1531
interface dimensions
1532
module procedure dimensions_
1533
end interface
1534
public :: dimensions
1535
interface array
1536
module procedure get_elem2_
1537
end interface
1538
public :: array
1539
interface array_p
1540
module procedure get_elem2p_
1541
end interface
1542
public :: array_p
1543
interface add_element
1544
module procedure add_element_
1545
end interface
1546
public :: add_element
1547
type iCSC0_c3D
1548
type(iCSC0_c3D_), pointer :: D => null()
1549
integer :: error_ = 0
1550
end type iCSC0_c3D
1551
type iCSC0_c3D_
1552
type(iSM_CSC0) :: e1
1553
type(cArray3D) :: e2
1554
integer :: sm_idx = 3
1555
integer :: refs_ = 0
1556
character(len=BUD_ID_LEN) :: id_ = "null_id"
1557
end type iCSC0_c3D_
1558
interface new
1559
module procedure new_
1560
module procedure new_data_
1561
end interface
1562
public :: new
1563
interface assignment(=)
1564
module procedure get_elem1_assign_
1565
module procedure get_elem2_assign_
1566
module procedure set_elem1_
1567
module procedure set_elem2_
1568
end interface
1569
interface element
1570
module procedure get_elem1_
1571
module procedure get_elem2_
1572
end interface
1573
interface set_element
1574
module procedure set_elem1_
1575
module procedure set_elem2_
1576
end interface
1577
interface element1
1578
module procedure get_elem1_
1579
end interface
1580
public :: element1
1581
interface set_element1
1582
module procedure set_elem1_
1583
end interface
1584
public :: set_element1
1585
interface element1_p
1586
module procedure get_elem1p_
1587
end interface
1588
public :: element1_p
1589
interface element2
1590
module procedure get_elem2_
1591
end interface
1592
public :: element2
1593
interface set_element2
1594
module procedure set_elem2_
1595
end interface
1596
public :: set_element2
1597
interface element2_p
1598
module procedure get_elem2p_
1599
end interface
1600
public :: element2_p
1601
public :: iCSC0_c3D
1602
private :: iCSC0_c3D_
1603
interface assignment(=)
1604
module procedure common_assign_
1605
end interface
1606
public :: assignment(=)
1607
private :: common_assign_
1608
interface initialize
1609
module procedure common_initialize_
1610
end interface
1611
public :: initialize
1612
private :: common_initialize_
1613
interface is_initialized
1614
module procedure common_is_initialized_
1615
end interface
1616
public :: is_initialized
1617
private :: common_is_initialized_
1618
interface initialized
1619
module procedure common_is_initialized_
1620
end interface
1621
public :: initialized
1622
interface is_initd
1623
module procedure common_is_initialized_
1624
end interface
1625
public :: is_initd
1626
interface is_same
1627
module procedure common_is_same_
1628
end interface
1629
public :: is_same
1630
private :: common_is_same_
1631
interface same
1632
module procedure common_is_same_
1633
end interface
1634
public :: same
1635
interface delete
1636
module procedure common_delete_
1637
end interface
1638
public :: delete
1639
private :: common_delete_
1640
interface nullify
1641
module procedure common_nullify_
1642
end interface
1643
public :: nullify
1644
private :: common_nullify_
1645
interface copy
1646
module procedure copy_
1647
end interface
1648
public :: copy
1649
private :: common_copy_
1650
interface print
1651
module procedure print_
1652
end interface
1653
public :: print
1654
interface read
1655
module procedure read_
1656
end interface
1657
public :: read
1658
interface write
1659
module procedure write_
1660
end interface
1661
public :: write
1662
interface references
1663
module procedure common_references_
1664
end interface
1665
public :: references
1666
private :: common_references_
1667
interface refs
1668
module procedure common_references_
1669
end interface
1670
public :: refs
1671
interface set_error
1672
module procedure common_set_error_is_
1673
module procedure common_set_error_ii_
1674
module procedure common_set_error_il_
1675
end interface
1676
public :: set_error
1677
private :: common_set_error_is_
1678
private :: common_set_error_ii_
1679
private :: common_set_error_il_
1680
interface error
1681
module procedure common_error_
1682
end interface
1683
public :: error
1684
private :: common_error_
1685
contains
1686
subroutine common_copy_(from, to)
1687
type(iCSC0_c3D), intent(in) :: from
1688
type(iCSC0_c3D), intent(inout) :: to
1689
call set_error(to, error(from))
1690
end subroutine common_copy_
1691
subroutine common_initialize_(this)
1692
type(iCSC0_c3D), intent(inout) :: this
1693
integer :: error
1694
call delete(this)
1695
allocate(this%D, stat=error)
1696
call set_error(this, error)
1697
if ( error /= 0 ) return
1698
this%D%refs_ = 1
1699
call common_tag_object_(this)
1700
end subroutine common_initialize_
1701
pure function common_is_initialized_(this) result(init)
1702
type(iCSC0_c3D), intent(in) :: this
1703
logical :: init
1704
init = associated(this%D)
1705
end function common_is_initialized_
1706
elemental function common_is_same_(lhs, rhs) result(same)
1707
type(iCSC0_c3D), intent(in) :: lhs, rhs
1708
logical :: same
1709
same = is_initd(lhs) .and. is_initd(rhs)
1710
if ( .not. same ) return
1711
same = associated(lhs%D, target=rhs%D)
1712
end function common_is_same_
1713
subroutine common_delete_(this)
1714
type(iCSC0_c3D), intent(inout) :: this
1715
integer :: error
1716
call set_error(this, 0)
1717
if (.not. is_initd(this) ) return
1718
this%D%refs_ = this%D%refs_ - 1
1719
if ( 0 == this%D%refs_ ) then
1720
call delete_(this)
1721
deallocate(this%D, stat=error)
1722
call set_error(this, error)
1723
end if
1724
nullify(this%D)
1725
end subroutine common_delete_
1726
elemental subroutine common_nullify_(this)
1727
type(iCSC0_c3D), intent(inout) :: this
1728
if (.not. is_initd(this) ) return
1729
nullify(this%D)
1730
end subroutine common_nullify_
1731
subroutine common_assign_(lhs, rhs)
1732
type(iCSC0_c3D), intent(inout) :: lhs
1733
type(iCSC0_c3D), intent(in) :: rhs
1734
call delete(lhs)
1735
if ( .not. is_initd(rhs) ) return
1736
lhs%D => rhs%D
1737
lhs%D%refs_ = rhs%D%refs_ + 1
1738
end subroutine common_assign_
1739
elemental function common_references_(this) result(refs)
1740
type(iCSC0_c3D), intent(in) :: this
1741
integer :: refs
1742
if ( is_initd(this) ) then
1743
refs = this%D%refs_
1744
else
1745
refs = 0
1746
end if
1747
end function common_references_
1748
elemental function common_error_(this) result(error)
1749
type(iCSC0_c3D), intent(in) :: this
1750
integer :: error
1751
if ( is_initd(this) ) then
1752
error = this%error_
1753
else
1754
error = 0
1755
end if
1756
end function common_error_
1757
elemental subroutine common_set_error_is_(this, error)
1758
type(iCSC0_c3D), intent(inout) :: this
1759
integer(is_), intent(in) :: error
1760
this%error_ = error
1761
end subroutine common_set_error_is_
1762
elemental subroutine common_set_error_ii_(this, error)
1763
type(iCSC0_c3D), intent(inout) :: this
1764
integer(ii_), intent(in) :: error
1765
this%error_ = error
1766
end subroutine common_set_error_ii_
1767
elemental subroutine common_set_error_il_(this, error)
1768
type(iCSC0_c3D), intent(inout) :: this
1769
integer(il_), intent(in) :: error
1770
this%error_ = error
1771
end subroutine common_set_error_il_
1772
elemental function common_id_(this) result(str)
1773
type(iCSC0_c3D), intent(in) :: this
1774
character(len=BUD_ID_LEn) :: str
1775
str = this%D%id_
1776
end function common_id_
1777
subroutine common_tag_object_(this)
1778
type(iCSC0_c3D), intent(inout) :: this
1779
end subroutine common_tag_object_
1780
subroutine delete_(this)
1781
type(iCSC0_c3D), intent(inout) :: this
1782
call set_error(this, 0)
1783
call delete(this%D%e1)
1784
if ( 0 /= error(this%D%e1) ) &
1785
call set_error(this, error(this%D%e1))
1786
call delete(this%D%e2)
1787
if ( 0 /= error(this%D%e2) ) &
1788
call set_error(this, error(this%D%e2))
1789
end subroutine delete_
1790
subroutine copy_(from, to)
1791
type(iCSC0_c3D), intent(in) :: from
1792
type(iCSC0_c3D), intent(inout) :: to
1793
call delete(to)
1794
if ( .not. is_initd(from) ) return
1795
call initialize(to)
1796
call common_copy_(from, to)
1797
call copy(from%D%e1, to%D%e1)
1798
call copy(from%D%e2, to%D%e2)
1799
end subroutine copy_
1800
subroutine new_data_(this, a, b &
1801
)
1802
type(iCSC0_c3D), intent(inout) :: this
1803
type(iSM_CSC0), intent(inout) :: a
1804
type(cArray3D), intent(inout) :: b
1805
call new(this)
1806
this%D%e1 = a
1807
this%D%e2 = b
1808
end subroutine new_data_
1809
subroutine new_(this)
1810
type(iCSC0_c3D), intent(inout) :: this
1811
call initialize(this)
1812
end subroutine new_
1813
subroutine get_elem1_(this, item)
1814
type(iCSC0_c3D), intent(in) :: this
1815
type(iSM_CSC0), intent(inout) :: item
1816
if ( .not. is_initd(this) ) then
1817
call delete(item)
1818
else
1819
item = this%D% e1
1820
end if
1821
end subroutine
1822
subroutine get_elem1_assign_(item, this)
1823
type(iSM_CSC0), intent(inout) :: item
1824
type(iCSC0_c3D), intent(in) :: this
1825
if ( .not. is_initd(this) ) then
1826
call delete(item)
1827
else
1828
item = this%D% e1
1829
end if
1830
end subroutine
1831
subroutine set_elem1_(this, item)
1832
type(iCSC0_c3D), intent(inout) :: this
1833
type(iSM_CSC0), intent(in) :: item
1834
if ( .not. is_initd(this) ) return
1835
this%D% e1 = item
1836
end subroutine
1837
function get_elem1p_(this) result(p)
1838
type(iCSC0_c3D), intent(inout) :: this
1839
type(iSM_CSC0), pointer :: p
1840
if ( .not. is_initd(this) ) then
1841
nullify(p)
1842
else
1843
p => this%D% e1
1844
end if
1845
end function
1846
subroutine get_elem2_(this, item)
1847
type(iCSC0_c3D), intent(in) :: this
1848
type(cArray3D), intent(inout) :: item
1849
if ( .not. is_initd(this) ) then
1850
call delete(item)
1851
else
1852
item = this%D% e2
1853
end if
1854
end subroutine
1855
subroutine get_elem2_assign_(item, this)
1856
type(cArray3D), intent(inout) :: item
1857
type(iCSC0_c3D), intent(in) :: this
1858
if ( .not. is_initd(this) ) then
1859
call delete(item)
1860
else
1861
item = this%D% e2
1862
end if
1863
end subroutine
1864
subroutine set_elem2_(this, item)
1865
type(iCSC0_c3D), intent(inout) :: this
1866
type(cArray3D), intent(in) :: item
1867
if ( .not. is_initd(this) ) return
1868
this%D% e2 = item
1869
end subroutine
1870
function get_elem2p_(this) result(p)
1871
type(iCSC0_c3D), intent(inout) :: this
1872
type(cArray3D), pointer :: p
1873
if ( .not. is_initd(this) ) then
1874
nullify(p)
1875
else
1876
p => this%D% e2
1877
end if
1878
end function
1879
subroutine print_(this, info, indent)
1880
type(iCSC0_c3D), intent(in) :: this
1881
character(len=*), intent(in), optional :: info
1882
integer, intent(in), optional :: indent
1883
integer :: lindent
1884
character(len=32) :: fmt
1885
character(len=256) :: name
1886
name = "iCSC0_c3D"
1887
if ( present(info) ) name = info
1888
lindent = 1
1889
if ( present(indent) ) lindent = indent
1890
write(fmt, '(a,i0,a)') '(t',lindent,',3a)'
1891
if ( .not. is_initd(this) ) then
1892
write(*,fmt) "<", trim(name), " not initialized>"
1893
return
1894
end if
1895
write(fmt, '(a,i0,a)') '(t',lindent,',3a)'
1896
lindent = lindent + 2 ! step indentation
1897
write(*,fmt) "<<", trim(name), " coll>"
1898
call print(this%D%e1, indent = lindent)
1899
call print(this%D%e2, indent = lindent)
1900
lindent = lindent - 2 ! go back to requested indentation
1901
write(fmt, '(a,i0,a)') '(t',lindent,',a,i0,a)'
1902
write(*,fmt) " <coll-refs: ", references(this), ">>"
1903
end subroutine print_
1904
function matrix_p_(this) result(p)
1905
type(iCSC0_c3D), intent(in) :: this
1906
complex(rr_), pointer :: p (:,:,:)
1907
p => array_p(this%D%e2)
1908
end function matrix_p_
1909
function sparse_index_(this) result(idx)
1910
type(iCSC0_c3D), intent(in) :: this
1911
integer :: idx
1912
idx = this%D%sm_idx
1913
end function sparse_index_
1914
pure function dimensions_(this) result(d)
1915
type(iCSC0_c3D), intent(in) :: this
1916
integer :: d
1917
if ( is_initd(this) ) then
1918
d = 3
1919
else
1920
d = -1
1921
end if
1922
end function dimensions_
1923
recursive subroutine add_element_(this, ir, ic, val)
1924
type(iCSC0_c3D), intent(inout) :: this
1925
integer(ii_), intent(in) :: ir, ic
1926
complex(rr_), intent(in) :: val
1927
type(iSM_CSC0) :: sm
1928
type(iCSC0_c3D) :: nthis
1929
integer(ii_) :: i, c, ix, nr, nc, npc
1930
complex(rr_), pointer :: p (:,:,:)
1931
if ( .not. is_initd(this) ) return
1932
sm = this
1933
call add_element(sm, ir, ic, dry_run = .true.)
1934
if ( error(sm) /= 0 ) then
1935
call delete(sm)
1936
call set_error(this, -1)
1937
return
1938
end if
1939
call add_element(sm, ir, ic)
1940
i = index(sm, ir, ic)
1941
p => matrix_p(this)
1942
select case ( sparse_index(this) )
1943
case ( 1 )
1944
p(i,:,:) = val
1945
case ( 2 )
1946
p(:,i,:) = val
1947
case ( 3 )
1948
p(:,:,i) = val
1949
end select
1950
call delete(sm)
1951
end subroutine add_element_
1952
subroutine write_(f, this, only_array)
1953
use bud_File
1954
type( File ), intent(inout) :: f
1955
type(iCSC0_c3D), intent(inout) :: this
1956
logical, intent(in), optional :: only_array
1957
type(iSM_CSC0) :: sm
1958
type(cArray3D) :: arr
1959
logical :: lonly_array
1960
if ( .not. is_open(f) ) return
1961
if ( .not. is_initd(this) ) return
1962
lonly_array = .false.
1963
if ( present(only_array) ) lonly_array = only_array
1964
sm = this
1965
arr = this
1966
if ( .not. is_finalized(sm) ) then
1967
call delete(sm)
1968
call delete(arr)
1969
call set_error(this, -1)
1970
return
1971
end if
1972
if ( .not. lonly_array ) then
1973
call write(f, sm)
1974
end if
1975
call write(f, arr)
1976
call delete(sm)
1977
call delete(arr)
1978
end subroutine write_
1979
subroutine read_(f, this, sm)
1980
use bud_File
1981
type( File ), intent(inout) :: f
1982
type(iCSC0_c3D), intent(inout) :: this
1983
type(iSM_CSC0), intent(inout), optional :: sm
1984
type(iSM_CSC0) :: lsm
1985
type(cArray3D) :: arr
1986
if ( .not. is_open(f) ) return
1987
if ( present(sm) ) then
1988
lsm = sm
1989
else
1990
call read(f, lsm)
1991
end if
1992
call read(f, arr)
1993
call new(this, lsm, arr)
1994
call delete(lsm)
1995
end subroutine read_
1996
end module
1997
module bud_iCSC0_z3D
1998
use bud_iSM_CSC0
1999
use bud_zArray3D
2000
implicit none
2001
private
2002
integer, parameter :: rr_ = selected_real_kind(p=6) ! single (real*4)
2003
integer, parameter :: rd_ = selected_real_kind(p=15) ! double (real*8)
2004
integer, parameter :: is_ = selected_int_kind(4) ! short (integer*2)
2005
integer, parameter :: ii_ = selected_int_kind(9) ! int (integer*4)
2006
integer, parameter :: il_ = selected_int_kind(18) ! long (integer*8)
2007
integer, parameter, private :: BUD_ID_LEn = 36
2008
character(len=*), parameter, private :: &
2009
BUD_MOd = 'BUD_CC2(BUD_MOD,_)BUD_MOD_NAME'
2010
character(len=*), parameter, private :: &
2011
BUD_TYPe = "iCSC0_z3D"
2012
integer(ii_), parameter :: ONE = 1_ii_
2013
integer(ii_), parameter :: ZERO = 0_ii_
2014
interface matrix_p
2015
module procedure matrix_p_
2016
end interface
2017
public :: matrix_p
2018
interface sparse_matrix
2019
module procedure get_elem1_
2020
end interface
2021
public :: sparse_matrix
2022
interface sparse_matrix_p
2023
module procedure get_elem1p_
2024
end interface
2025
public :: sparse_matrix_p
2026
interface sparse_index
2027
module procedure sparse_index_
2028
end interface
2029
public :: sparse_index
2030
interface dimensions
2031
module procedure dimensions_
2032
end interface
2033
public :: dimensions
2034
interface array
2035
module procedure get_elem2_
2036
end interface
2037
public :: array
2038
interface array_p
2039
module procedure get_elem2p_
2040
end interface
2041
public :: array_p
2042
interface add_element
2043
module procedure add_element_
2044
end interface
2045
public :: add_element
2046
type iCSC0_z3D
2047
type(iCSC0_z3D_), pointer :: D => null()
2048
integer :: error_ = 0
2049
end type iCSC0_z3D
2050
type iCSC0_z3D_
2051
type(iSM_CSC0) :: e1
2052
type(zArray3D) :: e2
2053
integer :: sm_idx = 3
2054
integer :: refs_ = 0
2055
character(len=BUD_ID_LEN) :: id_ = "null_id"
2056
end type iCSC0_z3D_
2057
interface new
2058
module procedure new_
2059
module procedure new_data_
2060
end interface
2061
public :: new
2062
interface assignment(=)
2063
module procedure get_elem1_assign_
2064
module procedure get_elem2_assign_
2065
module procedure set_elem1_
2066
module procedure set_elem2_
2067
end interface
2068
interface element
2069
module procedure get_elem1_
2070
module procedure get_elem2_
2071
end interface
2072
interface set_element
2073
module procedure set_elem1_
2074
module procedure set_elem2_
2075
end interface
2076
interface element1
2077
module procedure get_elem1_
2078
end interface
2079
public :: element1
2080
interface set_element1
2081
module procedure set_elem1_
2082
end interface
2083
public :: set_element1
2084
interface element1_p
2085
module procedure get_elem1p_
2086
end interface
2087
public :: element1_p
2088
interface element2
2089
module procedure get_elem2_
2090
end interface
2091
public :: element2
2092
interface set_element2
2093
module procedure set_elem2_
2094
end interface
2095
public :: set_element2
2096
interface element2_p
2097
module procedure get_elem2p_
2098
end interface
2099
public :: element2_p
2100
public :: iCSC0_z3D
2101
private :: iCSC0_z3D_
2102
interface assignment(=)
2103
module procedure common_assign_
2104
end interface
2105
public :: assignment(=)
2106
private :: common_assign_
2107
interface initialize
2108
module procedure common_initialize_
2109
end interface
2110
public :: initialize
2111
private :: common_initialize_
2112
interface is_initialized
2113
module procedure common_is_initialized_
2114
end interface
2115
public :: is_initialized
2116
private :: common_is_initialized_
2117
interface initialized
2118
module procedure common_is_initialized_
2119
end interface
2120
public :: initialized
2121
interface is_initd
2122
module procedure common_is_initialized_
2123
end interface
2124
public :: is_initd
2125
interface is_same
2126
module procedure common_is_same_
2127
end interface
2128
public :: is_same
2129
private :: common_is_same_
2130
interface same
2131
module procedure common_is_same_
2132
end interface
2133
public :: same
2134
interface delete
2135
module procedure common_delete_
2136
end interface
2137
public :: delete
2138
private :: common_delete_
2139
interface nullify
2140
module procedure common_nullify_
2141
end interface
2142
public :: nullify
2143
private :: common_nullify_
2144
interface copy
2145
module procedure copy_
2146
end interface
2147
public :: copy
2148
private :: common_copy_
2149
interface print
2150
module procedure print_
2151
end interface
2152
public :: print
2153
interface read
2154
module procedure read_
2155
end interface
2156
public :: read
2157
interface write
2158
module procedure write_
2159
end interface
2160
public :: write
2161
interface references
2162
module procedure common_references_
2163
end interface
2164
public :: references
2165
private :: common_references_
2166
interface refs
2167
module procedure common_references_
2168
end interface
2169
public :: refs
2170
interface set_error
2171
module procedure common_set_error_is_
2172
module procedure common_set_error_ii_
2173
module procedure common_set_error_il_
2174
end interface
2175
public :: set_error
2176
private :: common_set_error_is_
2177
private :: common_set_error_ii_
2178
private :: common_set_error_il_
2179
interface error
2180
module procedure common_error_
2181
end interface
2182
public :: error
2183
private :: common_error_
2184
contains
2185
subroutine common_copy_(from, to)
2186
type(iCSC0_z3D), intent(in) :: from
2187
type(iCSC0_z3D), intent(inout) :: to
2188
call set_error(to, error(from))
2189
end subroutine common_copy_
2190
subroutine common_initialize_(this)
2191
type(iCSC0_z3D), intent(inout) :: this
2192
integer :: error
2193
call delete(this)
2194
allocate(this%D, stat=error)
2195
call set_error(this, error)
2196
if ( error /= 0 ) return
2197
this%D%refs_ = 1
2198
call common_tag_object_(this)
2199
end subroutine common_initialize_
2200
pure function common_is_initialized_(this) result(init)
2201
type(iCSC0_z3D), intent(in) :: this
2202
logical :: init
2203
init = associated(this%D)
2204
end function common_is_initialized_
2205
elemental function common_is_same_(lhs, rhs) result(same)
2206
type(iCSC0_z3D), intent(in) :: lhs, rhs
2207
logical :: same
2208
same = is_initd(lhs) .and. is_initd(rhs)
2209
if ( .not. same ) return
2210
same = associated(lhs%D, target=rhs%D)
2211
end function common_is_same_
2212
subroutine common_delete_(this)
2213
type(iCSC0_z3D), intent(inout) :: this
2214
integer :: error
2215
call set_error(this, 0)
2216
if (.not. is_initd(this) ) return
2217
this%D%refs_ = this%D%refs_ - 1
2218
if ( 0 == this%D%refs_ ) then
2219
call delete_(this)
2220
deallocate(this%D, stat=error)
2221
call set_error(this, error)
2222
end if
2223
nullify(this%D)
2224
end subroutine common_delete_
2225
elemental subroutine common_nullify_(this)
2226
type(iCSC0_z3D), intent(inout) :: this
2227
if (.not. is_initd(this) ) return
2228
nullify(this%D)
2229
end subroutine common_nullify_
2230
subroutine common_assign_(lhs, rhs)
2231
type(iCSC0_z3D), intent(inout) :: lhs
2232
type(iCSC0_z3D), intent(in) :: rhs
2233
call delete(lhs)
2234
if ( .not. is_initd(rhs) ) return
2235
lhs%D => rhs%D
2236
lhs%D%refs_ = rhs%D%refs_ + 1
2237
end subroutine common_assign_
2238
elemental function common_references_(this) result(refs)
2239
type(iCSC0_z3D), intent(in) :: this
2240
integer :: refs
2241
if ( is_initd(this) ) then
2242
refs = this%D%refs_
2243
else
2244
refs = 0
2245
end if
2246
end function common_references_
2247
elemental function common_error_(this) result(error)
2248
type(iCSC0_z3D), intent(in) :: this
2249
integer :: error
2250
if ( is_initd(this) ) then
2251
error = this%error_
2252
else
2253
error = 0
2254
end if
2255
end function common_error_
2256
elemental subroutine common_set_error_is_(this, error)
2257
type(iCSC0_z3D), intent(inout) :: this
2258
integer(is_), intent(in) :: error
2259
this%error_ = error
2260
end subroutine common_set_error_is_
2261
elemental subroutine common_set_error_ii_(this, error)
2262
type(iCSC0_z3D), intent(inout) :: this
2263
integer(ii_), intent(in) :: error
2264
this%error_ = error
2265
end subroutine common_set_error_ii_
2266
elemental subroutine common_set_error_il_(this, error)
2267
type(iCSC0_z3D), intent(inout) :: this
2268
integer(il_), intent(in) :: error
2269
this%error_ = error
2270
end subroutine common_set_error_il_
2271
elemental function common_id_(this) result(str)
2272
type(iCSC0_z3D), intent(in) :: this
2273
character(len=BUD_ID_LEn) :: str
2274
str = this%D%id_
2275
end function common_id_
2276
subroutine common_tag_object_(this)
2277
type(iCSC0_z3D), intent(inout) :: this
2278
end subroutine common_tag_object_
2279
subroutine delete_(this)
2280
type(iCSC0_z3D), intent(inout) :: this
2281
call set_error(this, 0)
2282
call delete(this%D%e1)
2283
if ( 0 /= error(this%D%e1) ) &
2284
call set_error(this, error(this%D%e1))
2285
call delete(this%D%e2)
2286
if ( 0 /= error(this%D%e2) ) &
2287
call set_error(this, error(this%D%e2))
2288
end subroutine delete_
2289
subroutine copy_(from, to)
2290
type(iCSC0_z3D), intent(in) :: from
2291
type(iCSC0_z3D), intent(inout) :: to
2292
call delete(to)
2293
if ( .not. is_initd(from) ) return
2294
call initialize(to)
2295
call common_copy_(from, to)
2296
call copy(from%D%e1, to%D%e1)
2297
call copy(from%D%e2, to%D%e2)
2298
end subroutine copy_
2299
subroutine new_data_(this, a, b &
2300
)
2301
type(iCSC0_z3D), intent(inout) :: this
2302
type(iSM_CSC0), intent(inout) :: a
2303
type(zArray3D), intent(inout) :: b
2304
call new(this)
2305
this%D%e1 = a
2306
this%D%e2 = b
2307
end subroutine new_data_
2308
subroutine new_(this)
2309
type(iCSC0_z3D), intent(inout) :: this
2310
call initialize(this)
2311
end subroutine new_
2312
subroutine get_elem1_(this, item)
2313
type(iCSC0_z3D), intent(in) :: this
2314
type(iSM_CSC0), intent(inout) :: item
2315
if ( .not. is_initd(this) ) then
2316
call delete(item)
2317
else
2318
item = this%D% e1
2319
end if
2320
end subroutine
2321
subroutine get_elem1_assign_(item, this)
2322
type(iSM_CSC0), intent(inout) :: item
2323
type(iCSC0_z3D), intent(in) :: this
2324
if ( .not. is_initd(this) ) then
2325
call delete(item)
2326
else
2327
item = this%D% e1
2328
end if
2329
end subroutine
2330
subroutine set_elem1_(this, item)
2331
type(iCSC0_z3D), intent(inout) :: this
2332
type(iSM_CSC0), intent(in) :: item
2333
if ( .not. is_initd(this) ) return
2334
this%D% e1 = item
2335
end subroutine
2336
function get_elem1p_(this) result(p)
2337
type(iCSC0_z3D), intent(inout) :: this
2338
type(iSM_CSC0), pointer :: p
2339
if ( .not. is_initd(this) ) then
2340
nullify(p)
2341
else
2342
p => this%D% e1
2343
end if
2344
end function
2345
subroutine get_elem2_(this, item)
2346
type(iCSC0_z3D), intent(in) :: this
2347
type(zArray3D), intent(inout) :: item
2348
if ( .not. is_initd(this) ) then
2349
call delete(item)
2350
else
2351
item = this%D% e2
2352
end if
2353
end subroutine
2354
subroutine get_elem2_assign_(item, this)
2355
type(zArray3D), intent(inout) :: item
2356
type(iCSC0_z3D), intent(in) :: this
2357
if ( .not. is_initd(this) ) then
2358
call delete(item)
2359
else
2360
item = this%D% e2
2361
end if
2362
end subroutine
2363
subroutine set_elem2_(this, item)
2364
type(iCSC0_z3D), intent(inout) :: this
2365
type(zArray3D), intent(in) :: item
2366
if ( .not. is_initd(this) ) return
2367
this%D% e2 = item
2368
end subroutine
2369
function get_elem2p_(this) result(p)
2370
type(iCSC0_z3D), intent(inout) :: this
2371
type(zArray3D), pointer :: p
2372
if ( .not. is_initd(this) ) then
2373
nullify(p)
2374
else
2375
p => this%D% e2
2376
end if
2377
end function
2378
subroutine print_(this, info, indent)
2379
type(iCSC0_z3D), intent(in) :: this
2380
character(len=*), intent(in), optional :: info
2381
integer, intent(in), optional :: indent
2382
integer :: lindent
2383
character(len=32) :: fmt
2384
character(len=256) :: name
2385
name = "iCSC0_z3D"
2386
if ( present(info) ) name = info
2387
lindent = 1
2388
if ( present(indent) ) lindent = indent
2389
write(fmt, '(a,i0,a)') '(t',lindent,',3a)'
2390
if ( .not. is_initd(this) ) then
2391
write(*,fmt) "<", trim(name), " not initialized>"
2392
return
2393
end if
2394
write(fmt, '(a,i0,a)') '(t',lindent,',3a)'
2395
lindent = lindent + 2 ! step indentation
2396
write(*,fmt) "<<", trim(name), " coll>"
2397
call print(this%D%e1, indent = lindent)
2398
call print(this%D%e2, indent = lindent)
2399
lindent = lindent - 2 ! go back to requested indentation
2400
write(fmt, '(a,i0,a)') '(t',lindent,',a,i0,a)'
2401
write(*,fmt) " <coll-refs: ", references(this), ">>"
2402
end subroutine print_
2403
function matrix_p_(this) result(p)
2404
type(iCSC0_z3D), intent(in) :: this
2405
complex(rd_), pointer :: p (:,:,:)
2406
p => array_p(this%D%e2)
2407
end function matrix_p_
2408
function sparse_index_(this) result(idx)
2409
type(iCSC0_z3D), intent(in) :: this
2410
integer :: idx
2411
idx = this%D%sm_idx
2412
end function sparse_index_
2413
pure function dimensions_(this) result(d)
2414
type(iCSC0_z3D), intent(in) :: this
2415
integer :: d
2416
if ( is_initd(this) ) then
2417
d = 3
2418
else
2419
d = -1
2420
end if
2421
end function dimensions_
2422
recursive subroutine add_element_(this, ir, ic, val)
2423
type(iCSC0_z3D), intent(inout) :: this
2424
integer(ii_), intent(in) :: ir, ic
2425
complex(rd_), intent(in) :: val
2426
type(iSM_CSC0) :: sm
2427
type(iCSC0_z3D) :: nthis
2428
integer(ii_) :: i, c, ix, nr, nc, npc
2429
complex(rd_), pointer :: p (:,:,:)
2430
if ( .not. is_initd(this) ) return
2431
sm = this
2432
call add_element(sm, ir, ic, dry_run = .true.)
2433
if ( error(sm) /= 0 ) then
2434
call delete(sm)
2435
call set_error(this, -1)
2436
return
2437
end if
2438
call add_element(sm, ir, ic)
2439
i = index(sm, ir, ic)
2440
p => matrix_p(this)
2441
select case ( sparse_index(this) )
2442
case ( 1 )
2443
p(i,:,:) = val
2444
case ( 2 )
2445
p(:,i,:) = val
2446
case ( 3 )
2447
p(:,:,i) = val
2448
end select
2449
call delete(sm)
2450
end subroutine add_element_
2451
subroutine write_(f, this, only_array)
2452
use bud_File
2453
type( File ), intent(inout) :: f
2454
type(iCSC0_z3D), intent(inout) :: this
2455
logical, intent(in), optional :: only_array
2456
type(iSM_CSC0) :: sm
2457
type(zArray3D) :: arr
2458
logical :: lonly_array
2459
if ( .not. is_open(f) ) return
2460
if ( .not. is_initd(this) ) return
2461
lonly_array = .false.
2462
if ( present(only_array) ) lonly_array = only_array
2463
sm = this
2464
arr = this
2465
if ( .not. is_finalized(sm) ) then
2466
call delete(sm)
2467
call delete(arr)
2468
call set_error(this, -1)
2469
return
2470
end if
2471
if ( .not. lonly_array ) then
2472
call write(f, sm)
2473
end if
2474
call write(f, arr)
2475
call delete(sm)
2476
call delete(arr)
2477
end subroutine write_
2478
subroutine read_(f, this, sm)
2479
use bud_File
2480
type( File ), intent(inout) :: f
2481
type(iCSC0_z3D), intent(inout) :: this
2482
type(iSM_CSC0), intent(inout), optional :: sm
2483
type(iSM_CSC0) :: lsm
2484
type(zArray3D) :: arr
2485
if ( .not. is_open(f) ) return
2486
if ( present(sm) ) then
2487
lsm = sm
2488
else
2489
call read(f, lsm)
2490
end if
2491
call read(f, arr)
2492
call new(this, lsm, arr)
2493
call delete(lsm)
2494
end subroutine read_
2495
end module
2496
module bud_CSC0_3D
2497
use bud_iCSC0_b3D
2498
use bud_iCSC0_r3D
2499
use bud_iCSC0_d3D
2500
use bud_iCSC0_c3D
2501
use bud_iCSC0_z3D
2502
end module
Loggerhead is a web-based interface for Breezy
Version: 2.0.1