gcc/testsuite/gfortran.dg/dummy_procedure_7.f90

   1 ! { dg-do run }
   2 !
   3 ! PR fortran/52022
   4 !
   5
   6 module check
   7   integer, save :: icheck = 0
   8 end module check
   9
  10 module t
  11 implicit none
  12       contains
  13 subroutine  sol(cost)
  14    use check
  15    interface
  16         function cost(p) result(y)
  17                 double precision,dimension(:) :: p
  18                 double precision,dimension(:),allocatable :: y
  19         end function cost
  20    end interface
  21
  22    if (any (cost([1d0,2d0]) /= [2.d0, 4.d0])) call abort ()
  23    icheck = icheck + 1
  24 end subroutine
  25
  26 end module t
  27
  28 module tt
  29    procedure(cost1),pointer :: pcost
  30 contains
  31   subroutine init()
  32         pcost=>cost1
  33   end subroutine
  34
  35   function cost1(x) result(y)
  36         double precision,dimension(:) :: x
  37         double precision,dimension(:),allocatable :: y
  38         allocate(y(2))
  39         y=2d0*x
  40   end function cost1
  41
  42
  43
  44   function cost(x) result(y)
  45         double precision,dimension(:) :: x
  46         double precision,dimension(:),allocatable :: y
  47         allocate(y(2))
  48         y=pcost(x)
  49   end function cost
  50 end module
  51
  52 program test
  53         use tt
  54         use t
  55         use check
  56         implicit none
  57
  58         call init()
  59         if (any (cost([3.d0,7.d0]) /= [6.d0, 14.d0])) call abort ()
  60         if (icheck /= 0) call abort ()
  61         call sol(cost)
  62         if (icheck /= 1) call abort ()
  63 end program test
  64
  65 ! { dg-final { cleanup-modules "t tt check" } }