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 !
   6 ! Coarray intrinsics
   7 !
   8
   9 subroutine image_idx_test1()
  10   INTEGER,save :: array[2,-1:4,8,*]
  11   WRITE (*,*) IMAGE_INDEX (array, [2,0,3,1])
  12   if (IMAGE_INDEX (array, [1,-1,1,1]) /= 1) call not_existing()
  13   if (IMAGE_INDEX (array, [2,-1,1,1]) /= 0) call not_existing()
  14   if (IMAGE_INDEX (array, [1,-1,1,2]) /= 0) call not_existing()
  15 end subroutine
  16
  17 subroutine this_image_check()
  18   integer,save :: a(1,2,3,5)[0:3,*]
  19   integer :: j
  20   if (this_image() /= 1) call not_existing()
  21   if (this_image(a,dim=1) /= 0) call not_existing()
  22   if (this_image(a,dim=2) /= 1) call not_existing()
  23 end subroutine this_image_check
  24
  25 subroutine othercheck()
  26 real,save :: a(5)[2,*]
  27 complex,save :: c[4:5,6,9:*]
  28 integer,save :: i, j[*]
  29 dimension :: b(3)
  30 codimension :: b[5:*]
  31 dimension :: h(9:10)
  32 codimension :: h[8:*]
  33 save :: b,h
  34 if (this_image() /= 1) call not_existing()
  35 if (num_images() /= 1) call not_existing()
  36 if(any(this_image(coarray=a) /= [ 1, 1 ])) call not_existing()
  37 if(any(this_image(c) /= [4,1,9])) call not_existing()
  38 if(this_image(c, dim=3) /= 9) call not_existing()
  39 if(ubound(b,dim=1) /= 3 .or. this_image(coarray=b,dim=1) /= 5) call not_existing()
  40 if(ubound(h,dim=1) /= 10 .or. this_image(h,dim=1) /= 8) call not_existing()
  41 end subroutine othercheck
  42
  43 subroutine andanother()
  44 integer,save :: a(1)[2:9,4,-3:5,0:*]
  45 print *, lcobound(a)
  46 print *, lcobound(a,dim=3,kind=8)
  47 print *, ucobound(a)
  48 print *, ucobound(a,dim=1,kind=2)
  49 if (any(lcobound(a) /= [2, 1, -3, 0])) call not_existing()
  50 if (any(ucobound(a) /= [9, 4,  5, 0])) call not_existing()
  51 if (lcobound(a,dim=3,kind=8) /= -3_8)  call not_existing()
  52 if (ucobound(a,dim=1,kind=2) /=  9_2)  call not_existing()
  53 end subroutine andanother
  54
  55 ! { dg-final { scan-tree-dump-times "not_existing" 0 "original" } }
  56 ! { dg-final { cleanup-tree-dump "original" } }