cray_pointers_2.f90

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

           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 #251
              errors(251) = .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 #252
              errors(252) = .true.
           endif

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

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

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

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

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

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

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

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


subroutine ptr9(nnn,mmm,ooo)
  common /errors/errors(400)
  logical :: errors, intne, realne, chne, ch8ne
  integer :: i,j,k
  integer :: nnn,mmm,ooo
  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(nnn)
  type(drvd) dpte2(mmm,nnn)
  type(drvd) dpte3(ooo,mmm,nnn)
  integer ipte1 (nnn)
  integer ipte2 (mmm,nnn)
  integer ipte3 (ooo,mmm,nnn)
  real rpte1(nnn)
  real rpte2(mmm,nnn)
  real rpte3(ooo,mmm,nnn)
  character chpte1(nnn)
  character chpte2(mmm,nnn)
  character chpte3(ooo,mmm,nnn)
  character*8 ch8pte1(nnn)
  character*8 ch8pte2(mmm,nnn)
  character*8 ch8pte3(ooo,mmm,nnn)

  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 #261
        errors(261) = .true.
     endif

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

        ch8targ2(j,i) = 'zzzzzzzz'
        if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then
           ! Error #280
           errors(280) = .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 #281
              errors(281) = .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 #282
              errors(282) = .true.
           endif

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

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

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

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

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

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

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

           ch8targ3(k,j,i) = 'zzzzzzzz'
           if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then
              ! Error #290
              errors(290) = .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 #291
              errors(291) = .true.
           endif

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

end subroutine ptr9

subroutine ptr10(nnn,mmm,ooo)
  common /errors/errors(400)
  logical :: errors, intne, realne, chne, ch8ne
  integer :: i,j,k
  integer :: nnn,mmm,ooo
  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(nnn))
  pointer(iptr2,dpte2(mmm,nnn))
  pointer(iptr3,dpte3(ooo,mmm,nnn))
  pointer(iptr4,ipte1(nnn))
  pointer(iptr5,ipte2 (mmm,nnn))
  pointer(iptr6,ipte3(ooo,mmm,nnn))
  pointer(iptr7,rpte1(nnn))
  pointer(iptr8,rpte2(mmm,nnn))
  pointer(iptr9,rpte3(ooo,mmm,nnn))
  pointer(iptr10,chpte1(nnn))
  pointer(iptr11,chpte2(mmm,nnn))
  pointer(iptr12,chpte3(ooo,mmm,nnn))
  pointer(iptr13,ch8pte1(nnn))
  pointer(iptr14,ch8pte2(mmm,nnn))
  pointer(iptr15,ch8pte3(ooo,mmm,nnn))

  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 #293
        errors(293) = .true.
     endif

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

        chtarg2(j,i) = 'z'
        if (chne(chpte2(j,i), chtarg2(j,i))) then
           ! Error #310
           errors(310)