view gcc/testsuite/gfortran.dg/coindexed_1.f90 @ 120:f93fa5091070

fix conv1.c
author mir3636
date Thu, 08 Mar 2018 14:53:42 +0900
parents 04ced10e8804
children 84e7813d76e9
line wrap: on
line source

! { dg-do run }
! { dg-options "-fcoarray=lib -lcaf_single" }
! { dg-additional-options "-latomic" { target libatomic_available } }
!
! Contributed by Reinhold Bader
!

program pmup
  implicit none
  type t
    integer :: b, a
  end type t

  CLASS(*), allocatable :: a(:)[:]
  integer :: ii

  !! --- ONE --- 
  allocate(real :: a(3)[*])
  IF (this_image() == num_images()) THEN
    SELECT TYPE (a)
      TYPE IS (real)
      a(:)[1] = 2.0
    END SELECT
  END IF
  SYNC ALL

  IF (this_image() == 1) THEN
    SELECT TYPE (a)
      TYPE IS (real)
        IF (ALL(A(:)[1] == 2.0)) THEN
          !WRITE(*,*) 'OK'
        ELSE
          WRITE(*,*) 'FAIL'
          call abort()
        END IF
      TYPE IS (t)
        ii = a(1)[1]%a
        call abort()
      CLASS IS (t)
        ii = a(1)[1]%a
        call abort()
    END SELECT
  END IF

  !! --- TWO --- 
  deallocate(a)
  allocate(t :: a(3)[*])
  IF (this_image() == num_images()) THEN
    SELECT TYPE (a)
      TYPE IS (t)
      a(:)[1]%a = 4.0
    END SELECT
  END IF
  SYNC ALL

  IF (this_image() == 1) THEN
    SELECT TYPE (a)
   TYPE IS (real)
      ii = a(1)[1]
      call abort()
    TYPE IS (t)
      IF (ALL(A(:)[1]%a == 4.0)) THEN
        !WRITE(*,*) 'OK'
      ELSE
        WRITE(*,*) 'FAIL'
        call abort()
      END IF
    CLASS IS (t)
      ii = a(1)[1]%a
      call abort()
    END SELECT
  END IF
end program