1! { dg-do run }
2! Tests the fix for PR4164656 in which the call to a%a%scal failed to compile.
3!
4! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
5!
6module const_mod
7  integer, parameter  :: longndig=12
8  integer, parameter  :: long_int_k_ = selected_int_kind(longndig)
9  integer, parameter  :: dpk_ = kind(1.d0)
10  integer, parameter  :: spk_ = kind(1.e0)
11end module const_mod
12
13module base_mat_mod  
14  use const_mod 
15  type  :: base_sparse_mat
16    integer, private     :: m, n
17    integer, private     :: state, duplicate 
18    logical, private     :: triangle, unitd, upper, sorted
19  contains 
20    procedure, pass(a) :: get_nzeros
21  end type base_sparse_mat
22  private ::  get_nzeros
23contains
24  function get_nzeros(a) result(res)
25    implicit none 
26    class(base_sparse_mat), intent(in) :: a
27    integer :: res
28    integer :: err_act
29    character(len=20)  :: name='base_get_nzeros'
30    logical, parameter :: debug=.false.
31    res = -1
32  end function get_nzeros
33end module base_mat_mod
34
35module s_base_mat_mod
36  use base_mat_mod
37  type, extends(base_sparse_mat) :: s_base_sparse_mat
38  contains
39    procedure, pass(a) :: s_scals
40    procedure, pass(a) :: s_scal
41    generic, public    :: scal => s_scals, s_scal 
42  end type s_base_sparse_mat
43  private :: s_scals, s_scal
44
45  type, extends(s_base_sparse_mat) :: s_coo_sparse_mat
46    
47    integer              :: nnz
48    integer, allocatable :: ia(:), ja(:)
49    real(spk_), allocatable :: val(:)
50  contains
51    procedure, pass(a) :: get_nzeros => s_coo_get_nzeros
52    procedure, pass(a) :: s_scals => s_coo_scals
53    procedure, pass(a) :: s_scal => s_coo_scal
54  end type s_coo_sparse_mat
55  private :: s_coo_scals, s_coo_scal, s_coo_get_nzeros
56contains 
57  subroutine s_scals(d,a,info) 
58    implicit none 
59    class(s_base_sparse_mat), intent(inout) :: a
60    real(spk_), intent(in)      :: d
61    integer, intent(out)            :: info
62
63    Integer :: err_act
64    character(len=20)  :: name='s_scals'
65    logical, parameter :: debug=.false.
66
67    ! This is the base version. If we get here
68    ! it means the derived class is incomplete,
69    ! so we throw an error.
70    info = 700
71  end subroutine s_scals
72
73
74  subroutine s_scal(d,a,info) 
75    implicit none 
76    class(s_base_sparse_mat), intent(inout) :: a
77    real(spk_), intent(in)      :: d(:)
78    integer, intent(out)            :: info
79
80    Integer :: err_act
81    character(len=20)  :: name='s_scal'
82    logical, parameter :: debug=.false.
83
84    ! This is the base version. If we get here
85    ! it means the derived class is incomplete,
86    ! so we throw an error.
87    info = 700
88  end subroutine s_scal
89
90  function s_coo_get_nzeros(a) result(res)
91    implicit none 
92    class(s_coo_sparse_mat), intent(in) :: a
93    integer :: res
94    res  = a%nnz
95  end function s_coo_get_nzeros
96
97
98  subroutine s_coo_scal(d,a,info) 
99    use const_mod
100    implicit none 
101    class(s_coo_sparse_mat), intent(inout) :: a
102    real(spk_), intent(in)      :: d(:)
103    integer, intent(out)            :: info
104
105    Integer :: err_act,mnm, i, j, m
106    character(len=20)  :: name='scal'
107    logical, parameter :: debug=.false.
108    info  = 0
109    do i=1,a%get_nzeros()
110      j        = a%ia(i)
111      a%val(i) = a%val(i) * d(j)
112    enddo
113  end subroutine s_coo_scal
114
115  subroutine s_coo_scals(d,a,info) 
116    use const_mod
117    implicit none 
118    class(s_coo_sparse_mat), intent(inout) :: a
119    real(spk_), intent(in)      :: d
120    integer, intent(out)            :: info
121
122    Integer :: err_act,mnm, i, j, m
123    character(len=20)  :: name='scal'
124    logical, parameter :: debug=.false.
125
126    info  = 0
127    do i=1,a%get_nzeros()
128      a%val(i) = a%val(i) * d
129    enddo
130  end subroutine s_coo_scals
131end module s_base_mat_mod
132
133module s_mat_mod
134  use s_base_mat_mod
135  type :: s_sparse_mat
136    class(s_base_sparse_mat), pointer  :: a
137  contains
138    procedure, pass(a) :: s_scals
139    procedure, pass(a) :: s_scal
140    generic, public    :: scal => s_scals, s_scal 
141  end type s_sparse_mat
142  interface scal
143    module procedure s_scals, s_scal
144  end interface
145contains 
146  subroutine s_scal(d,a,info)
147    use const_mod
148    implicit none 
149    class(s_sparse_mat), intent(inout) :: a
150    real(spk_), intent(in)              :: d(:)
151    integer, intent(out)                    :: info
152    integer :: err_act
153    character(len=20)  :: name='csnmi'
154    logical, parameter :: debug=.false.
155    print *, "s_scal"
156    call a%a%scal(d,info)
157    return
158  end subroutine s_scal
159
160  subroutine s_scals(d,a,info)
161    use const_mod
162    implicit none 
163    class(s_sparse_mat), intent(inout) :: a
164    real(spk_), intent(in)              :: d
165    integer, intent(out)                    :: info
166    integer :: err_act
167    character(len=20)  :: name='csnmi'
168    logical, parameter :: debug=.false.
169!    print *, "s_scals"
170    info = 0
171    call a%a%scal(d,info)
172    return
173  end subroutine s_scals
174end module s_mat_mod
175
176    use s_mat_mod
177    class (s_sparse_mat), pointer :: a
178    type (s_sparse_mat), target :: b
179    type (s_base_sparse_mat), target :: c
180    integer info
181    b%a => c
182    a => b
183    call a%scal (1.0_spk_, info)
184    if (info .ne. 700) call abort
185end
186