!-------------------------------------------------------------------------!
!                                                                         !
!        N  A  S     P A R A L L E L     B E N C H M A R K S  2.3         !
!                                                                         !
!                     S E R I A L     V E R S I O N S                     !
!                                                                         !
!                                   F T                                   !
!                                                                         !
!-------------------------------------------------------------------------!
!                                                                         !
!    This benchmark is a serial version of the NPB FT code.               !
!                                                                         !
!    Permission to use, copy, distribute and modify this software         !
!    for any purpose with or without fee is hereby granted.  We           !
!    request, however, that all derived work reference the NAS            !
!    Parallel Benchmarks 2.3. This software is provided "as is"           !
!    without express or implied warranty.                                 !
!                                                                         !
!    Information on NPB 2.3, including the technical report, the          !
!    original specifications, source code, results and information        !
!    on how to submit new results, is available at:                       !
!                                                                         !
!           http://www.nas.nasa.gov/NAS/NPB/                              !
!                                                                         !
!    Send comments or suggestions to  npb@nas.nasa.gov                    !
!    Send bug reports to              npb-bugs@nas.nasa.gov               !
!                                                                         !
!          NAS Parallel Benchmarks Group                                  !
!          NASA Ames Research Center                                      !
!          Mail Stop: T27A-1                                              !
!          Moffett Field, CA   94035-1000                                 !
!                                                                         !
!          E-mail:  npb@nas.nasa.gov                                      !
!          Fax:     (415) 604-3957                                        !
!                                                                         !
!-------------------------------------------------------------------------!

c---------------------------------------------------------------------
c
c Authors: D. Bailey
c          W. Saphir
c
c---------------------------------------------------------------------

c---------------------------------------------------------------------

c---------------------------------------------------------------------
c FT benchmark
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      program ft

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      implicit none

      include 'global.h'
      integer i, ierr
      
c---------------------------------------------------------------------
c u0, u1, u2 are the main arrays in the problem. 
c Depending on the decomposition, these arrays will have different 
c dimensions. To accomodate all possibilities, we allocate them as 
c one-dimensional arrays and pass them to subroutines for different 
c views
c  - u0 contains the initial (transformed) initial condition
c  - u1 and u2 are working arrays
c  - indexmap maps i,j,k of u0 to the correct i^2+j^2+k^2 for the
c    time evolution operator. 
c---------------------------------------------------------------------

      double complex u0(ntotal), 
     >               u1(ntotal), 
     >               u2(ntotal)
      integer indexmap(ntotal)
c---------------------------------------------------------------------
c Large arrays are in common so that they are allocated on the
c heap rather than the stack. This common block is not
c referenced directly anywhere else. Padding is to avoid accidental 
c cache problems, since all array sizes are powers of two.
c---------------------------------------------------------------------

      double complex pad1(3), pad2(3), pad3(3)
      common /bigarrays/ u0, pad1, u1, pad2, u2, pad3, indexmap

      integer iter
c      double precision total_time, mflops
      logical verified
      character class

c---------------------------------------------------------------------
c Run the entire problem once to make sure all data is touched. 
c This reduces variable startup costs, which is important for such a 
c short benchmark. The other NPB 2 implementations are similar. 
c---------------------------------------------------------------------
c      do i = 1, t_max
c         call timer_clear(i)
c      end do
      call setup()
c      call compute_indexmap(indexmap, dims(1,3))
c      call compute_initial_conditions(u1, dims(1,1))
      call compute_indexmap(indexmap, dims(1,3),dims(2,3),dims(3,3))
      call compute_initial_conditions(u1, dims(1,1),dims(2,1),dims(3,1))
      call fft_init (dims(1,1))
      call fft(1, u1, u0)

c---------------------------------------------------------------------
c Start over from the beginning. Note that all operations must
c be timed, in contrast to other benchmarks. 
c---------------------------------------------------------------------
c      do i = 1, t_max
c         call timer_clear(i)
c      end do

c      call timer_start(T_total)
c      if (timers_enabled) call timer_start(T_setup)

c      call compute_indexmap(indexmap, dims(1,3))
      call compute_indexmap(indexmap, dims(1,3),dims(2,3),dims(3,3))

c      call compute_initial_conditions(u1, dims(1,1))
      call compute_initial_conditions(u1, dims(1,1),dims(2,1),dims(3,1))

      call fft_init (dims(1,1))

c      if (timers_enabled) call timer_stop(T_setup)
c      if (timers_enabled) call timer_start(T_fft)
      call fft(1, u1, u0)
c      if (timers_enabled) call timer_stop(T_fft)

      do iter = 1, niter
c         if (timers_enabled) call timer_start(T_evolve)
         call evolve(u0, u1, iter, indexmap, 
     *        dims(1, 1),dims(2,1),dims(3,1))
c         if (timers_enabled) call timer_stop(T_evolve)
c         if (timers_enabled) call timer_start(T_fft)
         call fft(-1, u1, u2)
