cray_pointers_2.f90

来自「linux下编程用 编译软件」· F90 代码 · 共 2,707 行 · 第 1/5 页

! { dg-do run }
! { dg-options "-fcray-pointer" }
! Series of routines for testing a Cray pointer implementation
program craytest
  common /errors/errors(400)
  common /foo/foo ! To prevent optimizations
  integer foo
  integer i
  logical errors
  errors = .false.
  foo = 0
  call ptr1
  call ptr2
  call ptr3
  call ptr4
  call ptr5
  call ptr6
  call ptr7
  call ptr8
  call ptr9(9,10,11)
  call ptr10(9,10,11)
  call ptr11(9,10,11)
  call ptr12(9,10,11)
  call ptr13(9,10)
  call parmtest
! NOTE: Tests 1 through 12 were removed from this file
! and placed in loc_1.f90, so we start at 13
  do i=13,400
     if (errors(i)) then
!        print *,"Test",i,"failed."
        call abort()
     endif
  end do
  if (foo.eq.0) then
!     print *,"Test did not run correctly."
     call abort()
  endif
end program craytest

! ptr1 through ptr13 that Cray pointees are correctly used with
! a variety of declaration styles
subroutine ptr1
  common /errors/errors(400)
  logical :: errors, intne, realne, chne, ch8ne
  integer :: i,j,k
  integer, parameter :: n = 9
  integer, parameter :: m = 10
  integer, parameter :: o = 11
  integer itarg1 (n)
  integer itarg2 (m,n)
  integer itarg3 (o,m,n)
  real rtarg1(n)
  real rtarg2(m,n)
  real rtarg3(o,m,n)
  character chtarg1(n)
  character chtarg2(m,n)
  character chtarg3(o,m,n)
  character*8 ch8targ1(n)
  character*8 ch8targ2(m,n)
  character*8 ch8targ3(o,m,n)
  type drvd
     real r1
     integer i1
     integer i2(5)
  end type drvd
  type(drvd) dtarg1(n)
  type(drvd) dtarg2(m,n)
  type(drvd) dtarg3(o,m,n)

  type(drvd) dpte1(n)
  type(drvd) dpte2(m,n)
  type(drvd) dpte3(o,m,n)
  integer ipte1 (n)
  integer ipte2 (m,n)
  integer ipte3 (o,m,n)
  real rpte1(n)
  real rpte2(m,n)
  real rpte3(o,m,n)
  character chpte1(n)
  character chpte2(m,n)
  character chpte3(o,m,n)
  character*8 ch8pte1(n)
  character*8 ch8pte2(m,n)
  character*8 ch8pte3(o,m,n)

  pointer(iptr1,dpte1)
  pointer(iptr2,dpte2)
  pointer(iptr3,dpte3)
  pointer(iptr4,ipte1)
  pointer(iptr5,ipte2)
  pointer(iptr6,ipte3)
  pointer(iptr7,rpte1)
  pointer(iptr8,rpte2)
  pointer(iptr9,rpte3)
  pointer(iptr10,chpte1)
  pointer(iptr11,chpte2)
  pointer(iptr12,chpte3)
  pointer(iptr13,ch8pte1)
  pointer(iptr14,ch8pte2)
  pointer(iptr15,ch8pte3)

  iptr1 = loc(dtarg1)
  iptr2 = loc(dtarg2)
  iptr3 = loc(dtarg3)
  iptr4 = loc(itarg1)
  iptr5 = loc(itarg2)
  iptr6 = loc(itarg3)
  iptr7 = loc(rtarg1)
  iptr8 = loc(rtarg2)
  iptr9 = loc(rtarg3)
  iptr10= loc(chtarg1)
  iptr11= loc(chtarg2)
  iptr12= loc(chtarg3)
  iptr13= loc(ch8targ1)
  iptr14= loc(ch8targ2)
  iptr15= loc(ch8targ3)


  do, i=1,n
     dpte1(i)%i1=i
     if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then
        ! Error #13
        errors(13) = .true.
     endif

     dtarg1(i)%i1=2*dpte1(i)%i1
     if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then
        ! Error #14
        errors(14) = .true.
     endif

     ipte1(i) = i
     if (intne(ipte1(i), itarg1(i))) then
        ! Error #15
        errors(15) = .true.
     endif

     itarg1(i) = -ipte1(i)
     if (intne(ipte1(i), itarg1(i))) then
        ! Error #16
        errors(16) = .true.
     endif

     rpte1(i) = i * 5.0
     if (realne(rpte1(i), rtarg1(i))) then
        ! Error #17
        errors(17) = .true.
     endif

     rtarg1(i) = i * (-5.0)
     if (realne(rpte1(i), rtarg1(i))) then
        ! Error #18
        errors(18) = .true.
     endif

     chpte1(i) = 'a'
     if (chne(chpte1(i), chtarg1(i))) then
        ! Error #19
        errors(19) = .true.
     endif

     chtarg1(i) = 'z'
     if (chne(chpte1(i), chtarg1(i))) then
        ! Error #20
        errors(20) = .true.
     endif

     ch8pte1(i) = 'aaaaaaaa'
     if (ch8ne(ch8pte1(i), ch8targ1(i))) then
        ! Error #21
        errors(21) = .true.
     endif

     ch8targ1(i) = 'zzzzzzzz'
     if (ch8ne(ch8pte1(i), ch8targ1(i))) then
        ! Error #22
        errors(22) = .true.
     endif

     do, j=1,m
        dpte2(j,i)%r1=1.0
        if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then
           ! Error #23
           errors(23) = .true.
        endif

        dtarg2(j,i)%r1=2*dpte2(j,i)%r1
        if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then
           ! Error #24
           errors(24) = .true.
        endif

        ipte2(j,i) = i
        if (intne(ipte2(j,i), itarg2(j,i))) then
           ! Error #25
           errors(25) = .true.
        endif

        itarg2(j,i) = -ipte2(j,i)
        if (intne(ipte2(j,i), itarg2(j,i))) then
           ! Error #26
           errors(26) = .true.
        endif

        rpte2(j,i) = i * (-2.0)
        if (realne(rpte2(j,i), rtarg2(j,i))) then
           ! Error #27
           errors(27) = .true.
        endif

        rtarg2(j,i) = i * (-3.0)
        if (realne(rpte2(j,i), rtarg2(j,i))) then
           ! Error #28
           errors(28) = .true.
        endif

        chpte2(j,i) = 'a'
        if (chne(chpte2(j,i), chtarg2(j,i))) then
           ! Error #29
           errors(29) = .true.
        endif

        chtarg2(j,i) = 'z'
        if (chne(chpte2(j,i), chtarg2(j,i))) then
           ! Error #30
           errors(30) = .true.
        endif

        ch8pte2(j,i) = 'aaaaaaaa'
        if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then
           ! Error #31
           errors(31) = .true.
        endif

        ch8targ2(j,i) = 'zzzzzzzz'
        if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then
           ! Error #32
           errors(32) = .true.
        endif
        do k=1,o
           dpte3(k,j,i)%i2(1+mod(i,5))=i
           if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), &
                dtarg3(k,j,i)%i2(1+mod(i,5)))) then
              ! Error #33
              errors(33) = .true.
           endif

           dtarg3(k,j,i)%i2(1+mod(i,5))=2*dpte3(k,j,i)%i2(1+mod(i,5))
           if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), &
                dtarg3(k,j,i)%i2(1+mod(i,5)))) then
              ! Error #34
              errors(34) = .true.
           endif

           ipte3(k,j,i) = i
           if (intne(ipte3(k,j,i), itarg3(k,j,i))) then
              ! Error #35
              errors(35) = .true.
           endif

           itarg3(k,j,i) = -ipte3(k,j,i)
           if (intne(ipte3(k,j,i), itarg3(k,j,i))) then
              ! Error #36
              errors(36) = .true.
           endif

           rpte3(k,j,i) = i * 2.0
           if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then
              ! Error #37
              errors(37) = .true.
           endif

           rtarg3(k,j,i) = i * 3.0
           if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then
              ! Error #38
              errors(38) = .true.
           endif

           chpte3(k,j,i) = 'a'
           if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then
              ! Error #39
              errors(39) = .true.
           endif

           chtarg3(k,j,i) = 'z'
           if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then
              ! Error #40
              errors(40) = .true.
           endif

           ch8pte3(k,j,i) = 'aaaaaaaa'
           if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then
              ! Error #41
              errors(41) = .true.
           endif

           ch8targ3(k,j,i) = 'zzzzzzzz'
           if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then
              ! Error #42
              errors(42) = .true.
           endif
        end do
     end do
  end do

  rtarg3 = .5
  ! Vector syntax
  do, i=1,n
     ipte3 = i
     rpte3 = rpte3+1
     do, j=1,m
        do k=1,o
           if (intne(itarg3(k,j,i), i)) then
              ! Error #43
              errors(43) = .true.
           endif

           if (realne(rtarg3(k,j,i), i+.5)) then
              ! Error #44
              errors(44) = .true.
           endif
        end do
     end do
  end do

