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