c         if (timers_enabled) call timer_stop(T_fft)
c         if (timers_enabled) call timer_start(T_checksum)
c         call checksum(iter, u2, dims(1,1))
         call checksum(iter, u2, dims(1,1),dims(2,1),dims(3,1))
c         if (timers_enabled) call timer_stop(T_checksum)
      end do

      call verify(nx, ny, nz, niter, verified, class)

c      call timer_stop(t_total)
c      total_time = timer_read(t_total)

c      if( total_time .ne. 0. ) then
c         mflops = 1.0d-6*float(ntotal) *
c     >             (14.8157+7.19641*log(float(ntotal))
c     >          +  (5.23518+7.21113*log(float(ntotal)))*niter)
c     >                 /total_time
c      else
c         mflops = 0.0
c      endif
c      call print_results('FT', class, nx, ny, nz, niter,
c     >  total_time, mflops, '          floating point', verified, 
c     >  npbversion, compiletime, cs1, cs2, cs3, cs4, cs5, cs6, cs7)
c      if (timers_enabled) call print_timers()

      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c      subroutine evolve(u0, u1, t, indexmap, d)
      subroutine evolve(u0, u1, t, indexmap, d1, d2, d3)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c evolve u0 -> u1 (t time steps) in fourier space
c---------------------------------------------------------------------

      implicit none
      include 'global.h'
      integer d(3)
c      double complex u0(d(1),d(2),d(3))
c      double complex u1(d(1),d(2),d(3))
c      integer  indexmap(d(1),d(2),d(3))
      integer d1,d2,d3
      double complex u0(d1,d2,d3)
      double complex u1(d1,d2,d3)
      integer  indexmap(d1,d2,d3)
      integer t
      integer i, j, k

      d(1) = d1
      d(2) = d2
      d(3) = d3

      do k = 1, d(3)
         do j = 1, d(2)
            do i = 1, d(1)
               u1(i,j,k) = u0(i,j,k)*ex(t*indexmap(i,j,k))
            end do
         end do
      end do

      return
      end


c---------------------------------------------------------------------
c---------------------------------------------------------------------

c      subroutine compute_initial_conditions(u0, d)
      subroutine compute_initial_conditions(u0, d1,d2,d3)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c Fill in array u0 with initial conditions from 
c random number generator 
c---------------------------------------------------------------------
      implicit none
      include 'global.h'
      integer d(3)
      integer d1,d2,d3
c      double complex u0(d(1), d(2), d(3))
      double complex u0(d1, d2, d3)
      integer k
      double precision x0, start, an, dummy
      
      d(1) = d1
      d(2) = d2
      d(3) = d3

      start = seed                                    
c---------------------------------------------------------------------
c Jump to the starting element for our first plane.
c---------------------------------------------------------------------
      call ipow46(a, (zstart(1)-1)*2*nx*ny + (ystart(1)-1)*2*nx, an)
      dummy = randlc(start, an)
      call ipow46(a, 2*nx*ny, an)
      
c---------------------------------------------------------------------
c Go through by z planes filling in one square at a time.
c---------------------------------------------------------------------
      do k = 1, dims(3, 1) 
         x0 = start
         call vranlc(2*nx*dims(2, 1), x0, a, u0(1, 1, k))
         if (k .ne. dims(3, 1)) dummy = randlc(start, an)
      end do

      return
      end

	            
c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine ipow46(a, exponent, result)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c compute a^exponent mod 2^46
c---------------------------------------------------------------------

      implicit none
      double precision a, result, dummy, q, r
      integer exponent, n, n2
      external randlc
      double precision randlc
c---------------------------------------------------------------------
c Use
c   a^n = a^(n/2)*a^(n/2) if n even else
c   a^n = a*a^(n-1)       if n odd
c---------------------------------------------------------------------
      result = 1
      if (exponent .eq. 0) return
      q = a
      r = 1
      n = exponent

c      do while (n .gt. 1)
 100  if(.not. (n .gt. 1)) goto 200
         n2 = n/2
         if (n2 * 2 .eq. n) then
            dummy = randlc(q, q) 
            n = n2
         else
            dummy = randlc(r, q)
            n = n-1
         endif
c     end do
         goto 100
 200     continue
c
      dummy = randlc(r, q)
      result = r
      return
      end


c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine setup

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      implicit none
      include 'global.h'

      integer ierr, i, j, fstatus
      debug = .FALSE.
      
      write(*, 1000)

      niter = niter_default

      write(*, 1001) nx, ny, nz
      write(*, 1002) niter


 1000 format(//,' NAS Parallel Benchmarks 2.3-serial version',
     >          ' - FT Benchmark', /)
 1001 format(' Size                : ', i3, 'x', i3, 'x', i3)
 1002 format(' Iterations          :     ', i7)
 1004 format(' Number of processes :     ', i7)
 1005 format(' Processor array     :     ', i3, 'x', i3)
 1006 format(' WARNING: compiled for ', i5, ' processes. ',
     >       ' Will not verify. ')

      do i = 1, 3
         dims(1, i) = nx
         dims(2, i) = ny
         dims(3, i) = nz
      end do


      do i = 1, 3
         xstart(i) = 1
         xend(i)   = nx
         ystart(i) = 1
         yend(i)   = ny
         zstart(i) = 1
         zend(i)   = nz
      end do

