gcc/testsuite/gfortran.dg/coindexed_1.f90

   1 ! { dg-do run }
   2 ! { dg-options "-fcoarray=lib -lcaf_single" }
   3 ! { dg-additional-options "-latomic" { target libatomic_available } }
   4 !
   5 ! Contributed by Reinhold Bader
   6 !
   7
   8 program pmup
   9   implicit none
  10   type t
  11     integer :: b, a
  12   end type t
  13
  14   CLASS(*), allocatable :: a(:)[:]
  15   integer :: ii
  16
  17   !! --- ONE ---
  18   allocate(real :: a(3)[*])
  19   IF (this_image() == num_images()) THEN
  20     SELECT TYPE (a)
  21       TYPE IS (real)
  22       a(:)[1] = 2.0
  23     END SELECT
  24   END IF
  25   SYNC ALL
  26
  27   IF (this_image() == 1) THEN
  28     SELECT TYPE (a)
  29       TYPE IS (real)
  30         IF (ALL(A(:)[1] == 2.0)) THEN
  31           !WRITE(*,*) 'OK'
  32         ELSE
  33           WRITE(*,*) 'FAIL'
  34           STOP 1
  35         END IF
  36       TYPE IS (t)
  37         ii = a(1)[1]%a
  38         STOP 2
  39       CLASS IS (t)
  40         ii = a(1)[1]%a
  41         STOP 3
  42     END SELECT
  43   END IF
  44
  45   !! --- TWO ---
  46   deallocate(a)
  47   allocate(t :: a(3)[*])
  48   IF (this_image() == num_images()) THEN
  49     SELECT TYPE (a)
  50       TYPE IS (t)
  51       a(:)[1]%a = 4.0
  52     END SELECT
  53   END IF
  54   SYNC ALL
  55
  56   IF (this_image() == 1) THEN
  57     SELECT TYPE (a)
  58    TYPE IS (real)
  59       ii = a(1)[1]
  60       STOP 4
  61     TYPE IS (t)
  62       IF (ALL(A(:)[1]%a == 4.0)) THEN
  63         !WRITE(*,*) 'OK'
  64       ELSE
  65         WRITE(*,*) 'FAIL'
  66         STOP 5
  67       END IF
  68     CLASS IS (t)
  69       ii = a(1)[1]%a
  70       STOP 6
  71     END SELECT
  72   END IF
  73 end program