summaryrefslogtreecommitdiff
path: root/gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03
blob: 036c20092d57876d6749e7dd752e7fe1ce98ee8a (plain)
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" } }