summaryrefslogtreecommitdiff
path: root/gcc/testsuite/gfortran.dg/whole_file_27.f90
blob: 4129547273168988a67a082b1766b012256bcc8c (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
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
! { 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

! { dg-final { cleanup-modules "base_mat_mod const_mod d_base_mat_mod" } }