c---------------------------------------------------------------------
c Set up info for blocking of ffts and transposes.  This improves
c performance on cache-based systems. Blocking involves
c working on a chunk of the problem at a time, taking chunks
c along the first, second, or third dimension. 
c
c - In cffts1 blocking is on 2nd dimension (with fft on 1st dim)
c - In cffts2/3 blocking is on 1st dimension (with fft on 2nd and 3rd dims)

c Since 1st dim is always in processor, we'll assume it's long enough 
c (default blocking factor is 16 so min size for 1st dim is 16)
c The only case we have to worry about is cffts1 in a 2d decomposition. 
c so the blocking factor should not be larger than the 2nd dimension. 
c---------------------------------------------------------------------

      fftblock = fftblock_default
      fftblockpad = fftblockpad_default

      if (fftblock .ne. fftblock_default) fftblockpad = fftblock+3

      return
      end

      
c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine compute_indexmap(indexmap, d1,d2,d3)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c compute function from local (i,j,k) to ibar^2+jbar^2+kbar^2 
c for time evolution exponent. 
c---------------------------------------------------------------------

      implicit none
      include 'global.h'
      integer d(3)
      integer d1,d2,d3
c      integer indexmap(d(1), d(2), d(3))
      integer indexmap(d1, d2, d3)
      integer i, j, k, ii, ii2, jj, ij2, kk
      double precision ap

      d(1) = d1
      d(2) = d2
      d(3) = d3

c---------------------------------------------------------------------
c basically we want to convert the fortran indices 
c   1 2 3 4 5 6 7 8 
c to 
c   0 1 2 3 -4 -3 -2 -1
c The following magic formula does the trick:
c mod(i-1+n/2, n) - n/2
c---------------------------------------------------------------------

      do i = 1, dims(1,3)
         ii =  mod(i+xstart(3)-2+nx/2, nx) - nx/2
         ii2 = ii*ii
         do j = 1, dims(2,3)
            jj = mod(j+ystart(3)-2+ny/2, ny) - ny/2
            ij2 = jj*jj+ii2
            do k = 1, dims(3,3)
               kk = mod(k+zstart(3)-2+nz/2, nz) - nz/2
               indexmap(i, j, k) = kk*kk+ij2
            end do
         end do
      end do

c---------------------------------------------------------------------
c compute array of exponentials for time evolution. 
c---------------------------------------------------------------------
      ap = - 4.d0 * alpha * pi *pi

      ex(0) = 1.0d0
      ex(1) = exp(ap)
      do i = 2, expmax
         ex(i) = ex(i-1)*ex(1)
      end do

      return
      end



c---------------------------------------------------------------------
c---------------------------------------------------------------------

c      subroutine print_timers()
c
c---------------------------------------------------------------------
c---------------------------------------------------------------------

c      implicit none
c      integer i
c      include 'global.h'
c      character*25 tstrings(T_max)
c      data tstrings / '          total ', 
c     >                '          setup ', 
c     >                '            fft ', 
c     >                '         evolve ', 
c     >                '       checksum ', 
c     >                '         fftlow ', 
c     >                '        fftcopy ' /

c      do i = 1, t_max
c         if (timer_read(i) .ne. 0.0d0) then
c            write(*, 100) i, tstrings(i), timer_read(i)
c         endif
c      end do
c 100  format(' timer ', i2, '(', A16,  ') :', F10.6)
c      return
c      end



c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine fft(dir, x1, x2)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      implicit none
      include 'global.h'
      integer dir
      double complex x1(ntotal), x2(ntotal)

      double complex scratch(fftblockpad_default*maxdim*2)

c---------------------------------------------------------------------
c note: args x1, x2 must be different arrays
c note: args for cfftsx are (direction, layout, xin, xout, scratch)
c       xin/xout may be the same and it can be somewhat faster
c       if they are
c---------------------------------------------------------------------

      if (dir .eq. 1) then
c         call cffts1(1, dims(1,1), x1, x1, scratch)
c         call cffts2(1, dims(1,2), x1, x1, scratch)
c         call cffts3(1, dims(1,3), x1, x2, scratch)
         call cffts1(1, dims(1,1),dims(2,1),dims(3,1), x1, x1, scratch)
         call cffts2(1, dims(1,2),dims(2,2),dims(3,2), x1, x1, scratch)
         call cffts3(1, dims(1,3),dims(3,3),dims(3,3), x1, x2, scratch)
      else
c         call cffts3(-1, dims(1,3), x1, x1, scratch)
c         call cffts2(-1, dims(1,2), x1, x1, scratch)
c         call cffts1(-1, dims(1,1), x1, x2, scratch)
         call cffts3(-1, dims(1,3),dims(2,3),dims(3,3), x1, x1, scratch)
         call cffts2(-1, dims(1,2),dims(2,2),dims(3,2), x1, x1, scratch)
         call cffts1(-1, dims(1,1),dims(2,1),dims(3,1), x1, x2, scratch)
      endif
      return
      end