end subroutine ptr1


subroutine ptr2
  common /errors/errors(400)
  logical :: errors, intne, realne, chne, ch8ne
  integer :: i,j,k
  integer, parameter :: n = 9
  integer, parameter :: m = 10
  integer, parameter :: o = 11
  integer itarg1 (n)
  integer itarg2 (m,n)
  integer itarg3 (o,m,n)
  real rtarg1(n)
  real rtarg2(m,n)
  real rtarg3(o,m,n)
  character chtarg1(n)
  character chtarg2(m,n)
  character chtarg3(o,m,n)
  character*8 ch8targ1(n)
  character*8 ch8targ2(m,n)
  character*8 ch8targ3(o,m,n)
  type drvd
     real r1
     integer i1
     integer i2(5)
  end type drvd
  type(drvd) dtarg1(n)
  type(drvd) dtarg2(m,n)
  type(drvd) dtarg3(o,m,n)

  type(drvd) dpte1
  type(drvd) dpte2
  type(drvd) dpte3
  integer ipte1
  integer ipte2
  integer ipte3
  real rpte1
  real rpte2
  real rpte3
  character chpte1
  character chpte2
  character chpte3
  character*8 ch8pte1
  character*8 ch8pte2
  character*8 ch8pte3

  pointer(iptr1,dpte1(n))
  pointer(iptr2,dpte2(m,n))
  pointer(iptr3,dpte3(o,m,n))
  pointer(iptr4,ipte1(n))
  pointer(iptr5,ipte2 (m,n))
  pointer(iptr6,ipte3(o,m,n))
  pointer(iptr7,rpte1(n))
  pointer(iptr8,rpte2(m,n))
  pointer(iptr9,rpte3(o,m,n))
  pointer(iptr10,chpte1(n))
  pointer(iptr11,chpte2(m,n))
  pointer(iptr12,chpte3(o,m,n))
  pointer(iptr13,ch8pte1(n))
  pointer(iptr14,ch8pte2(m,n))
  pointer(iptr15,ch8pte3(o,m,n))

  iptr1 = loc(dtarg1)
  iptr2 = loc(dtarg2)
  iptr3 = loc(dtarg3)
  iptr4 = loc(itarg1)
  iptr5 = loc(itarg2)
  iptr6 = loc(itarg3)
  iptr7 = loc(rtarg1)
  iptr8 = loc(rtarg2)
  iptr9 = loc(rtarg3)
  iptr10= loc(chtarg1)
  iptr11= loc(chtarg2)
  iptr12= loc(chtarg3)
  iptr13= loc(ch8targ1)
  iptr14= loc(ch8targ2)
  iptr15= loc(ch8targ3)

  do, i=1,n
     dpte1(i)%i1=i
     if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then
        ! Error #45
        errors(45) = .true.
     endif

     dtarg1(i)%i1=2*dpte1(i)%i1
     if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then
        ! Error #46
        errors(46) = .true.
     endif

     ipte1(i) = i
     if (intne(ipte1(i), itarg1(i))) then
        ! Error #47
        errors(47) = .true.
     endif

     itarg1(i) = -ipte1(i)
     if (intne(ipte1(i), itarg1(i))) then
        ! Error #48
        errors(48) = .true.
     endif

     rpte1(i) = i * 5.0
     if (realne(rpte1(i), rtarg1(i))) then
        ! Error #49
        errors(49) = .true.
     endif

     rtarg1(i) = i * (-5.0)
     if (realne(rpte1(i), rtarg1(i))) then
        ! Error #50
        errors(50) = .true.
     endif

     chpte1(i) = 'a'
     if (chne(chpte1(i), chtarg1(i))) then
        ! Error #51
        errors(51) = .true.
     endif

     chtarg1(i) = 'z'
     if (chne(chpte1(i), chtarg1(i))) then
        ! Error #52
        errors(52) = .true.
     endif

     ch8pte1(i) = 'aaaaaaaa'
     if (ch8ne(ch8pte1(i), ch8targ1(i))) then
        ! Error #53
        errors(53) = .true.
     endif

     ch8targ1(i) = 'zzzzzzzz'
     if (ch8ne(ch8pte1(i), ch8targ1(i))) then
        ! Error #54
        errors(54) = .true.
     endif

     do, j=1,m
        dpte2(j,i)%r1=1.0
        if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then
           ! Error #55
           errors(55) = .true.
        endif

        dtarg2(j,i)%r1=2*dpte2(j,i)%r1
        if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then
           ! Error #56
           errors(56) = .true.
        endif

        ipte2(j,i) = i
        if (intne(ipte2(j,i), itarg2(j,i))) then
           ! Error #57
           errors(57) = .true.
        endif

        itarg2(j,i) = -ipte2(j,i)
        if (intne(ipte2(j,i), itarg2(j,i))) then
           ! Error #58
           errors(58) = .true.
        endif

        rpte2(j,i) = i * (-2.0)
        if (realne(rpte2(j,i), rtarg2(j,i))) then
           ! Error #59
           errors(59) = .true.
        endif

        rtarg2(j,i) = i * (-3.0)
        if (realne(rpte2(j,i), rtarg2(j,i))) then
           ! Error #60
           errors(60) = .true.
        endif

        chpte2(j,i) = 'a'
        if (chne(chpte2(j,i), chtarg2(j,i))) then
           ! Error #61
           errors(61) = .true.
        endif

        chtarg2(j,i) = 'z'
        if (chne(chpte2(j,i), chtarg2(j,i))) then
           ! Error #62
           errors(62) = .true.
        endif

        ch8pte2(j,i) = 'aaaaaaaa'
        if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then
           ! Error #63
           errors(63) = .true.
        endif

        ch8targ2(j,i) = 'zzzzzzzz'
        if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then
           ! Error #64
           errors(64) = .true.
        endif
        do k=1,o
           dpte3(k,j,i)%i2(1+mod(i,5))=i
           if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), dtarg3(k,j,i)%i2(1+mod(i,5)))) then
              ! Error #65
              errors(65) = .true.
           endif

           dtarg3(k,j,i)%i2(1+mod(i,5))=2*dpte3(k,j,i)%i2(1+mod(i,5))
           if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), dtarg3(k,j,i)%i2(1+mod(i,5)))) then
              ! Error #66
              errors(66) = .true.
           endif

           ipte3(k,j,i) = i
           if (intne(ipte3(k,j,i), itarg3(k,j,i))) then
              ! Error #67
              errors(67) = .true.