1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
|
! { dg-do compile }
!
! PR fortran/45125
!
! Contributed by Salvatore Filippone and Dominique d'Humieres.
!
module const_mod
! This is the default integer
integer, parameter :: ndig=8
integer, parameter :: int_k_ = selected_int_kind(ndig)
! This is an 8-byte integer, and normally different from default integer.
integer, parameter :: longndig=12
integer, parameter :: long_int_k_ = selected_int_kind(longndig)
!
! These must be the kind parameter corresponding to MPI_DOUBLE_PRECISION
! and MPI_REAL
!
integer, parameter :: dpk_ = kind(1.d0)
integer, parameter :: spk_ = kind(1.e0)
integer, save :: sizeof_dp, sizeof_sp
integer, save :: sizeof_int, sizeof_long_int
integer, save :: mpi_integer
integer, parameter :: invalid_ = -1
integer, parameter :: spmat_null_=0, spmat_bld_=1
integer, parameter :: spmat_asb_=2, spmat_upd_=4
!
!
! Error constants
integer, parameter, public :: success_=0
integer, parameter, public :: err_iarg_neg_=10
end module const_mod
module base_mat_mod
use const_mod
type :: base_sparse_mat
integer, private :: m, n
integer, private :: state, duplicate
logical, private :: triangle, unitd, upper, sorted
contains
procedure, pass(a) :: get_fmt => base_get_fmt
procedure, pass(a) :: set_null => base_set_null
procedure, pass(a) :: allocate_mnnz => base_allocate_mnnz
generic, public :: allocate => allocate_mnnz
end type base_sparse_mat
interface
subroutine base_allocate_mnnz(m,n,a,nz)
import base_sparse_mat, long_int_k_
integer, intent(in) :: m,n
class(base_sparse_mat), intent(inout) :: a
integer, intent(in), optional :: nz
end subroutine base_allocate_mnnz
end interface
contains
function base_get_fmt(a) result(res)
implicit none
class(base_sparse_mat), intent(in) :: a
character(len=5) :: res
res = 'NULL'
end function base_get_fmt
subroutine base_set_null(a)
implicit none
class(base_sparse_mat), intent(inout) :: a
a%state = spmat_null_
end subroutine base_set_null
end module base_mat_mod
module d_base_mat_mod
use base_mat_mod
type, extends(base_sparse_mat) :: d_base_sparse_mat
contains
end type d_base_sparse_mat
type, extends(d_base_sparse_mat) :: d_coo_sparse_mat
integer :: nnz
integer, allocatable :: ia(:), ja(:)
real(dpk_), allocatable :: val(:)
contains
procedure, pass(a) :: get_fmt => d_coo_get_fmt
procedure, pass(a) :: allocate_mnnz => d_coo_allocate_mnnz
end type d_coo_sparse_mat
interface
subroutine d_coo_allocate_mnnz(m,n,a,nz)
import d_coo_sparse_mat
integer, intent(in) :: m,n
class(d_coo_sparse_mat), intent(inout) :: a
integer, intent(in), optional :: nz
end subroutine d_coo_allocate_mnnz
end interface
contains
function d_coo_get_fmt(a) result(res)
implicit none
class(d_coo_sparse_mat), intent(in) :: a
character(len=5) :: res
res = 'COO'
end function d_coo_get_fmt
end module d_base_mat_mod
subroutine base_allocate_mnnz(m,n,a,nz)
use base_mat_mod, protect_name => base_allocate_mnnz
implicit none
integer, intent(in) :: m,n
class(base_sparse_mat), intent(inout) :: a
integer, intent(in), optional :: nz
Integer :: err_act
character(len=20) :: name='allocate_mnz', errfmt
logical, parameter :: debug=.false.
! This is the base version. If we get here
! it means the derived class is incomplete,
! so we throw an error.
errfmt=a%get_fmt()
write(0,*) 'Error: Missing ovverriding impl for allocate in class ',errfmt
return
end subroutine base_allocate_mnnz
subroutine d_coo_allocate_mnnz(m,n,a,nz)
use d_base_mat_mod, protect_name => d_coo_allocate_mnnz
implicit none
integer, intent(in) :: m,n
class(d_coo_sparse_mat), intent(inout) :: a
integer, intent(in), optional :: nz
Integer :: err_act, info, nz_
character(len=20) :: name='allocate_mnz'
logical, parameter :: debug=.false.
info = success_
if (m < 0) then
info = err_iarg_neg_
endif
if (n < 0) then
info = err_iarg_neg_
endif
if (present(nz)) then
nz_ = nz
else
nz_ = max(7*m,7*n,1)
end if
if (nz_ < 0) then
info = err_iarg_neg_
endif
! !$ if (info == success_) call realloc(nz_,a%ia,info)
! !$ if (info == success_) call realloc(nz_,a%ja,info)
! !$ if (info == success_) call realloc(nz_,a%val,info)
if (info == success_) then
! !$ call a%set_nrows(m)
! !$ call a%set_ncols(n)
! !$ call a%set_nzeros(0)
! !$ call a%set_bld()
! !$ call a%set_triangle(.false.)
! !$ call a%set_unit(.false.)
! !$ call a%set_dupl(dupl_def_)
write(0,*) 'Allocated COO succesfully, should now set components'
else
write(0,*) 'COO allocation failed somehow. Go figure'
end if
return
end subroutine d_coo_allocate_mnnz
program d_coo_err
use d_base_mat_mod
implicit none
integer :: ictxt, iam, np
! solver parameters
type(d_coo_sparse_mat) :: acoo
! other variables
integer nnz, n
n = 32
nnz = n*9
call acoo%set_null()
call acoo%allocate(n,n,nz=nnz)
stop
end program d_coo_err
|
