gcc/testsuite/gfortran.dg/whole_file_27.f90

   1 ! { dg-do compile }
   2 !
   3 ! PR fortran/45125
   4 !
   5 ! Contributed by Salvatore Filippone and Dominique d'Humieres.
   6 !
   7
   8 module const_mod
   9   ! This is the default integer
  10   integer, parameter  :: ndig=8
  11   integer, parameter  :: int_k_ = selected_int_kind(ndig)
  12   ! This is an 8-byte  integer, and normally different from default integer.
  13   integer, parameter  :: longndig=12
  14   integer, parameter  :: long_int_k_ = selected_int_kind(longndig)
  15   !
  16   ! These must be the kind parameter corresponding to MPI_DOUBLE_PRECISION
  17   ! and MPI_REAL
  18   !
  19   integer, parameter  :: dpk_ = kind(1.d0)
  20   integer, parameter  :: spk_ = kind(1.e0)
  21   integer, save       :: sizeof_dp, sizeof_sp
  22   integer, save       :: sizeof_int, sizeof_long_int
  23   integer, save       :: mpi_integer
  24
  25   integer, parameter :: invalid_ = -1
  26   integer, parameter :: spmat_null_=0, spmat_bld_=1
  27   integer, parameter :: spmat_asb_=2, spmat_upd_=4
  28
  29   !
  30   !
  31   !     Error constants
  32   integer, parameter, public :: success_=0
  33   integer, parameter, public :: err_iarg_neg_=10
  34 end module const_mod
  35 module base_mat_mod
  36
  37   use const_mod
  38
  39
  40   type  :: base_sparse_mat
  41     integer, private     :: m, n
  42     integer, private     :: state, duplicate
  43     logical, private     :: triangle, unitd, upper, sorted
  44   contains
  45
  46     procedure, pass(a) :: get_fmt => base_get_fmt
  47     procedure, pass(a) :: set_null => base_set_null
  48     procedure, pass(a) :: allocate_mnnz => base_allocate_mnnz
  49     generic,   public  :: allocate => allocate_mnnz
  50   end type base_sparse_mat
  51
  52   interface
  53     subroutine  base_allocate_mnnz(m,n,a,nz)
  54       import base_sparse_mat, long_int_k_
  55       integer, intent(in) :: m,n
  56       class(base_sparse_mat), intent(inout) :: a
  57       integer, intent(in), optional  :: nz
  58     end subroutine base_allocate_mnnz
  59   end interface
  60
  61 contains
  62
  63   function base_get_fmt(a) result(res)
  64     implicit none
  65     class(base_sparse_mat), intent(in) :: a
  66     character(len=5) :: res
  67     res = 'NULL'
  68   end function base_get_fmt
  69
  70   subroutine  base_set_null(a)
  71     implicit none
  72     class(base_sparse_mat), intent(inout) :: a
  73
  74     a%state = spmat_null_
  75   end subroutine base_set_null
  76
  77
  78 end module base_mat_mod
  79
  80 module d_base_mat_mod
  81
  82   use base_mat_mod
  83
  84   type, extends(base_sparse_mat) :: d_base_sparse_mat
  85   contains
  86   end type d_base_sparse_mat
  87
  88
  89
  90   type, extends(d_base_sparse_mat) :: d_coo_sparse_mat
  91
  92     integer              :: nnz
  93     integer, allocatable :: ia(:), ja(:)
  94     real(dpk_), allocatable :: val(:)
  95
  96   contains
  97
  98     procedure, pass(a) :: get_fmt      => d_coo_get_fmt
  99     procedure, pass(a) :: allocate_mnnz => d_coo_allocate_mnnz
 100
 101   end type d_coo_sparse_mat
 102
 103
 104   interface
 105     subroutine  d_coo_allocate_mnnz(m,n,a,nz)
 106       import d_coo_sparse_mat
 107       integer, intent(in) :: m,n
 108       class(d_coo_sparse_mat), intent(inout) :: a
 109       integer, intent(in), optional :: nz
 110     end subroutine d_coo_allocate_mnnz
 111   end interface
 112
 113 contains
 114
 115   function d_coo_get_fmt(a) result(res)
 116     implicit none
 117     class(d_coo_sparse_mat), intent(in) :: a
 118     character(len=5) :: res
 119     res = 'COO'
 120   end function d_coo_get_fmt
 121
 122 end module d_base_mat_mod
 123
 124 subroutine  base_allocate_mnnz(m,n,a,nz)
 125   use base_mat_mod, protect_name => base_allocate_mnnz
 126   implicit none
 127   integer, intent(in) :: m,n
 128   class(base_sparse_mat), intent(inout) :: a
 129   integer, intent(in), optional  :: nz
 130   Integer :: err_act
 131   character(len=20)  :: name='allocate_mnz', errfmt
 132   logical, parameter :: debug=.false.
 133
 134   ! This is the base version. If we get here
 135   ! it means the derived class is incomplete,
 136   ! so we throw an error.
 137   errfmt=a%get_fmt()
 138   write(0,*) 'Error: Missing ovverriding impl for allocate in class ',errfmt
 139
 140   return
 141
 142 end subroutine base_allocate_mnnz
 143
 144 subroutine  d_coo_allocate_mnnz(m,n,a,nz)
 145   use d_base_mat_mod, protect_name => d_coo_allocate_mnnz
 146   implicit none
 147   integer, intent(in) :: m,n
 148   class(d_coo_sparse_mat), intent(inout) :: a
 149   integer, intent(in), optional :: nz
 150   Integer :: err_act, info, nz_
 151   character(len=20)  :: name='allocate_mnz'
 152   logical, parameter :: debug=.false.
 153
 154   info = success_
 155   if (m < 0) then
 156     info = err_iarg_neg_
 157   endif
 158   if (n < 0) then
 159     info = err_iarg_neg_
 160   endif
 161   if (present(nz)) then
 162     nz_ = nz
 163   else
 164     nz_ = max(7*m,7*n,1)
 165   end if
 166   if (nz_ < 0) then
 167     info = err_iarg_neg_
 168   endif
 169 ! !$  if (info == success_) call realloc(nz_,a%ia,info)
 170 ! !$  if (info == success_) call realloc(nz_,a%ja,info)
 171 ! !$  if (info == success_) call realloc(nz_,a%val,info)
 172   if (info == success_) then
 173 ! !$    call a%set_nrows(m)
 174 ! !$    call a%set_ncols(n)
 175 ! !$    call a%set_nzeros(0)
 176 ! !$    call a%set_bld()
 177 ! !$    call a%set_triangle(.false.)
 178 ! !$    call a%set_unit(.false.)
 179 ! !$    call a%set_dupl(dupl_def_)
 180     write(0,*) 'Allocated COO succesfully, should now set components'
 181   else
 182     write(0,*) 'COO allocation failed somehow. Go figure'
 183   end if
 184   return
 185
 186 end subroutine d_coo_allocate_mnnz
 187
 188
 189 program d_coo_err
 190   use d_base_mat_mod
 191   implicit none
 192
 193   integer            :: ictxt, iam, np
 194
 195   ! solver parameters
 196   type(d_coo_sparse_mat) :: acoo
 197
 198   ! other variables
 199   integer nnz, n
 200
 201   n   = 32
 202   nnz = n*9
 203
 204   call acoo%set_null()
 205   call acoo%allocate(n,n,nz=nnz)
 206
 207   stop
 208 end program d_coo_err