gcc/testsuite/gfortran.dg/class_allocate_12.f90

   1 ! { dg-do run }
   2 !
   3 ! PR fortran/51972
   4 !
   5 ! Contributed by Damian Rouson
   6 !
   7 module surrogate_module
   8   type ,abstract :: surrogate
   9   end type
  10 end module
  11
  12 module strategy_module
  13   use surrogate_module
  14
  15   type :: strategy
  16   end type
  17 end module
  18
  19 module integrand_module
  20   use surrogate_module
  21   use strategy_module
  22   implicit none
  23
  24   type ,abstract, extends(surrogate) :: integrand
  25     class(strategy), allocatable :: quadrature
  26   end type
  27 end module integrand_module
  28
  29 module lorenz_module
  30   use strategy_module
  31   use integrand_module
  32   implicit none
  33
  34   type ,extends(integrand) :: lorenz
  35     real, dimension(:), allocatable :: state
  36   contains
  37     procedure ,public :: assign   => assign_lorenz
  38   end type
  39 contains
  40   type(lorenz) function constructor(initial_state, this_strategy)
  41     real ,dimension(:) ,intent(in)  :: initial_state
  42     class(strategy)    ,intent(in)  :: this_strategy
  43     constructor%state=initial_state
  44     allocate (constructor%quadrature, source=this_strategy)
  45   end function
  46
  47   subroutine assign_lorenz(lhs,rhs)
  48     class(lorenz)    ,intent(inout) :: lhs
  49     class(integrand) ,intent(in)    :: rhs
  50     select type(rhs)
  51       class is (lorenz)
  52         allocate (lhs%quadrature, source=rhs%quadrature)
  53         lhs%state=rhs%state
  54     end select
  55   end subroutine
  56 end module lorenz_module
  57
  58 module runge_kutta_2nd_module
  59   use surrogate_module,only : surrogate
  60   use strategy_module ,only : strategy
  61   use integrand_module,only : integrand
  62   implicit none
  63
  64   type, extends(strategy) ,public :: runge_kutta_2nd
  65   contains
  66     procedure, nopass :: integrate
  67   end type
  68 contains
  69   subroutine integrate(this)
  70     class(surrogate) ,intent(inout) :: this
  71     class(integrand) ,allocatable   :: this_half
  72
  73     select type (this)
  74       class is (integrand)
  75         allocate (this_half, source=this)
  76     end select
  77   end subroutine
  78 end module
  79
  80 program main
  81   use lorenz_module
  82   use runge_kutta_2nd_module ,only : runge_kutta_2nd, integrate
  83   implicit none
  84
  85   type(runge_kutta_2nd) :: timed_lorenz_integrator
  86   type(lorenz)          :: attractor
  87
  88   attractor = constructor( [1., 1., 1.] , timed_lorenz_integrator)
  89   call integrate(attractor)
  90 end program main