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