c---------------------------------------------------------------------
c---------------------------------------------------------------------

c      subroutine cffts1(is, d, x, xout, y)
      subroutine cffts1(is, d1,d2,d3, x, xout, y)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      implicit none

      include 'global.h'
      integer is, d(3), logd(3)
      integer d1,d2,d3
c      double complex x(d(1),d(2),d(3))
c      double complex xout(d(1),d(2),d(3))
      double complex x(d1,d2,d3)
      double complex xout(d1,d2,d3)
c      double complex y(fftblockpad, d(1), 2) 
      double complex y(fftblockpad, d1, 2) 
      integer i, j, k, jj

      d(1) = d1
      d(2) = d2
      d(3) = d3

      do i = 1, 3
         logd(i) = ilog2(d(i))
      end do
      do k = 1, d(3)
         do jj = 0, d(2) - fftblock, fftblock
c            if (timers_enabled) call timer_start(T_fftcopy)
            do j = 1, fftblock
               do i = 1, d(1)
                  y(j,i,1) = x(i,j+jj,k)
               enddo
            enddo
c            if (timers_enabled) call timer_stop(T_fftcopy)
            
c            if (timers_enabled) call timer_start(T_fftlow)
            call cfftz (is, logd(1), 
     >                  d(1), y, y(1,1,2))

c            if (timers_enabled) call timer_stop(T_fftlow)

c            if (timers_enabled) call timer_start(T_fftcopy)
            do j = 1, fftblock
               do i = 1, d(1)
                  xout(i,j+jj,k) = y(j,i,1)
               enddo
            enddo
c            if (timers_enabled) call timer_stop(T_fftcopy)
         enddo
      enddo

      return
      end


c---------------------------------------------------------------------
c---------------------------------------------------------------------

c      subroutine cffts2(is, d, x, xout, y)
      subroutine cffts2(is, d1,d2,d3, x, xout, y)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      implicit none

      include 'global.h'
      integer is, d(3), logd(3)
      integer d1,d2,d3
c      double complex x(d(1),d(2),d(3))
c      double complex xout(d(1),d(2),d(3))
c      double complex y(fftblockpad, d(2), 2) 
      double complex x(d1,d2,d3)
      double complex xout(d1,d2,d3)
      double complex y(fftblockpad, d2, 2) 
      integer i, j, k, ii

      d(1) = d1
      d(2) = d2
      d(3) = d3

      do i = 1, 3
         logd(i) = ilog2(d(i))
      end do
      do k = 1, d(3)
        do ii = 0, d(1) - fftblock, fftblock
c           if (timers_enabled) call timer_start(T_fftcopy)
           do j = 1, d(2)
              do i = 1, fftblock
                 y(i,j,1) = x(i+ii,j,k)
              enddo
           enddo
c           if (timers_enabled) call timer_stop(T_fftcopy)

c           if (timers_enabled) call timer_start(T_fftlow)
           call cfftz (is, logd(2), 
     >          d(2), y, y(1, 1, 2))
           
c           if (timers_enabled) call timer_stop(T_fftlow)
c           if (timers_enabled) call timer_start(T_fftcopy)
           do j = 1, d(2)
              do i = 1, fftblock
                 xout(i+ii,j,k) = y(i,j,1)
              enddo
           enddo
c           if (timers_enabled) call timer_stop(T_fftcopy)
        enddo
      enddo

      return
      end


c---------------------------------------------------------------------
c---------------------------------------------------------------------

c      subroutine cffts3(is, d, x, xout, y)
      subroutine cffts3(is, d1,d2,d3, x, xout, y)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      implicit none

      include 'global.h'
      integer is, d(3), logd(3)
c      double complex x(d(1),d(2),d(3))
c      double complex xout(d(1),d(2),d(3))
c      double complex y(fftblockpad, d(3), 2) 
      integer d1,d2,d3
      double complex x(d1,d2,d3)
      double complex xout(d1,d2,d3)
      double complex y(fftblockpad, d3, 2) 
      integer i, j, k, ii
      d(1) = d1
      d(2) = d2
      d(3) = d3

      do i = 1, 3
         logd(i) = ilog2(d(i))
      end do
      do j = 1, d(2)
        do ii = 0, d(1) - fftblock, fftblock
c           if (timers_enabled) call timer_start(T_fftcopy)
           do k = 1, d(3)
              do i = 1, fftblock
                 y(i,k,1) = x(i+ii,j,k)
              enddo
           enddo
c           if (timers_enabled) call timer_stop(T_fftcopy)

c           if (timers_enabled) call timer_start(T_fftlow)
           call cfftz (is, logd(3), 
     >          d(3), y, y(1, 1, 2))
c           if (timers_enabled) call timer_stop(T_fftlow)
c           if (timers_enabled) call timer_start(T_fftcopy)
           do k = 1, d(3)
              do i = 1, fftblock
                 xout(i+ii,j,k) = y(i,k,1)
              enddo
           enddo
