OSDN Git Service

2012-01-27 Tobias Burnus <burnus@net-b.de>
[pf3gnuchains/gcc-fork.git] / 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" } }