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
|
! { dg-do run }
! Tests the fix for PR4164656 in which the call to a%a%scal failed to compile.
!
! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
!
module const_mod
integer, parameter :: longndig=12
integer, parameter :: long_int_k_ = selected_int_kind(longndig)
integer, parameter :: dpk_ = kind(1.d0)
integer, parameter :: spk_ = kind(1.e0)
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_nzeros
end type base_sparse_mat
private :: get_nzeros
contains
function get_nzeros(a) result(res)
implicit none
class(base_sparse_mat), intent(in) :: a
integer :: res
integer :: err_act
character(len=20) :: name='base_get_nzeros'
logical, parameter :: debug=.false.
res = -1
end function get_nzeros
end module base_mat_mod
module s_base_mat_mod
use base_mat_mod
type, extends(base_sparse_mat) :: s_base_sparse_mat
contains
procedure, pass(a) :: s_scals
procedure, pass(a) :: s_scal
generic, public :: scal => s_scals, s_scal
end type s_base_sparse_mat
private :: s_scals, s_scal
type, extends(s_base_sparse_mat) :: s_coo_sparse_mat
integer :: nnz
integer, allocatable :: ia(:), ja(:)
real(spk_), allocatable :: val(:)
contains
procedure, pass(a) :: get_nzeros => s_coo_get_nzeros
procedure, pass(a) :: s_scals => s_coo_scals
procedure, pass(a) :: s_scal => s_coo_scal
end type s_coo_sparse_mat
private :: s_coo_scals, s_coo_scal, s_coo_get_nzeros
contains
subroutine s_scals(d,a,info)
implicit none
class(s_base_sparse_mat), intent(in) :: a
real(spk_), intent(in) :: d
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='s_scals'
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.
info = 700
end subroutine s_scals
subroutine s_scal(d,a,info)
implicit none
class(s_base_sparse_mat), intent(in) :: a
real(spk_), intent(in) :: d(:)
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='s_scal'
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.
info = 700
end subroutine s_scal
function s_coo_get_nzeros(a) result(res)
implicit none
class(s_coo_sparse_mat), intent(in) :: a
integer :: res
res = a%nnz
end function s_coo_get_nzeros
subroutine s_coo_scal(d,a,info)
use const_mod
implicit none
class(s_coo_sparse_mat), intent(inout) :: a
real(spk_), intent(in) :: d(:)
integer, intent(out) :: info
Integer :: err_act,mnm, i, j, m
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
info = 0
do i=1,a%get_nzeros()
j = a%ia(i)
a%val(i) = a%val(i) * d(j)
enddo
end subroutine s_coo_scal
subroutine s_coo_scals(d,a,info)
use const_mod
implicit none
class(s_coo_sparse_mat), intent(inout) :: a
real(spk_), intent(in) :: d
integer, intent(out) :: info
Integer :: err_act,mnm, i, j, m
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
info = 0
do i=1,a%get_nzeros()
a%val(i) = a%val(i) * d
enddo
end subroutine s_coo_scals
end module s_base_mat_mod
module s_mat_mod
use s_base_mat_mod
type :: s_sparse_mat
class(s_base_sparse_mat), pointer :: a
contains
procedure, pass(a) :: s_scals
procedure, pass(a) :: s_scal
generic, public :: scal => s_scals, s_scal
end type s_sparse_mat
interface scal
module procedure s_scals, s_scal
end interface
contains
subroutine s_scal(d,a,info)
use const_mod
implicit none
class(s_sparse_mat), intent(inout) :: a
real(spk_), intent(in) :: d(:)
integer, intent(out) :: info
integer :: err_act
character(len=20) :: name='csnmi'
logical, parameter :: debug=.false.
print *, "s_scal"
call a%a%scal(d,info)
return
end subroutine s_scal
subroutine s_scals(d,a,info)
use const_mod
implicit none
class(s_sparse_mat), intent(inout) :: a
real(spk_), intent(in) :: d
integer, intent(out) :: info
integer :: err_act
character(len=20) :: name='csnmi'
logical, parameter :: debug=.false.
! print *, "s_scals"
info = 0
call a%a%scal(d,info)
return
end subroutine s_scals
end module s_mat_mod
use s_mat_mod
class (s_sparse_mat), pointer :: a
type (s_sparse_mat), target :: b
type (s_base_sparse_mat), target :: c
integer info
b%a => c
a => b
call a%scal (1.0_spk_, info)
if (info .ne. 700) call abort
end
! { dg-final { cleanup-modules "const_mod base_mat_mod s_base_mat_mod s_mat_mod" } }
|