c           if (timers_enabled) call timer_stop(T_fftcopy)
        enddo
      enddo

      return
      end


c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine fft_init (n)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c compute the roots-of-unity array that will be used for subsequent FFTs. 
c---------------------------------------------------------------------

      implicit none
      include 'global.h'

      integer m,n,nu,ku,i,j,ln
      double precision t, ti


c---------------------------------------------------------------------
c   Initialize the U array with sines and cosines in a manner that permits
c   stride one access at each FFT iteration.
c---------------------------------------------------------------------
      nu = n
      m = ilog2(n)
      u(1) = m
      ku = 2
      ln = 1

      do j = 1, m
         t = pi / ln
         
         do i = 0, ln - 1
            ti = i * t
            u(i+ku) = dcmplx (cos (ti), sin(ti))
         enddo
         
         ku = ku + ln
         ln = 2 * ln
      enddo
      
      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine cfftz (is, m, n, x, y)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c   Computes NY N-point complex-to-complex FFTs of X using an algorithm due
c   to Swarztrauber.  X is both the input and the output array, while Y is a 
c   scratch array.  It is assumed that N = 2^M.  Before calling CFFTZ to 
c   perform FFTs, the array U must be initialized by calling CFFTZ with IS 
c   set to 0 and M set to MX, where MX is the maximum value of M for any 
c   subsequent call.
c---------------------------------------------------------------------

      implicit none
      include 'global.h'

      integer is,m,n,i,j,l,mx
      double complex x, y

      dimension x(fftblockpad,n), y(fftblockpad,n)

c---------------------------------------------------------------------
c   Check if input parameters are invalid.
c---------------------------------------------------------------------
      mx = u(1)
      if ((is .ne. 1 .and. is .ne. -1) .or. m .lt. 1 .or. m .gt. mx)    
     >  then
        write (*, 1)  is, m, mx
 1      format ('CFFTZ: Either U has not been initialized, or else'/    
     >    'one of the input parameters is invalid', 3I5)
        stop
      endif

c---------------------------------------------------------------------
c   Perform one variant of the Stockham FFT.
c---------------------------------------------------------------------
      do l = 1, m, 2
        call fftz2 (is, l, m, n, fftblock, fftblockpad, u, x, y)
        if (l .eq. m) goto 160
        call fftz2 (is, l + 1, m, n, fftblock, fftblockpad, u, y, x)
      enddo

      goto 180

c---------------------------------------------------------------------
c   Copy Y to X.
c---------------------------------------------------------------------
 160  do j = 1, n
        do i = 1, fftblock
          x(i,j) = y(i,j)
        enddo
      enddo

 180  continue

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine fftz2 (is, l, m, n, ny, ny1, u, x, y)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c   Performs the L-th iteration of the second variant of the Stockham FFT.
c---------------------------------------------------------------------

      implicit none

      integer is,k,l,m,n,ny,ny1,n1,li,lj,lk,ku,i,j,i11,i12,i21,i22
      double complex u,x,y,u1,x11,x21
      dimension u(n), x(ny1,n), y(ny1,n)


c---------------------------------------------------------------------
c   Set initial parameters.
c---------------------------------------------------------------------

      n1 = n / 2
      lk = 2 ** (l - 1)
      li = 2 ** (m - l)
      lj = 2 * lk
      ku = li + 1

      do i = 0, li - 1
        i11 = i * lk + 1
        i12 = i11 + n1
        i21 = i * lj + 1
        i22 = i21 + lk
        if (is .ge. 1) then
          u1 = u(ku+i)
        else
          u1 = dconjg (u(ku+i))
        endif

c---------------------------------------------------------------------
c   This loop is vectorizable.
c---------------------------------------------------------------------
        do k = 0, lk - 1
          do j = 1, ny
            x11 = x(j,i11+k)
            x21 = x(j,i12+k)
            y(j,i21+k) = x11 + x21
            y(j,i22+k) = u1 * (x11 - x21)
          enddo
        enddo
      enddo

      return
      end

c---------------------------------------------------------------------


c---------------------------------------------------------------------
c---------------------------------------------------------------------

      integer function ilog2(n)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      implicit none
      integer n, nn, lg
      if (n .eq. 1) then
         ilog2=0
         return
      endif
      lg = 1
      nn = 2
      
c      do while (nn .lt. n)
 100  if(.not.(nn .lt. n)) goto 200
         nn = nn*2
         lg = lg+1
c      end do
         goto 100
 200     continue
      ilog2 = lg
      return
      end


c---------------------------------------------------------------------
c---------------------------------------------------------------------

c      subroutine checksum(i, u1, d)
      subroutine checksum(i, u1, d1,d2,d3)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      implicit none
      include 'global.h'
      integer i, d(3)
      integer d1,d2,d3
