Mercurial > hg > CbC > CbC_gcc
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