OSDN Git Service

2010-04-28 Tobias Burnus <burnus@net-b.de>
[pf3gnuchains/gcc-fork.git] / gcc / testsuite / gfortran.dg / coarray_11.f90
1 ! { dg-do compile }
2 ! { dg-options "-fcoarray=single -fdump-tree-original" }
3 !
4 ! PR fortran/18918
5 ! PR fortran/43919 for boundsTest()
6 !
7 ! Coarray intrinsics
8 !
9
10 subroutine image_idx_test1()
11   INTEGER,save :: array[2,-1:4,8,*]
12   WRITE (*,*) IMAGE_INDEX (array, [2,0,3,1])
13   if (IMAGE_INDEX (array, [1,-1,1,1]) /= 1) call not_existing()
14   if (IMAGE_INDEX (array, [2,-1,1,1]) /= 0) call not_existing()
15   if (IMAGE_INDEX (array, [1,-1,1,2]) /= 0) call not_existing()
16 end subroutine
17
18 subroutine this_image_check()
19   integer,save :: a(1,2,3,5)[0:3,*]
20   integer :: j
21   if (this_image() /= 1) call not_existing()
22   if (this_image(a,dim=1) /= 0) call not_existing()
23   if (this_image(a,dim=2) /= 1) call not_existing()
24 end subroutine this_image_check
25
26 subroutine othercheck()
27 real,save :: a(5)[2,*]
28 complex,save :: c[4:5,6,9:*]
29 integer,save :: i, j[*]
30 dimension :: b(3)
31 codimension :: b[5:*]
32 dimension :: h(9:10)
33 codimension :: h[8:*]
34 save :: b,h
35 if (this_image() /= 1) call not_existing()
36 if (num_images() /= 1) call not_existing()
37 if(any(this_image(coarray=a) /= [ 1, 1 ])) call not_existing()
38 if(any(this_image(c) /= [4,1,9])) call not_existing()
39 if(this_image(c, dim=3) /= 9) call not_existing()
40 if(ubound(b,dim=1) /= 3 .or. this_image(coarray=b,dim=1) /= 5) call not_existing()
41 if(ubound(h,dim=1) /= 10 .or. this_image(h,dim=1) /= 8) call not_existing()
42 end subroutine othercheck
43
44 subroutine andanother()
45 integer,save :: a(1)[2:9,4,-3:5,0:*]
46 print *, lcobound(a)
47 print *, lcobound(a,dim=3,kind=8)
48 print *, ucobound(a)
49 print *, ucobound(a,dim=1,kind=2)
50 if (any(lcobound(a) /= [2, 1, -3, 0])) call not_existing()
51 if (any(ucobound(a) /= [9, 4,  5, 0])) call not_existing()
52 if (lcobound(a,dim=3,kind=8) /= -3_8)  call not_existing()
53 if (ucobound(a,dim=1,kind=2) /=  9_2)  call not_existing()
54 end subroutine andanother
55
56 subroutine boundsTest()
57   implicit none
58   integer :: a[*] = 7
59   if (any (lcobound(a) /= [1])) call not_existing()
60   if (any (ucobound(a) /= [1])) call not_existing()
61 end subroutine boundsTest
62
63 ! { dg-final { scan-tree-dump-times "not_existing" 0 "original" } }
64 ! { dg-final { cleanup-tree-dump "original" } }