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