c      double complex u1(d(1),d(2),d(3))
      double complex u1(d1,d2,d3)
      integer j, q,r,s, ierr
      double complex chk,allchk

      d(1) = d1
      d(2) = d2
      d(3) = d3

      chk = (0.0,0.0)

      do j=1,1024
         q = mod(j, nx)+1
         if (q .ge. xstart(1) .and. q .le. xend(1)) then
            r = mod(3*j,ny)+1
            if (r .ge. ystart(1) .and. r .le. yend(1)) then
               s = mod(5*j,nz)+1
               if (s .ge. zstart(1) .and. s .le. zend(1)) then
                  chk=chk+u1(q-xstart(1)+1,r-ystart(1)+1,s-zstart(1)+1)
               end if
            end if
         end if
      end do

      chk = chk/dble(ntotal)
      
      write (*, 30) i, chk
 30   format (' T =',I5,5X,'Checksum =',1P2D22.12)
      sums(i) = chk
      return
      end


c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine verify (d1, d2, d3, nt, verified, class)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      implicit none
      include 'global.h'
      integer d1, d2, d3, nt
      character class
      logical verified
      integer ierr, size, i
      double precision err, epsilon

c---------------------------------------------------------------------
c   Sample size reference checksums
c---------------------------------------------------------------------
      double precision vdata_real_s(6)
      double precision vdata_imag_s(6)
      double precision vdata_real_w(6)
      double precision vdata_imag_w(6)
      double precision vdata_real_a(6)
      double precision vdata_imag_a(6)
      double precision vdata_real_b(20)
      double precision vdata_imag_b(20)
      double precision vdata_real_c(20)
      double precision vdata_imag_c(20)
      data vdata_real_s / 5.546087004964D+02,
     >                5.546385409189D+02,
     >                5.546148406171D+02,
     >                5.545423607415D+02,
     >                5.544255039624D+02,
     >                5.542683411902D+02 /

      data vdata_imag_s / 4.845363331978D+02,
     >                4.865304269511D+02,
     >                4.883910722336D+02,
     >                4.901273169046D+02,
     >                4.917475857993D+02,
     >                4.932597244941D+02 /
c---------------------------------------------------------------------
c   Class W size reference checksums
c---------------------------------------------------------------------
       data vdata_real_w /
     >                5.673612178944D+02,
     >                5.631436885271D+02,
     >                5.594024089970D+02,
     >                5.560698047020D+02,
     >                5.530898991250D+02,
     >                5.504159734538D+02/
       data vdata_imag_w /
     >               5.293246849175D+02,
     >               5.282149986629D+02,
     >               5.270996558037D+02, 
     >               5.260027904925D+02, 
     >               5.249400845633D+02,
     >               5.239212247086D+02/

c---------------------------------------------------------------------
c   Class A size reference checksums
c---------------------------------------------------------------------
      data vdata_real_a / 5.046735008193D+02,
     >                5.059412319734D+02,
     >                5.069376896287D+02,
     >                5.077892868474D+02,
     >                5.085233095391D+02,
     >                5.091487099959D+02 /
      
      data vdata_imag_a / 5.114047905510D+02,
     >                5.098809666433D+02,
     >                5.098144042213D+02,
     >                5.101336130759D+02,
     >                5.104914655194D+02,
     >                5.107917842803D+02 /
      
c---------------------------------------------------------------------
c   Class B size reference checksums
c---------------------------------------------------------------------
      data vdata_real_b / 5.177643571579D+02,
     >                5.154521291263D+02,
     >                5.146409228649D+02,
     >                5.142378756213D+02,
     >                5.139626667737D+02,
     >                5.137423460082D+02,
     >                5.135547056878D+02,
     >                5.133910925466D+02,
     >                5.132470705390D+02,
     >                5.131197729984D+02,
     >                5.130070319283D+02,
     >                5.129070537032D+02,
     >                5.128182883502D+02,
     >                5.127393733383D+02,
     >                5.126691062020D+02,
     >                5.126064276004D+02,
     >                5.125504076570D+02,
     >                5.125002331720D+02,
     >                5.124551951846D+02,
     >                5.124146770029D+02 /
   
      data vdata_imag_b / 5.077803458597D+02,
     >                5.088249431599D+02,                  
     >                5.096208912659D+02,                     
     >                5.101023387619D+02,                  
     >                5.103976610617D+02,                  
     >                5.105948019802D+02,                  
     >                5.107404165783D+02,                  
     >                5.108576573661D+02,                  
     >                5.109577278523D+02,                  
     >                5.110460304483D+02,                  
     >                5.111252433800D+02,                  
     >                5.111968077718D+02,                  
     >                5.112616233064D+02,                  
     >                5.113203605551D+02,                  
     >                5.113735928093D+02,                  
     >                5.114218460548D+02,
     >                5.114656139760D+02,
     >                5.115053595966D+02,
     >                5.115415130407D+02,
     >                5.115744692211D+02 /

c---------------------------------------------------------------------
c   Class C size reference checksums
c---------------------------------------------------------------------
      data vdata_real_c / 5.195078707457D+02,
     >                5.155422171134D+02,
     >                5.144678022222D+02,
     >                5.140150594328D+02,
     >                5.137550426810D+02,
     >                5.135811056728D+02,
     >                5.134569343165D+02,
     >                5.133651975661D+02,
     >                5.132955192805D+02,
     >                5.132410471738D+02,
     >                5.131971141679D+02,
     >                5.131605205716D+02,
     >                5.131290734194D+02,
     >                5.131012720314D+02,
     >                5.130760908195D+02,
     >                5.130528295923D+02,
     >                5.130310107773D+02,
     >                5.130103090133D+02,
     >                5.129905029333D+02,
     >                5.129714421109D+02 /

      data vdata_imag_c / 5.149019699238D+02,
     >                5.127578201997D+02,
     >                5.122251847514D+02,
     >                5.121090289018D+02,
     >                5.121143685824D+02,
     >                5.121496764568D+02,
     >                5.121870921893D+02,
     >                5.122193250322D+02,
     >                5.122454735794D+02,
     >                5.122663649603D+02,
     >                5.122830879827D+02,
     >                5.122965869718D+02,
     >                5.123075927445D+02,
     >                5.123166486553D+02,
     >                5.123241541685D+02,
     >                5.123304037599D+02,
     >                5.123356167976D+02,
     >                5.123399592211D+02,
     >                5.123435588985D+02,
     >                5.123465164008D+02 /



      epsilon = 1.0d-12

      verified = .FALSE.
      class = 'U'

      if (d1 .eq. 64 .and.
     >    d2 .eq. 64 .and.
     >    d3 .eq. 64 .and.
     >    nt .eq. 6) then
         class = 'S'
         do i = 1, nt
            err = (dble(sums(i)) - vdata_real_s(i)) / vdata_real_s(i)
            if (abs(err) .gt. epsilon) goto 100
            err = (dimag(sums(i)) - vdata_imag_s(i)) / vdata_imag_s(i)
c If you have a machine where the above does not compile, let 
c us know and use the following
c            err = (aimag(sums(i)) - vdata_imag_s(i)) / vdata_imag_s(i)
            if (abs(err) .gt. epsilon) goto 100
         end do
         verified = .TRUE.
 100     continue
      else if (d1 .eq. 128 .and.
     >    d2 .eq. 128 .and.
     >    d3 .eq. 32 .and.
     >    nt .eq. 6) then
         class = 'W'
         do i = 1, nt
            err = (dble(sums(i)) - vdata_real_w(i)) / vdata_real_w(i)
            if (abs(err) .gt. epsilon) goto 105
            err = (dimag(sums(i)) - vdata_imag_w(i)) / vdata_imag_w(i)
c If you have a machine where the above does not compile, let 
c us know and use the following
c            err = (aimag(sums(i)) - vdata_imag_w(i)) / vdata_imag_w(i)
            if (abs(err) .gt. epsilon) goto 105
         end do
         verified = .TRUE.
 105     continue
      else if (d1 .eq. 256 .and.
     >    d2 .eq. 256 .and.
     >    d3 .eq. 128 .and.
     >    nt .eq. 6) then
         class = 'A'
         do i = 1, nt
            err = (dble(sums(i)) - vdata_real_a(i)) / vdata_real_a(i)
            if (abs(err) .gt. epsilon) goto 110
            err = (dimag(sums(i)) - vdata_imag_a(i)) / vdata_imag_a(i)
c If you have a machine where the above does not compile, let 
c us know and use the following
c            err = (aimag(sums(i)) - vdata_imag_a(i)) / vdata_imag_a(i)
            if (abs(err) .gt. epsilon) goto 110
         end do
         verified = .TRUE.
 110     continue
      else if (d1 .eq. 512 .and.
     >    d2 .eq. 256 .and.
     >    d3 .eq. 256 .and.
     >    nt .eq. 20) then
         class = 'B'
         do i = 1, nt
            err = (dble(sums(i)) - vdata_real_b(i)) / vdata_real_b(i)
            if (abs(err) .gt. epsilon) goto 120
            err = (dimag(sums(i)) - vdata_imag_b(i)) / vdata_imag_b(i)
c If you have a machine where the above does not compile, let 
c us know and use the following
c            err = (aimag(sums(i)) - vdata_imag_b(i)) / vdata_imag_b(i)
            if (abs(err) .gt. epsilon) goto 120
         end do
         verified = .TRUE.
 120     continue
      else if (d1 .eq. 512 .and.
     >    d2 .eq. 512 .and.
     >    d3 .eq. 512 .and.
     >    nt .eq. 20) then
         class = 'C'
         do i = 1, nt 
            err = (dble(sums(i)) - vdata_real_c(i)) / vdata_real_c(i)
            if (abs(err) .gt. epsilon) goto 130
            err = (dimag(sums(i)) - vdata_imag_c(i)) / vdata_imag_c(i)
c            err = (aimag(sums(i)) - vdata_imag_c(i)) / vdata_imag_c(i)
            if (abs(err) .gt. epsilon) goto 130
         end do
         verified = .TRUE.
 130     continue
      endif
         
      if (class .ne. 'U') then
         if (verified) then
            write(*,2000)
 2000       format(' Result verification successful')
         else
            write(*,2001)
 2001       format(' Result verification failed')
         endif
      endif
      print *, 'class = ', class

      return
      end



c---------------------------------------------------------------------
c---------------------------------------------------------------------

      double precision function randlc (x, a)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c
c   This routine returns a uniform pseudorandom double precision number in the
c   range (0, 1) by using the linear congruential generator
c
c   x_{k+1} = a x_k  (mod 2^46)
c
c   where 0 < x_k < 2^46 and 0 < a < 2^46.  This scheme generates 2^44 numbers
c   before repeating.  The argument A is the same as 'a' in the above formula,
c   and X is the same as x_0.  A and X must be odd double precision integers
c   in the range (1, 2^46).  The returned value RANDLC is normalized to be
c   between 0 and 1, i.e. RANDLC = 2^(-46) * x_1.  X is updated to contain
c   the new seed x_1, so that subsequent calls to RANDLC using the same
c   arguments will generate a continuous sequence.
c
c   This routine should produce the same results on any computer with at least
c   48 mantissa bits in double precision floating point data.  On 64 bit
c   systems, double precision should be disabled.
c
c   David H. Bailey     October 26, 1990
c
c---------------------------------------------------------------------

      implicit none

      double precision r23,r46,t23,t46,a,x,t1,t2,t3,t4,a1,a2,x1,x2,z
      parameter (r23 = 0.5d0 ** 23, r46 = r23 ** 2, t23 = 2.d0 ** 23,
     >  t46 = t23 ** 2)

c---------------------------------------------------------------------
c   Break A into two parts such that A = 2^23 * A1 + A2.
c---------------------------------------------------------------------
      t1 = r23 * a
      a1 = int (t1)
      a2 = a - t23 * a1

c---------------------------------------------------------------------
c   Break X into two parts such that X = 2^23 * X1 + X2, compute
c   Z = A1 * X2 + A2 * X1  (mod 2^23), and then
c   X = 2^23 * Z + A2 * X2  (mod 2^46).
c---------------------------------------------------------------------
      t1 = r23 * x
      x1 = int (t1)
      x2 = x - t23 * x1
      t1 = a1 * x2 + a2 * x1
      t2 = int (r23 * t1)
      z = t1 - t23 * t2
      t3 = t23 * z + a2 * x2
      t4 = int (r46 * t3)
      x = t3 - t46 * t4
      randlc = r46 * x

      return
      end




c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine vranlc (n, x, a, y)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c
c   This routine generates N uniform pseudorandom double precision numbers in
c   the range (0, 1) by using the linear congruential generator
c
c   x_{k+1} = a x_k  (mod 2^46)
c
c   where 0 < x_k < 2^46 and 0 < a < 2^46.  This scheme generates 2^44 numbers
c   before repeating.  The argument A is the same as 'a' in the above formula,
c   and X is the same as x_0.  A and X must be odd double precision integers
c   in the range (1, 2^46).  The N results are placed in Y and are normalized
c   to be between 0 and 1.  X is updated to contain the new seed, so that
c   subsequent calls to VRANLC using the same arguments will generate a
c   continuous sequence.  If N is zero, only initialization is performed, and
c   the variables X, A and Y are ignored.
c
c   This routine is the standard version designed for scalar or RISC systems.
c   However, it should produce the same results on any single processor
c   computer with at least 48 mantissa bits in double precision floating point
c   data.  On 64 bit systems, double precision should be disabled.
c
c---------------------------------------------------------------------

      implicit none

      integer i,n
      double precision y,r23,r46,t23,t46,a,x,t1,t2,t3,t4,a1,a2,x1,x2,z
      dimension y(*)
      parameter (r23 = 0.5d0 ** 23, r46 = r23 ** 2, t23 = 2.d0 ** 23,
     >  t46 = t23 ** 2)


c---------------------------------------------------------------------
c   Break A into two parts such that A = 2^23 * A1 + A2.
c---------------------------------------------------------------------
      t1 = r23 * a
      a1 = int (t1)
      a2 = a - t23 * a1

c---------------------------------------------------------------------
c   Generate N results.   This loop is not vectorizable.
c---------------------------------------------------------------------
      do i = 1, n

c---------------------------------------------------------------------
c   Break X into two parts such that X = 2^23 * X1 + X2, compute
c   Z = A1 * X2 + A2 * X1  (mod 2^23), and then
c   X = 2^23 * Z + A2 * X2  (mod 2^46).
c---------------------------------------------------------------------
        t1 = r23 * x
        x1 = int (t1)
        x2 = x - t23 * x1
        t1 = a1 * x2 + a2 * x1
        t2 = int (r23 * t1)
        z = t1 - t23 * t2
        t3 = t23 * z + a2 * x2
        t4 = int (r46 * t3)
        x = t3 - t46 * t4
        y(i) = r46 * x
      enddo

      return
      end
