C Copyright(c) 1997, Space Science and Engineering Center, UW-Madison
C Refer to "McIDAS Software Acquisition and Distribution Policies"
C in the file  mcidas/data/license.txt

      FUNCTION RAERAC(IYRDY,IHMS,RAE)
C *** $Id: raerac.f,v 1.6 1997/10/10 20:18:42 dglo Exp $ ***
C RAERAC PHILLI 0174 NAV: CONVERTS EARTH LON TO CELESTIAL LON
C $ FUNCTION RAERAC(IYRDY, IHMS, RAE)  (DAS)
C $ CONVERT CONVERT EARTH LONGITUDE TO CELESTIAL LONGITUDE. FN VAL IS
C $   IN REAL*4 DEGREES.
C $ IYRDY = (I) INPUT  YEAR AND JULIAN DAY (YYDDD)
C $ IHMS = (I) INPUT  TIME (HHMMSS)
C $ RAE = (R) INPUT  EARTH LONGITUDE (DEGREES)
C $$ RAERAC = NAVIGATION, CONVERT, LONGITUDE
C
C REF: ESCOBAL, "METHODS OF ORBIT DETERMINATION." WILEY & SONS, 1965
C GREENWICH SIDEREAL TIME := ANGLE BETWEEN PRIME MERID. & 0 DEG R.A.
C JULIAN DATE := # DAYS ELAPSED SINCE 12 NOON ON JAN 1, 4713 B.C.
C APPROXIMATE FORMULA FOR GREENWICH SIDEREAL TIME AT 0Z:
C G.S.T (DEG) = S(0) = 99.6909833 + 36000.7689*C + 0.00038708*C*C ,WHERE
C    C = TIME IN CENTURIES = (J.D. - 2415020.0) / 36525
C FOR G.S.T. AT OTHER TIMES OF (SAME) DAY, USE:
C G.S.T AT TIME T = S(T) = S(0) + (T * DS/DT)
C DS/DT = 1 + (1 / 365.24219879) = 1.00273790927 REVOLUTIONS/DAY
C       = 0.250684477 DEGREES/MINUTE
C
C FROM TABLE, J.D. AT 0Z ON JAN 1,1974 = 2442048.5
C THEN S(0) AT 0Z ON JAN 1,1974 = 100.2601800
C
C
      DOUBLE PRECISION TIMDIF,RAHA,SOLSID,SHA
      SHA=100.26467D0
      IRAYD=74001
      IRAHMS=0
      SOLSID=1.00273791D0
      RAHA=RAE+TIMDIF(IRAYD,IRAHMS,IYRDY,IHMS)*SOLSID/4.0D0+SHA
      RAC=DMOD(RAHA,360.0D0)
      IF(RAC.LT.0.0)RAC=RAC+360.0
      RAERAC=RAC
      RETURN
      END
C
C
      FUNCTION RACRAE(IYRDY,IHMS,RAC)
C RACRAE PHILLI 0174 NAV: CONVERTS CELESTIAL ONG TO EARTH LON
C $ FUNCTION RACRAE(IYRDY, IHMS, RAC)  (DAS)
C $ CONVERT CONVERT CELESTIAL LONGITUDE TO EARTH LONGITUDE. FN VAL IS
C $   IN REAL*4 DEGREES.
C $ IYRDY = (I) INPUT  YEAR AND JULIAN DAY (YYDDD)
C $ IHMS = (I) INPUT  TIME (HHMMSS)
C $ RAE = (R) INPUT  CELESTIAL LONGITUDE (DEGREES)
C $$ RACRAE = NAVIGATION, CONVERT, LONGITUDE
C
C
      DOUBLE PRECISION TIMDIF,RAHA,SOLSID,SHA
      SHA=100.26467D0
      IRAYD=74001
      IRAHMS=0
      SOLSID=1.00273791D0
      RAHA=RAC-SHA+TIMDIF(IYRDY,IHMS,IRAYD,IRAHMS)*SOLSID/4.0D0
      RAE=DMOD(RAHA,360.0D0)
      IF(RAE.LT.0.0)RAE=RAE+360.0
      RACRAE=RAE
      RETURN
      END


c
c non central cumulative f distribution
c
c Uses ncbeta from AS 310 APPL. STATIST. (1997), VOL. 46, NO. 1
c
      function dncf(f,df1,df2,ncp,ifault)
      implicit none
      real*8 dncf
      real*8 f, df1, df2, ncp
      integer ifault

      real*8 ncbeta
      external ncbeta

      real*8 errmax, y

      errmax = 1.0e-6
      y = (df1 / df2) * f

      dncf=ncbeta(df1/2.0, df2/2.0,ncp,y/(1.0+y),errmax,ifault)

      return
      end


c
c -------------------------------------------------------------
c
       subroutine setVerts(poly,artri,x1,y1,x2,y2,x3,y3,ivert)

       implicit double precision (a-h,o-z)
       dimension poly(10,2)

       x1 = poly(1,1)
       y1 = poly(1,2)

       x2 = poly(ivert-1,1)
       y2 = poly(ivert-1,2)

       x3 = poly(ivert,1)
       y3 = poly(ivert,2)

       !artri = 0.5d0*((x2-x1) * (y3-y1) - (x3-x1) * (y2-y1) )
       artri = 0.5d0*((x2-x1)*(y1+y2)+(x3-x2)*(y2+y3)+(x1-x3)*(y3+y1))

       return
       end


PROGRAM main
  !-----------------------------------------------------------------------------------
  !
  !
  ! PURPOSE
  !
  ! This program numerically solves the 3D incompressible Navier-Stokes
  ! on a Cubic Domain [0,2pi]x[0,2pi]x[0,2pi] using pseudo-spectral methods and
  ! Implicit Midpoint rule timestepping. The numerical solution is compared to
  ! an exact solution reported by Shapiro
  !
  ! Analytical Solution:
  !       u(x,y,z,t)=-0.25*(cos(x)sin(y)sin(z)+sin(x)cos(y)cos(z))exp(-t/Re)
  !       v(x,y,z,t)= 0.25*(sin(x)cos(y)sin(z)-cos(x)sin(y)cos(z))exp(-t/Re)
  !       w(x,y,z,t)= 0.5*cos(x)cos(y)sin(z)exp(-t/Re)
  !
  ! .. Parameters ..
  !  Nx                           = number of modes in x - power of 2 for FFT
  !  Ny                           = number of modes in y - power of 2 for FFT
  !  Nz                           = number of modes in z - power of 2 for FFT
  !  Nt                           = number of timesteps to take
  !  Tmax                         = maximum simulation time
  !  FFTW_IN_PLACE        = value for FFTW input
  !  FFTW_MEASURE         = value for FFTW input
  !  FFTW_EXHAUSTIVE      = value for FFTW input
  !  FFTW_PATIENT         = value for FFTW input
  !  FFTW_ESTIMATE        = value for FFTW input
  !  FFTW_FORWARD     = value for FFTW input
  !  FFTW_BACKWARD        = value for FFTW input
  !  pi = 3.14159265358979323846264338327950288419716939937510d0
  !  Re                           = Reynolds number
  ! .. Scalars ..
  !  i                            = loop counter in x direction
  !  j                            = loop counter in y direction
  !  k                            = loop counter in z direction
  !  n                            = loop counter for timesteps direction
  !  allocatestatus       = error indicator during allocation
  !  count                        = keep track of information written to disk
  !  iol                          = size of array to write to disk
  !  start                        = variable to record start time of program
  !  finish                       = variable to record end time of program
  !  count_rate           = variable for clock count rate
  !  planfxyz                     = Forward 3d fft plan
  !  planbxyz                     = Backward 3d fft plan
  !  dt                           = timestep
  ! .. Arrays ..
  !  u                            = velocity in x direction
  !  v                            = velocity in y direction
  !  w                            = velocity in z direction
  !  uold                         = velocity in x direction at previous timestep
  !  vold                         = velocity in y direction at previous timestep
  !  wold                         = velocity in z direction at previous timestep
  !  ux                           = x derivative of velocity in x direction
  !  uy                           = y derivative of velocity in x direction
  !  uz                           = z derivative of velocity in x direction
  !  vx                           = x derivative of velocity in y direction
  !  vy                           = y derivative of velocity in y direction
  !  vz                           = z derivative of velocity in y direction
  !  wx                           = x derivative of velocity in z direction
  !  wy                           = y derivative of velocity in z direction
  !  wz                           = z derivative of velocity in z direction
  !  uxold                        = x derivative of velocity in x direction
  !  uyold                        = y derivative of velocity in x direction
  !  uzold                        = z derivative of velocity in x direction
  !  vxold                        = x derivative of velocity in y direction
  !  vyold                        = y derivative of velocity in y direction
  !  vzold                        = z derivative of velocity in y direction
  !  wxold                        = x derivative of velocity in z direction
  !  wyold                        = y derivative of velocity in z direction
  !  wzold                        = z derivative of velocity in z direction
  !  utemp                        = temporary storage of u to check convergence
  !  vtemp                        = temporary storage of u to check convergence
  !  wtemp                        = temporary storage of u to check convergence
  !  temp_r                       = temporary storage for untransformed variables
  !  uhat                         = Fourier transform of u
  !  vhat                         = Fourier transform of v
  !  what                         = Fourier transform of w
  !  rhsuhatfix           = Fourier transform of righthand side for u for timestepping
  !  rhsvhatfix           = Fourier transform of righthand side for v for timestepping
  !  rhswhatfix           = Fourier transform of righthand side for w for timestepping
  !  nonlinuhat           = Fourier transform of nonlinear term for u
  !  nonlinvhat           = Fourier transform of nonlinear term for u
  !  nonlinwhat           = Fourier transform of nonlinear term for u
  !  phat                         = Fourier transform of nonlinear term for pressure, p
  !  temp_c                       = temporary storage for Fourier transforms
  !  realtemp                     = Real storage
  !
  ! .. Vectors ..
  !  kx                           = fourier frequencies in x direction
  !  ky                           = fourier frequencies in y direction
  !  kz                           = fourier frequencies in z direction
  !  x                            = x locations
  !  y                            = y locations
  !  z                            = y locations
  !  time                         = times at which save data
  !  name_config          = array to store filename for data to be saved
  !
  ! REFERENCES
  !
  ! A. Shapiro " The use of an exact solution of the Navier-Stokes equations
  ! in a validation test of a three-dimensional nonhydrostatic numerical model"
  ! Monthly Weather Review vol. 121, 2420-2425, (1993).
  !
  ! ACKNOWLEDGEMENTS
  !
  ! ACCURACY
  !
  ! ERROR INDICATORS AND WARNINGS
  !
  ! FURTHER COMMENTS
  !
  ! This program has not been optimized to use the least amount of memory
  ! but is intended as an example only for which all states can be saved
  !
  !--------------------------------------------------------------------------------
  ! External routines required
  !
  ! External libraries required
  ! 2DECOMP&FFT -- Fast Fourier Transform in the West Library
  !                       (http://2decomp.org/)

  !---------------------------------------------------------------------------------

  USE decomp_2d
  USE decomp_2d_fft
  USE decomp_2d_io
  USE MPI
  !coprocessing:
  use NSadaptor_module
  IMPLICIT NONE
  ! declare variables
  INTEGER(kind=4), PARAMETER              :: Nx=256
  INTEGER(kind=4), PARAMETER              :: Ny=256
  INTEGER(kind=4), PARAMETER              :: Nz=256
  INTEGER(kind=4), PARAMETER              :: Lx=1
  INTEGER(kind=4), PARAMETER              :: Ly=1
  INTEGER(kind=4), PARAMETER              :: Lz=1
  INTEGER(kind=4), PARAMETER              :: Nt=20
  REAL(kind=8), PARAMETER                 :: dt=0.05d0/Nt
  REAL(kind=8), PARAMETER                 :: Re=1.0d0
  REAL(kind=8), PARAMETER                 :: tol=0.1d0**10
  REAL(kind=8), PARAMETER                 :: theta=0.0d0

  REAL(kind=8), PARAMETER &
       ::  pi=3.14159265358979323846264338327950288419716939937510d0
  REAL(kind=8), PARAMETER         ::      ReInv=1.0d0/REAL(Re,kind(0d0))
  REAL(kind=8), PARAMETER         ::  dtInv=1.0d0/REAL(dt,kind(0d0))
  REAL(kind=8)                            :: scalemodes,chg,factor
  REAL(kind=8), DIMENSION(:), ALLOCATABLE                 :: x, y, z, time,mychg,allchg
  COMPLEX(kind=8), DIMENSION(:,:,:), ALLOCATABLE  :: u, v, w,&
       ux, uy, uz,&
       vx, vy, vz,&
       wx, wy, wz,&
       uold, uxold, uyold, uzold,&
       vold, vxold, vyold, vzold,&
       wold, wxold, wyold, wzold,&
       utemp, vtemp, wtemp, temp_r

  COMPLEX(kind=8), DIMENSION(:), ALLOCATABLE      ::      kx, ky, kz
  COMPLEX(kind=8), DIMENSION(:,:,:), ALLOCATABLE  ::      uhat, vhat, what,&
       rhsuhatfix, rhsvhatfix,&
       rhswhatfix, nonlinuhat,&
       nonlinvhat, nonlinwhat,&
       phat,temp_c
  !coprocessing: added x,y,z component arrays also halos
  !coprocessing: halos get allocated inside call to update_halo
  REAL(kind=8), DIMENSION(:,:,:), ALLOCATABLE     ::  realtemp, realtempx, &
       realtempy, realtempz, tempxhalo, tempyhalo, tempzhalo
  !coprocessing: added 1D array for passing to C++
  real(kind=8), dimension(:), allocatable :: xpass2c, ypass2c, zpass2c
  ! MPI and 2DECOMP variables
  TYPE(DECOMP_INFO)                               ::  decomp
  INTEGER(kind=MPI_OFFSET_KIND)                   ::  filesize, disp
  INTEGER(kind=4)                                 ::  p_row=0, p_col=0, numprocs, myid, ierr

  ! variables used for saving data and timing
  INTEGER(kind=4)                                 :: count, iol
  INTEGER(kind=4)                                 :: i,j,k,n,t,allocatestatus
  INTEGER(kind=4)                                 :: ind, numberfile
  CHARACTER*100                                   :: name_config
  INTEGER(kind=4)                                 :: start, finish, count_rate

  ! initialisation of 2DECOMP&FFT
  CALL MPI_INIT(ierr)
  CALL MPI_COMM_SIZE(MPI_COMM_WORLD, numprocs, ierr)
  CALL MPI_COMM_RANK(MPI_COMM_WORLD, myid, ierr)
  ! do automatic domain decomposition
  CALL decomp_2d_init(Nx,Ny,Nz,p_row,p_col)
  ! get information about domain decomposition choosen
  CALL decomp_info_init(Nx,Ny,Nz,decomp)
  ! initialise FFT library
  CALL decomp_2d_fft_init
  IF (myid.eq.0) THEN
     PRINT *,'Grid:',Nx,'X',Ny,'Y',Nz,'Z'
     PRINT *,'dt:',dt
  END IF

  ALLOCATE(x(1:Nx),y(1:Ny),z(1:Nz),time(1:Nt+1),mychg(1:3),allchg(1:3),&
       u(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       v(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       w(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       ux(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       uy(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       uz(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       vx(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       vy(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       vz(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       wx(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       wy(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       wz(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       uold(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       uxold(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       uyold(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       uzold(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       vold(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       vxold(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       vyold(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       vzold(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       wold(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       wxold(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       wyold(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       wzold(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       utemp(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       vtemp(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       wtemp(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       temp_r(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       kx(1:Nx),ky(1:Ny),kz(1:Nz),&
       uhat(decomp%zst(1):decomp%zen(1),&
       decomp%zst(2):decomp%zen(2),&
       decomp%zst(3):decomp%zen(3)),&
       vhat(decomp%zst(1):decomp%zen(1),&
       decomp%zst(2):decomp%zen(2),&
       decomp%zst(3):decomp%zen(3)),&
       what(decomp%zst(1):decomp%zen(1),&
       decomp%zst(2):decomp%zen(2),&
       decomp%zst(3):decomp%zen(3)),&
       rhsuhatfix(decomp%zst(1):decomp%zen(1),&
       decomp%zst(2):decomp%zen(2),&
       decomp%zst(3):decomp%zen(3)),&
       rhsvhatfix(decomp%zst(1):decomp%zen(1),&
       decomp%zst(2):decomp%zen(2),&
       decomp%zst(3):decomp%zen(3)),&
       rhswhatfix(decomp%zst(1):decomp%zen(1),&
       decomp%zst(2):decomp%zen(2),&
       decomp%zst(3):decomp%zen(3)),&
       nonlinuhat(decomp%zst(1):decomp%zen(1),&
       decomp%zst(2):decomp%zen(2),&
       decomp%zst(3):decomp%zen(3)),&
       nonlinvhat(decomp%zst(1):decomp%zen(1),&
       decomp%zst(2):decomp%zen(2),&
       decomp%zst(3):decomp%zen(3)),&
       nonlinwhat(decomp%zst(1):decomp%zen(1),&
       decomp%zst(2):decomp%zen(2),&
       decomp%zst(3):decomp%zen(3)),&
       phat(decomp%zst(1):decomp%zen(1),&
       decomp%zst(2):decomp%zen(2),&
       decomp%zst(3):decomp%zen(3)),&
       temp_c(decomp%zst(1):decomp%zen(1),&
       decomp%zst(2):decomp%zen(2),&
       decomp%zst(3):decomp%zen(3)),&
       realtemp(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       realtempx(decomp%xst(1):decomp%xen(1), &
       decomp%xst(2):decomp%xen(2), &
       decomp%xst(3):decomp%xen(3)),&
       realtempy(decomp%xst(1):decomp%xen(1), &
       decomp%xst(2):decomp%xen(2), &
       decomp%xst(3):decomp%xen(3)),&
       realtempz(decomp%xst(1):decomp%xen(1), &
       decomp%xst(2):decomp%xen(2), &
       decomp%xst(3):decomp%xen(3)),&
       stat=AllocateStatus)
  IF (AllocateStatus .ne. 0) STOP
  IF (myid.eq.0) THEN
     PRINT *,'allocated space'
  END IF

  ! setup fourier frequencies in x-direction
  DO i=1,Nx/2+1
     kx(i)= cmplx(0.0d0,1.0d0)*REAL(i-1,kind(0d0))/Lx
  END DO
  kx(1+Nx/2)=0.0d0
  DO i = 1,Nx/2 -1
     kx(i+1+Nx/2)=-kx(1-i+Nx/2)
  END DO
  ind=1
  DO i=-Nx/2,Nx/2-1
     x(ind)=2.0d0*pi*REAL(i,kind(0d0))*Lx/REAL(Nx,kind(0d0))
     ind=ind+1
  END DO
  ! setup fourier frequencies in y-direction
  DO j=1,Ny/2+1
     ky(j)= cmplx(0.0d0,1.0d0)*REAL(j-1,kind(0d0))/Ly
  END DO
  ky(1+Ny/2)=0.0d0
  DO j = 1,Ny/2 -1
     ky(j+1+Ny/2)=-ky(1-j+Ny/2)
  END DO
  ind=1
  DO j=-Ny/2,Ny/2-1
     y(ind)=2.0d0*pi*REAL(j,kind(0d0))*Ly/REAL(Ny,kind(0d0))
     ind=ind+1
  END DO
  ! setup fourier frequencies in z-direction
  DO k=1,Nz/2+1
     kz(k)= cmplx(0.0d0,1.0d0)*REAL(k-1,kind(0d0))/Lz
  END DO
  kz(1+Nz/2)=0.0d0
  DO k = 1,Nz/2 -1
     kz(k+1+Nz/2)=-kz(1-k+Nz/2)
  END DO
  ind=1
  DO k=-Nz/2,Nz/2-1
     z(ind)=2.0d0*pi*REAL(k,kind(0d0))*Lz/REAL(Nz,kind(0d0))
     ind=ind+1
  END DO
  scalemodes=1.0d0/REAL(Nx*Ny*Nz,kind(0d0))
  IF (myid.eq.0) THEN
     PRINT *,'Setup grid and fourier frequencies'
  END IF

  !initial conditions for Taylor-Green vortex
  !       factor=2.0d0/sqrt(3.0d0)
  !       DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
  !               u(i,j,k)=factor*sin(theta+2.0d0*pi/3.0d0)*sin(x(i))*cos(y(j))*cos(z(k))
  !       END DO; END DO; END DO
  !       DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
  !               v(i,j,k)=factor*sin(theta-2.0d0*pi/3.0d0)*cos(x(i))*sin(y(j))*cos(z(k))
  !       END DO ; END DO ; END DO
  !       DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
  !               w(i,j,k)=factor*sin(theta)*cos(x(i))*cos(y(j))*sin(z(k))
  !       END DO ; END DO ; END DO

  time(1)=0.0d0
  factor=sqrt(3.0d0)
  DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
     u(i,j,k)=-0.5*( factor*cos(x(i))*sin(y(j))*sin(z(k))&
          +sin(x(i))*cos(y(j))*cos(z(k)) )*exp(-(factor**2)*time(1)/Re)
  END DO; END DO; END DO
  DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
     v(i,j,k)=0.5*(  factor*sin(x(i))*cos(y(j))*sin(z(k))&
          -cos(x(i))*sin(y(j))*cos(z(k)) )*exp(-(factor**2)*time(1)/Re)
  END DO; END DO ; END DO
  DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
     w(i,j,k)=cos(x(i))*cos(y(j))*sin(z(k))*exp(-(factor**2)*time(1)/Re)
  END DO; END DO ; END DO

  CALL decomp_2d_fft_3d(u,uhat,DECOMP_2D_FFT_FORWARD)
  CALL decomp_2d_fft_3d(v,vhat,DECOMP_2D_FFT_FORWARD)
  CALL decomp_2d_fft_3d(w,what,DECOMP_2D_FFT_FORWARD)

  ! derivative of u with respect to x, y, and z
  DO k=decomp%zst(3),decomp%zen(3) ; DO j=decomp%zst(2),decomp%zen(2) ; DO i=decomp%zst(1),decomp%zen(1)
     temp_c(i,j,k)=uhat(i,j,k)*kx(i)*scalemodes
  END DO; END DO ; END DO
  CALL decomp_2d_fft_3d(temp_c,ux,DECOMP_2D_FFT_BACKWARD)
  DO k=decomp%zst(3),decomp%zen(3) ; DO j=decomp%zst(2),decomp%zen(2) ; DO i=decomp%zst(1),decomp%zen(1)
     temp_c(i,j,k)=uhat(i,j,k)*ky(j)*scalemodes
  END DO; END DO ; END DO
  CALL decomp_2d_fft_3d(temp_c,uy,DECOMP_2D_FFT_BACKWARD)
  DO k=decomp%zst(3),decomp%zen(3) ; DO j=decomp%zst(2),decomp%zen(2) ; DO i=decomp%zst(1),decomp%zen(1)
     temp_c(i,j,k)=uhat(i,j,k)*kz(k)*scalemodes
  END DO; END DO ; END DO
  CALL decomp_2d_fft_3d(temp_c,uz,DECOMP_2D_FFT_BACKWARD)

  ! derivative of v with respect to x, y, and z
  DO k=decomp%zst(3),decomp%zen(3) ; DO j=decomp%zst(2),decomp%zen(2) ; DO i=decomp%zst(1),decomp%zen(1)
     temp_c(i,j,k)=vhat(i,j,k)*kx(i)*scalemodes
  END DO; END DO ; END DO
  CALL decomp_2d_fft_3d(temp_c,vx,DECOMP_2D_FFT_BACKWARD)
  DO k=decomp%zst(3),decomp%zen(3) ; DO j=decomp%zst(2),decomp%zen(2) ; DO i=decomp%zst(1),decomp%zen(1)
     temp_c(i,j,k)=vhat(i,j,k)*ky(j)*scalemodes
  END DO; END DO ; END DO
  CALL decomp_2d_fft_3d(temp_c,vy,DECOMP_2D_FFT_BACKWARD)
  DO k=decomp%zst(3),decomp%zen(3) ; DO j=decomp%zst(2),decomp%zen(2) ; DO i=decomp%zst(1),decomp%zen(1)
     temp_c(i,j,k)=vhat(i,j,k)*kz(k)*scalemodes
  END DO; END DO ; END DO
  CALL decomp_2d_fft_3d(temp_c,vz,DECOMP_2D_FFT_BACKWARD)

  ! derivative of w with respect to x, y, and z
  DO k=decomp%zst(3),decomp%zen(3) ; DO j=decomp%zst(2),decomp%zen(2) ; DO i=decomp%zst(1),decomp%zen(1)
     temp_c(i,j,k)=what(i,j,k)*kx(i)*scalemodes
  END DO; END DO ; END DO
  CALL decomp_2d_fft_3d(temp_c,wx,DECOMP_2D_FFT_BACKWARD)
  DO k=decomp%zst(3),decomp%zen(3) ; DO j=decomp%zst(2),decomp%zen(2) ; DO i=decomp%zst(1),decomp%zen(1)
     temp_c(i,j,k)=what(i,j,k)*ky(j)*scalemodes
  END DO; END DO ; END DO
  CALL decomp_2d_fft_3d(temp_c,wy,DECOMP_2D_FFT_BACKWARD)
  DO k=decomp%zst(3),decomp%zen(3) ; DO j=decomp%zst(2),decomp%zen(2) ; DO i=decomp%zst(1),decomp%zen(1)
     temp_c(i,j,k)=what(i,j,k)*kz(k)*scalemodes
  END DO; END DO ; END DO
  CALL decomp_2d_fft_3d(temp_c,wz,DECOMP_2D_FFT_BACKWARD)

  ! save initial data
  n = 0
  !coprocessing: removed savedata calls from coprocessing version
  !coprocessing: could have this after the coprocessor initialize and
  !coprocessing: followed by a call to the coprocessor to write out the initial data
  !coprocessing: image. Otherwise, these are just wasted calls at this spot.
  call coprocessorinitialize("pipeline.py", 11)

  DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
     realtempx(i,j,k)=REAL(wy(i,j,k)-vz(i,j,k),KIND=8)
  END DO; END DO ; END DO
  call update_halo(realtempx, tempxhalo, level=1)

  DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
     realtempy(i,j,k)=REAL(uz(i,j,k)-wx(i,j,k),KIND=8)
  END DO; END DO ; END DO
  call update_halo(realtempy, tempyhalo, level=1)

  DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
     realtempz(i,j,k)=REAL(vx(i,j,k)-uy(i,j,k),KIND=8)
  END DO; END DO ; END DO
  call update_halo(realtempz, tempzhalo, level=1)

  !coprocessing: Four cases of sending halo data to the coprocessor.
  if ((ny_global == decomp%xen(2)) .and. (nz_global == decomp%xen(3))) then
     !coprocessing: case 1: pencil furthest from index origin, send just the pencil
     allocate(xpass2c(decomp%xsz(1)*decomp%xsz(2)*decomp%xsz(3)))
     allocate(ypass2c(decomp%xsz(1)*decomp%xsz(2)*decomp%xsz(3)))
     allocate(zpass2c(decomp%xsz(1)*decomp%xsz(2)*decomp%xsz(3)))
     xpass2c = reshape(tempxhalo(:,1:decomp%xsz(2),1:decomp%xsz(3)),(/size(xpass2c)/))
     ypass2c = reshape(tempyhalo(:,1:decomp%xsz(2),1:decomp%xsz(3)),(/size(ypass2c)/))
     zpass2c = reshape(tempzhalo(:,1:decomp%xsz(2),1:decomp%xsz(3)),(/size(zpass2c)/))
     call NSadaptor(Nx,Ny,Nz,decomp%xst(1),decomp%xen(1), &
          decomp%xst(2),decomp%xen(2),decomp%xst(3),decomp%xen(3), n, n*dt, &
          xpass2c, ypass2c, zpass2c)
     deallocate(xpass2c, ypass2c, zpass2c)
  else if ((ny_global > decomp%xen(2)) .and. (nz_global == decomp%xen(3))) then
     !coprocessing: case 2: pencil furthest in z, send just upper y halo
     allocate(xpass2c(decomp%xsz(1)*(decomp%xsz(2)+1)*decomp%xsz(3)))
     allocate(ypass2c(decomp%xsz(1)*(decomp%xsz(2)+1)*decomp%xsz(3)))
     allocate(zpass2c(decomp%xsz(1)*(decomp%xsz(2)+1)*decomp%xsz(3)))
     xpass2c = reshape(tempxhalo(:,1:decomp%xsz(2)+1,1:decomp%xsz(3)),(/size(xpass2c)/))
     ypass2c = reshape(tempyhalo(:,1:decomp%xsz(2)+1,1:decomp%xsz(3)),(/size(ypass2c)/))
     zpass2c = reshape(tempzhalo(:,1:decomp%xsz(2)+1,1:decomp%xsz(3)),(/size(zpass2c)/))
     call NSadaptor(Nx,Ny,Nz,decomp%xst(1),decomp%xen(1), &
          decomp%xst(2),decomp%xen(2)+1,decomp%xst(3),decomp%xen(3), n, n*dt, &
          xpass2c, ypass2c, zpass2c)
     deallocate(xpass2c, ypass2c, zpass2c)
  else if ((ny_global == decomp%xen(2)) .and. (nz_global > decomp%xen(3))) then
     !coprocessing: case 3: pencil furthest in y, send just upper z halo
     allocate(xpass2c(decomp%xsz(1)*decomp%xsz(2)*(decomp%xsz(3)+1)))
     allocate(ypass2c(decomp%xsz(1)*decomp%xsz(2)*(decomp%xsz(3)+1)))
     allocate(zpass2c(decomp%xsz(1)*decomp%xsz(2)*(decomp%xsz(3)+1)))
     xpass2c = reshape(tempxhalo(:,1:decomp%xsz(2),1:decomp%xsz(3)+1),(/size(xpass2c)/))
     ypass2c = reshape(tempyhalo(:,1:decomp%xsz(2),1:decomp%xsz(3)+1),(/size(ypass2c)/))
     zpass2c = reshape(tempzhalo(:,1:decomp%xsz(2),1:decomp%xsz(3)+1),(/size(zpass2c)/))
     call NSadaptor(Nx,Ny,Nz,decomp%xst(1),decomp%xen(1), &
          decomp%xst(2),decomp%xen(2),decomp%xst(3),decomp%xen(3)+1, n, n*dt, &
          xpass2c, ypass2c, zpass2c)
     deallocate(xpass2c, ypass2c, zpass2c)
  else
     !coprocessing: case 4: send both upper y and upper z halo
     allocate(xpass2c(decomp%xsz(1)*(decomp%xsz(2)+1)*(decomp%xsz(3)+1)))
     allocate(ypass2c(decomp%xsz(1)*(decomp%xsz(2)+1)*(decomp%xsz(3)+1)))
     allocate(zpass2c(decomp%xsz(1)*(decomp%xsz(2)+1)*(decomp%xsz(3)+1)))
     xpass2c = reshape(tempxhalo(:,1:decomp%xsz(2)+1,1:decomp%xsz(3)+1),(/size(xpass2c)/))
     ypass2c = reshape(tempyhalo(:,1:decomp%xsz(2)+1,1:decomp%xsz(3)+1),(/size(ypass2c)/))
     zpass2c = reshape(tempzhalo(:,1:decomp%xsz(2)+1,1:decomp%xsz(3)+1),(/size(zpass2c)/))
     call NSadaptor(Nx,Ny,Nz,decomp%xst(1),decomp%xen(1), &
          decomp%xst(2),decomp%xen(2)+1,decomp%xst(3),decomp%xen(3)+1,n,n*dt, &
          xpass2c, ypass2c, zpass2c)
     deallocate(xpass2c,ypass2c,zpass2c)
  end if

  !start timer
  CALL system_clock(start,count_rate)
  ! coprocessing: Simulation loop starts here
  DO n=1,Nt
     !fixed point
     DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
        uold(i,j,k)=u(i,j,k)
        uxold(i,j,k)=ux(i,j,k)
        uyold(i,j,k)=uy(i,j,k)
        uzold(i,j,k)=uz(i,j,k)
     END DO; END DO ; END DO
     DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
        vold(i,j,k)=v(i,j,k)
        vxold(i,j,k)=vx(i,j,k)
        vyold(i,j,k)=vy(i,j,k)
        vzold(i,j,k)=vz(i,j,k)
     END DO; END DO ; END DO
     DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
        wold(i,j,k)=w(i,j,k)
        wxold(i,j,k)=wx(i,j,k)
        wyold(i,j,k)=wy(i,j,k)
        wzold(i,j,k)=wz(i,j,k)
     END DO; END DO ; END DO
     DO k=decomp%zst(3),decomp%zen(3) ; DO j=decomp%zst(2),decomp%zen(2) ; DO i=decomp%zst(1),decomp%zen(1)
        rhsuhatfix(i,j,k) = (dtInv+(0.5*ReInv)*(kx(i)*kx(i)+ky(j)*ky(j)+kz(k)*kz(k)))*uhat(i,j,k)
     END DO; END DO ; END DO
     DO k=decomp%zst(3),decomp%zen(3) ; DO j=decomp%zst(2),decomp%zen(2) ; DO i=decomp%zst(1),decomp%zen(1)
        rhsvhatfix(i,j,k) = (dtInv+(0.5*ReInv)*(kx(i)*kx(i)+ky(j)*ky(j)+kz(k)*kz(k)))*vhat(i,j,k)
     END DO; END DO ; END DO
     DO k=decomp%zst(3),decomp%zen(3) ; DO j=decomp%zst(2),decomp%zen(2) ; DO i=decomp%zst(1),decomp%zen(1)
        rhswhatfix(i,j,k) = (dtInv+(0.5*ReInv)*(kx(i)*kx(i)+ky(j)*ky(j)+kz(k)*kz(k)))*what(i,j,k)
     END DO; END DO ; END DO

     chg=1
     DO WHILE (chg .gt. tol)
        DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
           temp_r(i,j,k)=0.25d0*((u(i,j,k)+uold(i,j,k))*(ux(i,j,k)+uxold(i,j,k))&
                +(v(i,j,k)+vold(i,j,k))*(uy(i,j,k)+uyold(i,j,k))&
                +(w(i,j,k)+wold(i,j,k))*(uz(i,j,k)+uzold(i,j,k)))
        END DO; END DO ; END DO
        CALL decomp_2d_fft_3d(temp_r,nonlinuhat,DECOMP_2D_FFT_FORWARD)
        DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
           temp_r(i,j,k)=0.25d0*((u(i,j,k)+uold(i,j,k))*(vx(i,j,k)+vxold(i,j,k))&
                +(v(i,j,k)+vold(i,j,k))*(vy(i,j,k)+vyold(i,j,k))&
                +(w(i,j,k)+wold(i,j,k))*(vz(i,j,k)+vzold(i,j,k)))
        END DO; END DO ; END DO
        CALL decomp_2d_fft_3d(temp_r,nonlinvhat,DECOMP_2D_FFT_FORWARD)
        DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
           temp_r(i,j,k)=0.25d0*((u(i,j,k)+uold(i,j,k))*(wx(i,j,k)+wxold(i,j,k))&
                +(v(i,j,k)+vold(i,j,k))*(wy(i,j,k)+wyold(i,j,k))&
                +(w(i,j,k)+wold(i,j,k))*(wz(i,j,k)+wzold(i,j,k)))
        END DO; END DO ; END DO
        CALL decomp_2d_fft_3d(temp_r,nonlinwhat,DECOMP_2D_FFT_FORWARD)
        DO k=decomp%zst(3),decomp%zen(3) ; DO j=decomp%zst(2),decomp%zen(2) ; DO i=decomp%zst(1),decomp%zen(1)
           phat(i,j,k)=-1.0d0*( kx(i)*nonlinuhat(i,j,k)&
                +ky(j)*nonlinvhat(i,j,k)&
                +kz(k)*nonlinwhat(i,j,k))&
                /(kx(i)*kx(i)+ky(j)*ky(j)+kz(k)*kz(k)+0.1d0**13)
        END DO; END DO ; END DO

        DO k=decomp%zst(3),decomp%zen(3) ; DO j=decomp%zst(2),decomp%zen(2) ; DO i=decomp%zst(1),decomp%zen(1)
           uhat(i,j,k)=(rhsuhatfix(i,j,k)-nonlinuhat(i,j,k)-kx(i)*phat(i,j,k))/&
                (dtInv-(0.5d0*ReInv)*(kx(i)*kx(i)+ky(j)*ky(j)+kz(k)*kz(k))) !*scalemodes
        END DO; END DO ; END DO
        DO k=decomp%zst(3),decomp%zen(3) ; DO j=decomp%zst(2),decomp%zen(2) ; DO i=decomp%zst(1),decomp%zen(1)
           vhat(i,j,k)=(rhsvhatfix(i,j,k)-nonlinvhat(i,j,k)-ky(j)*phat(i,j,k))/&
                (dtInv-(0.5d0*ReInv)*(kx(i)*kx(i)+ky(j)*ky(j)+kz(k)*kz(k))) !*scalemodes
        END DO; END DO ; END DO
        DO k=decomp%zst(3),decomp%zen(3) ; DO j=decomp%zst(2),decomp%zen(2) ; DO i=decomp%zst(1),decomp%zen(1)
           what(i,j,k)=(rhswhatfix(i,j,k)-nonlinwhat(i,j,k)-kz(k)*phat(i,j,k))/&
                (dtInv-(0.5d0*ReInv)*(kx(i)*kx(i)+ky(j)*ky(j)+kz(k)*kz(k))) !*scalemodes
        END DO; END DO ; END DO

        ! derivative of u with respect to x, y, and z
        DO k=decomp%zst(3),decomp%zen(3) ; DO j=decomp%zst(2),decomp%zen(2) ; DO i=decomp%zst(1),decomp%zen(1)
           temp_c(i,j,k)=uhat(i,j,k)*kx(i)*scalemodes
        END DO; END DO ; END DO
        CALL decomp_2d_fft_3d(temp_c,ux,DECOMP_2D_FFT_BACKWARD)
        DO k=decomp%zst(3),decomp%zen(3); DO j=decomp%zst(2),decomp%zen(2) ; DO i=decomp%zst(1),decomp%zen(1)
           temp_c(i,j,k)=uhat(i,j,k)*ky(j)*scalemodes
        END DO; END DO ; END DO
        CALL decomp_2d_fft_3d(temp_c,uy,DECOMP_2D_FFT_BACKWARD)
        DO k=decomp%zst(3),decomp%zen(3); DO j=decomp%zst(2),decomp%zen(2) ; DO i=decomp%zst(1),decomp%zen(1)
           temp_c(i,j,k)=uhat(i,j,k)*kz(k)*scalemodes
        END DO; END DO ; END DO
        CALL decomp_2d_fft_3d(temp_c,uz,DECOMP_2D_FFT_BACKWARD)

        ! derivative of v with respect to x, y, and z
        DO k=decomp%zst(3),decomp%zen(3) ; DO j=decomp%zst(2),decomp%zen(2) ; DO i=decomp%zst(1),decomp%zen(1)
           temp_c(i,j,k)=vhat(i,j,k)*kx(i)*scalemodes
        END DO; END DO ; END DO
        CALL decomp_2d_fft_3d(temp_c,vx,DECOMP_2D_FFT_BACKWARD)
        DO k=decomp%zst(3),decomp%zen(3); DO j=decomp%zst(2),decomp%zen(2) ; DO i=decomp%zst(1),decomp%zen(1)
           temp_c(i,j,k)=vhat(i,j,k)*ky(j)*scalemodes
        END DO; END DO ; END DO
        CALL decomp_2d_fft_3d(temp_c,vy,DECOMP_2D_FFT_BACKWARD)
        DO k=decomp%zst(3),decomp%zen(3) ; DO j=decomp%zst(2),decomp%zen(2) ; DO i=decomp%zst(1),decomp%zen(1)
           temp_c(i,j,k)=vhat(i,j,k)*kz(k)*scalemodes
        END DO; END DO ; END DO
        CALL decomp_2d_fft_3d(temp_c,vz,DECOMP_2D_FFT_BACKWARD)

        ! derivative of w with respect to x, y, and z
        DO k=decomp%zst(3),decomp%zen(3) ; DO j=decomp%zst(2),decomp%zen(2) ; DO i=decomp%zst(1),decomp%zen(1)
           temp_c(i,j,k)=what(i,j,k)*kx(i)*scalemodes
        END DO; END DO ; END DO
        CALL decomp_2d_fft_3d(temp_c,wx,DECOMP_2D_FFT_BACKWARD)
        DO k=decomp%zst(3),decomp%zen(3) ; DO j=decomp%zst(2),decomp%zen(2) ; DO i=decomp%zst(1),decomp%zen(1)
           temp_c(i,j,k)=what(i,j,k)*ky(j)*scalemodes
        END DO; END DO ; END DO
        CALL decomp_2d_fft_3d(temp_c,wy,DECOMP_2D_FFT_BACKWARD)
        DO k=decomp%zst(3),decomp%zen(3) ; DO j=decomp%zst(2),decomp%zen(2) ; DO i=decomp%zst(1),decomp%zen(1)
           temp_c(i,j,k)=what(i,j,k)*kz(k)*scalemodes
        END DO; END DO ; END DO
        CALL decomp_2d_fft_3d(temp_c,wz,DECOMP_2D_FFT_BACKWARD)

        DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
           utemp(i,j,k)=u(i,j,k)
        END DO; END DO ; END DO
        DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
           vtemp(i,j,k)=v(i,j,k)
        END DO; END DO ; END DO
        DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
           wtemp(i,j,k)=w(i,j,k)
        END DO; END DO ; END DO

        CALL decomp_2d_fft_3d(uhat,u,DECOMP_2D_FFT_BACKWARD)
        CALL decomp_2d_fft_3d(vhat,v,DECOMP_2D_FFT_BACKWARD)
        CALL decomp_2d_fft_3d(what,w,DECOMP_2D_FFT_BACKWARD)

        DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
           u(i,j,k)=u(i,j,k)*scalemodes
        END DO; END DO ; END DO
        DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
           v(i,j,k)=v(i,j,k)*scalemodes
        END DO; END DO ; END DO
        DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
           w(i,j,k)=w(i,j,k)*scalemodes
        END DO; END DO ; END DO

        mychg(1) =maxval(abs(utemp-u))
        mychg(2) =maxval(abs(vtemp-v))
        mychg(3) =maxval(abs(wtemp-w))
        CALL MPI_ALLREDUCE(mychg,allchg,3,MPI_DOUBLE_PRECISION,MPI_MAX,MPI_COMM_WORLD,ierr)
        chg=allchg(1)+allchg(2)+allchg(3)
        IF (myid.eq.0) THEN
           PRINT *,'chg:',chg
        END IF
     END DO
     time(n+1)=n*dt

     !goto 5100
     IF (myid.eq.0) THEN
        PRINT *,'time',n*dt
     END IF

     !coprocessing: populating the arrays sent to the coprocessor
     DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
        realtempx(i,j,k)=REAL(wy(i,j,k)-vz(i,j,k),KIND=8)
     END DO; END DO ; END DO
     call update_halo(realtempx, tempxhalo, level=1)

     DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
        realtempy(i,j,k)=REAL(uz(i,j,k)-wx(i,j,k),KIND=8)
     END DO; END DO ; END DO
     call update_halo(realtempy, tempyhalo, level=1)

     DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
        realtempz(i,j,k)=REAL(vx(i,j,k)-uy(i,j,k),KIND=8)
     END DO; END DO ; END DO
     call update_halo(realtempz, tempzhalo, level=1)

     !coprocessing: same cases as for initial conditions.
     if ((ny_global == decomp%xen(2)) .and. (nz_global == decomp%xen(3))) then
        ! case 1: send just the pencil
        allocate(xpass2c(decomp%xsz(1)*decomp%xsz(2)*decomp%xsz(3)))
        allocate(ypass2c(decomp%xsz(1)*decomp%xsz(2)*decomp%xsz(3)))
        allocate(zpass2c(decomp%xsz(1)*decomp%xsz(2)*decomp%xsz(3)))
        xpass2c = reshape(tempxhalo(:,1:decomp%xsz(2),1:decomp%xsz(3)),(/size(xpass2c)/))
        ypass2c = reshape(tempyhalo(:,1:decomp%xsz(2),1:decomp%xsz(3)),(/size(ypass2c)/))
        zpass2c = reshape(tempzhalo(:,1:decomp%xsz(2),1:decomp%xsz(3)),(/size(zpass2c)/))
        call NSadaptor(Nx,Ny,Nz,decomp%xst(1),decomp%xen(1), &
             decomp%xst(2),decomp%xen(2),decomp%xst(3),decomp%xen(3), n, n*dt, &
             xpass2c, ypass2c, zpass2c)
        deallocate(xpass2c, ypass2c, zpass2c)
     else if ((ny_global > decomp%xen(2)) .and. (nz_global == decomp%xen(3))) then
        ! case 2: send just upper y halo
        allocate(xpass2c(decomp%xsz(1)*(decomp%xsz(2)+1)*decomp%xsz(3)))
        allocate(ypass2c(decomp%xsz(1)*(decomp%xsz(2)+1)*decomp%xsz(3)))
        allocate(zpass2c(decomp%xsz(1)*(decomp%xsz(2)+1)*decomp%xsz(3)))
        xpass2c = reshape(tempxhalo(:,1:decomp%xsz(2)+1,1:decomp%xsz(3)),(/size(xpass2c)/))
        ypass2c = reshape(tempyhalo(:,1:decomp%xsz(2)+1,1:decomp%xsz(3)),(/size(ypass2c)/))
        zpass2c = reshape(tempzhalo(:,1:decomp%xsz(2)+1,1:decomp%xsz(3)),(/size(zpass2c)/))
        call NSadaptor(Nx,Ny,Nz,decomp%xst(1),decomp%xen(1), &
             decomp%xst(2),decomp%xen(2)+1,decomp%xst(3),decomp%xen(3), n, n*dt, &
             xpass2c, ypass2c, zpass2c)
        deallocate(xpass2c, ypass2c, zpass2c)
     else if ((ny_global == decomp%xen(2)) .and. (nz_global > decomp%xen(3))) then
        ! case 3: send just upper z halo
        allocate(xpass2c(decomp%xsz(1)*decomp%xsz(2)*(decomp%xsz(3)+1)))
        allocate(ypass2c(decomp%xsz(1)*decomp%xsz(2)*(decomp%xsz(3)+1)))
        allocate(zpass2c(decomp%xsz(1)*decomp%xsz(2)*(decomp%xsz(3)+1)))
        xpass2c = reshape(tempxhalo(:,1:decomp%xsz(2),1:decomp%xsz(3)+1),(/size(xpass2c)/))
        ypass2c = reshape(tempyhalo(:,1:decomp%xsz(2),1:decomp%xsz(3)+1),(/size(ypass2c)/))
        zpass2c = reshape(tempzhalo(:,1:decomp%xsz(2),1:decomp%xsz(3)+1),(/size(zpass2c)/))
        call NSadaptor(Nx,Ny,Nz,decomp%xst(1),decomp%xen(1), &
             decomp%xst(2),decomp%xen(2),decomp%xst(3),decomp%xen(3)+1, n, n*dt, &
             xpass2c, ypass2c, zpass2c)
        deallocate(xpass2c, ypass2c, zpass2c)
     else
        ! send both upper y and upper z halo
        allocate(xpass2c(decomp%xsz(1)*(decomp%xsz(2)+1)*(decomp%xsz(3)+1)))
        allocate(ypass2c(decomp%xsz(1)*(decomp%xsz(2)+1)*(decomp%xsz(3)+1)))
        allocate(zpass2c(decomp%xsz(1)*(decomp%xsz(2)+1)*(decomp%xsz(3)+1)))
        xpass2c = reshape(tempxhalo(:,1:decomp%xsz(2)+1,1:decomp%xsz(3)+1),(/size(xpass2c)/))
        ypass2c = reshape(tempyhalo(:,1:decomp%xsz(2)+1,1:decomp%xsz(3)+1),(/size(ypass2c)/))
        zpass2c = reshape(tempzhalo(:,1:decomp%xsz(2)+1,1:decomp%xsz(3)+1),(/size(zpass2c)/))
        call NSadaptor(Nx,Ny,Nz,decomp%xst(1),decomp%xen(1), &
             decomp%xst(2),decomp%xen(2)+1,decomp%xst(3),decomp%xen(3)+1,n,n*dt, &
             xpass2c, ypass2c, zpass2c)
        deallocate(xpass2c,ypass2c,zpass2c)
     end if

  END DO
  !coprocessing:
  call coprocessorfinalize()

  CALL system_clock(finish,count_rate)

  IF (myid.eq.0) then
     PRINT *, 'Program took', REAL(finish-start)/REAL(count_rate), 'for main timestepping loop'
  END IF

  IF (myid.eq.0) THEN
     name_config = './data/tdata.dat'
     OPEN(unit=11,FILE=name_config,status="UNKNOWN")
     REWIND(11)
     DO n=1,1+Nt
        WRITE(11,*) time(n)
     END DO
     CLOSE(11)

     name_config = './data/xcoord.dat'
     OPEN(unit=11,FILE=name_config,status="UNKNOWN")
     REWIND(11)
     DO i=1,Nx
        WRITE(11,*) x(i)
     END DO
     CLOSE(11)

     name_config = './data/ycoord.dat'
     OPEN(unit=11,FILE=name_config,status="UNKNOWN")
     REWIND(11)
     DO j=1,Ny
        WRITE(11,*) y(j)
     END DO
     CLOSE(11)

     name_config = './data/zcoord.dat'
     OPEN(unit=11,FILE=name_config,status="UNKNOWN")
     REWIND(11)
     DO k=1,Nz
        WRITE(11,*) z(k)
     END DO
     CLOSE(11)
     PRINT *,'Saved data'
  END IF

  ! Calculate error in final numerical solution
  DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
     utemp(i,j,k)=u(i,j,k) -&
          (-0.5*( factor*cos(x(i))*sin(y(j))*sin(z(k))&
          +sin(x(i))*cos(y(j))*cos(z(k)) )*exp(-(factor**2)*time(Nt+1)/Re))
  END DO; END DO; END DO
  DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
     vtemp(i,j,k)=v(i,j,k) -&
          (0.5*(  factor*sin(x(i))*cos(y(j))*sin(z(k))&
          -cos(x(i))*sin(y(j))*cos(z(k)) )*exp(-(factor**2)*time(Nt+1)/Re))
  END DO; END DO ; END DO
  DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
     wtemp(i,j,k)=w(i,j,k)-&
          (cos(x(i))*cos(y(j))*sin(z(k))*exp(-(factor**2)*time(Nt+1)/Re))
  END DO; END DO ; END DO
  mychg(1) = maxval(abs(utemp))
  mychg(2) = maxval(abs(vtemp))
  mychg(3) = maxval(abs(wtemp))
  CALL MPI_ALLREDUCE(mychg,allchg,3,MPI_DOUBLE_PRECISION,MPI_MAX,MPI_COMM_WORLD,ierr)
  chg=allchg(1)+allchg(2)+allchg(3)
  IF (myid.eq.0) THEN
     PRINT*,'The error at the final timestep is',chg
  END IF

  ! clean up
  CALL decomp_2d_fft_finalize
  CALL decomp_2d_finalize

  DEALLOCATE(x,y,z,time,mychg,allchg,u,v,w,ux,uy,uz,vx,vy,vz,wx,wy,wz,uold,uxold,uyold,uzold,&
       vold,vxold,vyold,vzold,wold,wxold,wyold,wzold,utemp,vtemp,wtemp,&
       temp_r,kx,ky,kz,uhat,vhat,what,rhsuhatfix,rhsvhatfix,&
       rhswhatfix,phat,nonlinuhat,nonlinvhat,nonlinwhat,temp_c,&
       realtemp,stat=AllocateStatus)
  !coprocessing: deallocate Coprocessing specific arrays
  deallocate(realtempx, realtempy, realtempz, tempxhalo, tempyhalo, tempzhalo)
  IF (AllocateStatus .ne. 0) STOP
  IF (myid.eq.0) THEN
     PRINT *,'Program execution complete'
  END IF
  CALL MPI_FINALIZE(ierr)

END PROGRAM main


program Hofstadter
	implicit none !all variables needed to be defined

	!variable decleration
	real :: nu=0,alpha=0,e=0.0,res=0.0,p2,q2,e_step = 0.01
	integer :: qmax=50,countAlpha=0,p,q,i,countE=0,m=1,j
	real, dimension(2,2) :: a,b,mult !2d matrix for array multiplication
	real, dimension(100000) :: alpha_mat !matrix dimension unknown so taking a long one
	logical :: br
	REAL, PARAMETER :: M_PI = 3.1415927 !Approximate value of pi

    print *, "Please enter maximum value of qmax"!Querying for maximum q value
    read (*,*) qmax!maximum q value input from user
    call system('rm gnuOut.txt')!removing gnuOut.txt file if present already
    open(1, file="gnuOut.txt",status="new")!opening gnuOut.txt for storing all the alpha value in gnuplot format

    !****** Main Itteration starting here **********

    do q = 1,qmax !denominator q values
    	do p = 0,q !numerator p values
    		br =.TRUE. !for checking the overlapping condition
    		p2 = p*1.0000 !converting p and q to real variables
    		q2 = q*1.0000
    		alpha = p2/q2 !alpha value calculated here
    		do i = 1, countAlpha!to prevent repetation
    			if(alpha == alpha_mat(i)) then
    				br= .FALSE.!if repeated then next if condition will not proceed
    				EXIT !Exiting when found
    			end if
    		end do
    		if(br) then!continue if alpha value not repeated
    			countAlpha = countAlpha +1 !Alpha count used for indexing the container of all the alpha values required to check overcounting
     			alpha_mat(countAlpha)=alpha!Storing all the alpha values
     			nu = M_PI/(2.0*q)!nu value
     			e=-4.0!starting e value
     			do while(e<=4.0)!itterating over all the e values with increament 0.01
     				m = 1! m value starting form 1 with 1 incrementation

     				!matrix Initialization
     				a(1,1) = e -2*cos(2*M_PI*m*alpha-nu)
     				a(1,2) = -1.0
     				a(2,1) = 1.0
     				a(2,2) = 0.0

     				b(1,1) = e -2*cos(2*M_PI*(m+1)*alpha - nu)
     				b(1,2) = -1.0
     				b(2,1) = 1.0
     				b(2,2) = 0.0

     				do j=1,q-1 !The loop has to only run q-1 times as we have already have A(m=1) and only have to multiply A(m=q)...A(m=2) with it.
     					!setting m = 0
     					mult(1,1) = 0.0
     					mult(1,2) = 0.0
     					mult(2,1) = 0.0
     					mult(2,2) = 0.0

     					call matrixMultiplication(a,b,mult)!a*b =mult matrix operation
     					call equateMatrix(a,mult)! a= mult matrix operation
     					m = m+1
     					b(1,1)= e -2*cos(2*M_PI*(m+1)*alpha - nu)

     				end do
     				call trace(a,res) !finding trace of a and storing it to res
     				if(ABS(res)<=4.0) then!if trace <=4 then e and alpha are written down
     					write(1,*) e, alpha
     				end if
     				e = e+e_step!Incrementation in e
     			end do

    		end if
    	end do
    end do

    print*, "Total number of alpha components are:", countAlpha!Total alpha count displayed

    !**** Plotting it using gnuplot *****
    call system('rm gnuCommands.txt')
    open(2, file="gnuCommands.txt",status="new")
    write(2,*) "set terminal qt enhanced"
    write(2,*) "set key off"
    write(2,*) "set xlabel '{/Symbol e}'"
    write(2,*) "set ylabel '{/Symbol a}'"
    write(2,*) "plot 'gnuOut.txt' w p pt 7 ps 0.05"
    call system("gnuplot gnuCommands.txt --persist")

    close(2)!closing open files
    close(1)
end program Hofstadter

! For finding trace of a 2-d matrix
SUBROUTINE trace(a,res)

implicit none

real, dimension(2,2) :: a
real :: res
integer :: i
res =0
do i=1,2
	res = res + a(i,i)
end do

end SUBROUTINE trace

!a*b=mult operation
SUBROUTINE matrixMultiplication(a,b,mult)

implicit none

real, dimension(2,2) :: a,b,mult
integer :: i,j,k

do i=1,2
	do j=1,2
		do k=1,2
			mult(i,j) = mult(i,j) + a(i,k)*b(k,j)
		end do
	end do
end do

END SUBROUTINE matrixMultiplication

!a=mult Matrix Operation
SUBROUTINE equateMatrix(a,mult)
implicit none

real, dimension(2,2) :: a,mult
integer :: i,j

do i =1,2
	do j=1,2
		a(i,j) = mult(i,j)
	end do
end do

end SUBROUTINE equateMatrix


! Mikayla Webber
! 4670 Numerical Analysis
! Homework G Due 12.1.17

! use at least three numerical methods to solve:
! dy/dt = te^(3t) - 2y
! y(0) = 0
! for 0 <= t <= 2
! for each method obtain at least 100 data points on your approximation and produce a graph for each method.

program extrapall
  implicit none

  integer :: i, neq, nsteps
  double precision :: a, b, dt, tin, tout
  double precision, allocatable, dimension(:, :) :: archive
  double precision, allocatable, dimension(:) :: t, f1, yin, yout

  neq = 1
  a = 0.0d0
  b = 2.0d0
  nsteps = 1000

  allocate(yin(neq), yout(neq), t(0:nsteps), f1(neq), archive(neq,0:nsteps))

  dt = ((b - a) / dble(nsteps))

  do i = 0, nsteps
    t(i) = (a + dble(i) * dt)
  end do

  archive (:,0) = (/ 1.0d0, 0.0d0, 0.0d0, 1.0d0 /) ! initial state vector
  yin = archive(:,0)

  do i = 0, (nsteps - 1)
    tin = t(i)
    tout = t(i + 1)
    yin = archive(:,i)
    call extrapolate(neq, tin, tout, yin, yout)
    archive(:,i+1) = yout
  end do

  print*, 'Creating "out5.2.2"'
  open(unit=8, file='out5.2.2', status='replace')

  do i = 0, nsteps
    write(8,*) t(i), archive(1,i)
  end do

  close(8)
  deallocate(yin, yout, t, f1, archive)

  stop
end program extrapall

!-----------------------------------------------------------------------

subroutine extrapolate(neq, tin, tout, yin, yout)
  implicit none

  integer, intent(in) :: neq
  integer :: i, k, nrich, nsteps
  double precision :: yout(neq), bot
  double precision, intent(in) :: tin, tout, yin(neq)
  double precision, allocatable, dimension(:, :, :) :: table

  nrich = 10
  nsteps = 1
  allocate(table(0:nrich, 0:nrich, neq))

  do i = 0, nrich
    call euler(neq, tin, tout, nsteps, yin, yout)
    table(i,0,:) = yout
    nsteps = (nsteps * 2)
  end do

  do k = 1, nrich
    bot = (2.0d0**k - 1.0d0)
    do i = k, nrich
      table(i,k,:) = (table(i,k-1,:) + (table(i,k-1,:) - table(i-1,k-1,:)) / bot)
    end do
  end do

  yout = table(nrich, nrich, :)
  return
end

!-----------------------------------------------------------------------

subroutine euler(neq, tin, tout, nsteps, yin, yout)
  implicit none

  integer :: i
  integer, intent(in) :: neq, nsteps
  double precision :: yout(neq), f(neq), dt
  double precision, intent(in) :: tin, tout, yin(neq)

  yout = yin
  dt = ((tout - tin)/dble(nsteps))

  do i = 0, (nsteps - 1)
    call computef(neq, (tin + dble(i) * dt), yout, f)
    yout = (yout + dt * f)
  end do

  return
end

!-----------------------------------------------------------------------

subroutine computef(neq, t, y, f)
  implicit none
  integer :: neq
  double precision :: f(neq)
  double precision, intent(in) :: t, y(neq)
  ! This subroutine computes the RHS of the differential equation:
  !  dy
  !  -- = f(t, y)
  !  dt
  ! where y is the array of unknowns, indexed from one to neq and f is the array of right sides.

  f(1) = (t * dexp(3.0d0 * t) - 2.0d0 * y(1))

  return
end


module v_cycle_mod

contains

    recursive subroutine v_cycle(ct,lvl,nlvl)

        use constants
        use multifab_module
        use traverse_mod
        use cycle_tower_mod

        implicit none

        ! Note: nlvl is different than ct%nlvl when in the FMG-cycle, because nlvl
        ! is the number of multigrid levels in whichever "mini" V-cycle is being called by
        ! the FMG-cycle, but ct%nlvl will always be the number of multigrid levels
        ! of the FMG-cycle.
        integer          , intent(in)    :: lvl ! Current multigrid level of this V-cycle
        integer          , intent(in)    :: nlvl ! Total multigrid levels of this V-cycle
        type(cycle_tower), intent(inout) :: ct

        integer :: i

        ! If not at the top, set solution guess to zero; use existing solution guess otherwise
        if (lvl /= nlvl) then
            call setval(ct%uu(lvl),0.d0,all=.true.)
        end if

        if (lvl == 1) then

            if (parallel_IOProcessor()) then
                call print_cycle_tower(ct,lvl,'Before relaxation: ')
                if (ct%verbose >= 2) then
                    write(*,'(a,i3,a)') '    V Cycle BOTTOM -- Applying ',ct%v_bot,' relaxations.'
                end if
            end if

            ! Just smooth a bunch of times at the bottom; can choose different solver here
            do i = 1,ct%v_bot
                call gsrb(ct%uu(lvl),ct%ff(lvl),ct%bb(lvl,:),ct%dx(lvl))
            end do

            if (parallel_IOProcessor()) then
                call print_cycle_tower(ct,lvl,' After relaxation: ')
            end if

        else

            if (parallel_IOProcessor()) then
                call print_cycle_tower(ct,lvl,'Before relaxation: ')
            end if

            ! Smooth on the way down
            do i = 1,ct%s1
                call gsrb(ct%uu(lvl),ct%ff(lvl),ct%bb(lvl,:),ct%dx(lvl))
            end do

            if (parallel_IOProcessor()) then
                call print_cycle_tower(ct,lvl,' After relaxation: ')
            end if

            ! Coarsen and continue downwards
            call residual(ct%res(lvl),ct%uu(lvl),ct%ff(lvl),ct%bb(lvl,:),ct%dx(lvl))
            call restriction(ct%ff(lvl-1),ct%res(lvl))
            call v_cycle(ct,lvl-1,nlvl)

            if (parallel_IOProcessor()) then
                call print_cycle_tower(ct,lvl,'Before relaxation: ')
            end if

            ! Smooth on the way up
            do i = 1,ct%s2
                call gsrb(ct%uu(lvl),ct%ff(lvl),ct%bb(lvl,:),ct%dx(lvl))
            end do

            if (parallel_IOProcessor()) then
                call print_cycle_tower(ct,lvl,' After relaxation: ')
            end if

        end if

        ! If not at the top of this V-cycle, interpolate up and apply correction (i.e. prolongation)
        if (lvl /= nlvl) then
            call prolongation(ct%uu(lvl+1),ct%uu(lvl),ct%interp_type)
        end if

        ! If at the top of this V-cycle, and if this V-cycle is NOT part of an FMG-cycle,
        ! then save solution and fill ghost cells.
        if (lvl == nlvl .and. ct%cycle_type /= FMG_CYCLE_TYPE) then
            call copy(ct%sol,ct%uu(lvl))
            call multifab_fill_boundary(ct%sol)
        end if

    end subroutine v_cycle

end module v_cycle_mod


!----------------------------------------------------------------
! (c) Copyright, 2016 by the Regents of the University of California.
! PhysConstclass: physical constants class in CONSTANTS module of
!                 DATA STRUCTURE layer.
!
! MODULE  : ... PhysConstclass
! VERSION : ... 1.0
!> @author
!> Ji Qiang, LBNL
!
! DESCRIPTION:
!> This class defines the physical constant parameters used
!> in the simulation.
! Comments:
!----------------------------------------------------------------
      module PhysConstclass
        use mpistub
        implicit none

        !physical parameters and constants ---------------------
        double precision :: Pi
        double precision :: Clight !< speed of light in vaccum
        double precision :: Scxl !< length scale
        double precision :: Rad2deg !< conversion factor from radian to degree
        double precision :: Epsilon0 !< permittivity of vacuum
        double precision :: Scfreq !< time scale
      contains
        subroutine construct_PhysConst(freq)
        double precision, intent(in) :: freq

        Clight = 299792458.0d0
        Pi = 2*asin(1.0d0)
        Scxl = Clight/(2*pi*freq)
        Rad2deg = 180.0d0/Pi
        Epsilon0 = 8.854187817d-12
        Scfreq = freq

        end subroutine construct_PhysConst

      end module PhysConstclass


!*******************************************************************************
!  Solve a series of large (~1 million variable) symmetric positive-definite
!  finite difference matrix equations using the conjugate gradient method
!  preconditioned by the nested factorization algorithm described by
!  "J. APPLEYARD AND I. CHESHIRE, Nested factorization, in Reservoir
!  Simulation Symposium of the SPE, 1983. Paper 12264."  The method works
!  well with very stiff equations which defeat other iterative methods, and
!  is similar to that implemented in the widely used Eclipse oil reservoir
!  simulator.
!
!  For a matrix
!
!     A = D + L1 + U1 + L2 + U2 + L3 + U3
!
!  where D is the matrix diagonal,
!        L1 and U1 are the bands connecting adjacent cells within a line,
!        L2 and U2 are the bands connecting adjacent lines within a plane,
!    and L3 and U3 are the bands connecting adjacent planes of the FD grid,
!
!          D U1  U1    U3              Finite Difference Matrix for
!         L1 D U1  U2    U3            nx=3, ny=2, nz=2
!           L1 D     U2    U3
!         L2     D U1        U3
!           L2  L1 D U1        U3
!             L2  L1 D           U3
!         L3           D U1  U2
!           L3        L1 D U1  U2
!             L3        L1 D     U2
!               L3    L2     D U1
!                 L3    L2  L1 D U1
!                   L3    L2  L1 D
!
!  the preconditioning matrix, B^-1, is defined by the recursive equations
!
!     B = (P+L3)(I+P^-1.U3)   - B is block tridiagonal - block elements are planes
!     P = (T+L2)(I+T^-1.U2)   - P is block tridiagonal - block elements are lines
!     T = (G+L1)(I+G^-1.U1)   - T is tridiagonal
!     G = D - L1.G^-1.U1
!           - ColSum(E)       - G is diagonal
!     E = L2.T^-1.U2 - L3.P^-1.*U3
!
!  ColSum(E) is the diagonal matrix formed by summing the elements of E in
!  columns.  Although, the definition of G is recursive, close examination
!  shows that each element depends only on the previous cell, line or plane.
!
!  After expansion, we obtain
!
!     B = A + E - Colsum(E)
!
!  The fact that the column sum of the error matrix is zero is useful in
!  some cases - for example it ensures zero material balance error for every
!  plane in some CFD problems.  It can also be used as a check on the
!  correctness of the implementation.
!
!  This preconditioning is usually most effective when the L1, and U1 bands are
!  numerically largest, followed by L2, U2 and, finally, L3, U3.  This happens
!  naturally in some problem domains - for example if the vertical extent of
!  finite difference grid blocks is smaller than the horizontal extent.
!*******************************************************************************
program NF
implicit none

!  Theses tests require about 120MBytes
!            nx  ny nz bd1 bd2 bd3 stiff   it  rms method
call mattest(97,105,99,1D2,1D1,1D0,1000D0, 50,1D-7,'NFCG')  ! NFCG best case - band1>band2>band3
call mattest(97,105,99,1D2,1D2,1D0,1000D0, 50,1D-7,'NFCG')  ! NFCG band1=band2>band3
call mattest(97,105,99,1D1,1D2,1D0,100D0 , 50,1D-7,'NFCG')  ! NFCG bad ordering - band1<band2
                                                            !      but reduced stiffness
call mattest(97,105,99,1D1,1D1,1D1,1000D0, 50,1D-7,'NFCG')  ! NFCG all bands the same
!call mattest(97,105,99,1D2,1D1,1D0,10D0  ,150,1D-7,'ICCG')  ! ICCG takes too long with same
!                                                            !      stiffness as NFCG
!call mattest(97,105,99,1D2,1D1,1D0,10D0  ,200,1D-7,'SIP3D0.92')
!                                                            ! SIP3D with alpha=0.92
!call mattest(97,105,99,1D2,1D1,1D0,1D0   ,150,1D-7,'CGSTAB')! CGSTAB (maybe not working?)

!  The following require an extra 240MBytes for the vector tridiagonal solver

!call mattest(97,105,99,1D2,1D1,1D0,1000D0, 50,1D-7,'VNFCG7')! VNFCG best case - band1>band2>band3
!call mattest(97,105,99,1D2,1D1,1D0,1000D0, 50,1D-7,'VNFCG6')! invwstigate effect of approximation
!call mattest(97,105,99,1D2,1D1,1D0,1000D0, 50,1D-7,'VNFCG5')! in tridiag solver
!call mattest(97,105,99,1D2,1D1,1D0,1000D0, 50,1D-7,'VNFCG4')!
end program NF

!*******************************************************************************
!  Set up and solve matrix representing nx * ny * nz finite difference grid
!  Elements on 1st band (1     above and below diagonal) are set to band1
!  Elements on 2nd band (nx    above and below diagonal) are set to band2
!  Elements on 3rd band (nx*ny above and below diagonal) are set to band3
!  All bands have gaps appropriate for nx * ny * nz geometry
!  Elements on diagonal = -sum(band elements in same column) - 1.0/stiffness
!  Up to maxiter iterations are allowed to reduce the rms residual to targrms
!  method='NFCG', 'ICCG', 'SIP3D0.nn' (alpha = 0.nn), 'VNFCGn'
!*******************************************************************************

subroutine mattest(nx,ny,nz,band1,band2,band3,stiffness,maxiter,targrms,method)
implicit none
integer,parameter :: dpkind=kind(1.0D0)
integer :: nx , ny , nz , maxiter
character(*) :: method
real(dpkind) :: band1 , band2 , band3 , stiffness , targrms , alfa
real(dpkind),allocatable,dimension(:) :: ad,au1,au2,au3,x,b
integer :: nxyz , nxy , i , cycles

write(*,'(/A,I4,A,I4,A,I4,A,A)') &
            ' Solve ',nx,' by',ny,' by',nz,' FD problem - method=',method
write(*,'(A,F8.2,A,F8.2,A,F8.2,A,F10.2)') &
            ' Band elements are ',band1,', ',band2, &
            ', and ',band3,'. stiffness=',stiffness
write(*,'(A,G13.4,A,I4/)') ' Target RMS residual =',targrms,' Maximum Iterations =',maxiter

                                     ! Set up matrix
nxy = nx*ny ; nxyz = nxy*nz
allocate(ad(nxyz),au1(nxyz),au2(nxyz),au3(nxyz),x(nxyz),b(nxyz))
au1 = band1 ; au2 = band2 ; au3 = band3
au1(nx:nxyz:nx) = 0.0
do i = nxy , nxyz , nxy
   au2(i-nx+1:i) = 0.0d0
enddo
au3(nxyz-nxy+1:) = 0.0d0
ad = -1.0/stiffness - au1 - au2 - au3
ad(2:nxyz)     = ad(2:nxyz)     - au1(1:nxyz-1)
ad(nx+1:nxyz)  = ad(nx+1:nxyz)  - au2(1:nxyz-nx)
ad(nxy+1:nxyz) = ad(nxy+1:nxyz) - au3(1:nxyz-nxy)

b=0.0 ; b(1) = 100.0                 ! set up rhs
x=0.0                                ! set up initial solution vector

                                     ! solve using requested method
if ( method=='NFCG' ) then
   call nfcg(nx,nxy,nxyz,ad,au1,au2,au3,x,b,maxiter,targrms)
!elseif ( method(1:5)=='VNFCG' ) then
!   read(method(6:6),'(I1)') cycles
!   call vnfcg(nx,nxy,nxyz,ad,au1,au2,au3,x,b,maxiter,targrms,cycles)
!elseif ( method=='ICCG' ) then
!   call iccg(nx,nxy,nxyz,ad,au1,au2,au3,x,b,maxiter,targrms)
!elseif ( method(1:5)=='SIP3D' ) then
!   read(method(6:),*) alfa
!   call sip3d(nx,nxy,nxyz,ad,au1,au2,au3,x,b,maxiter,targrms,alfa)
!elseif ( method=='CGSTAB' ) then
!   call cgstab(nx,nxy,nxyz,ad,au1,au2,au3,x,b,maxiter,targrms)
endif

deallocate(ad,au1,au2,au3,x,b)
end subroutine mattest
!*******************************************************************************

!*******************************************************************************
!  Solve using conjugate gradients pre-conditioned by nested factorization
!*******************************************************************************
subroutine nfcg(nx,nxy,nxyz,ad,au1,au2,au3,x,b,maxiter,targrms)
implicit none ; integer,parameter :: dpkind=kind(1.0D0)
integer :: nx , nxy , nxyz , maxiter
real(dpkind),dimension(nxyz):: ad,au1,au2,au3,x,b
real(dpkind)::targrms

real(dpkind),allocatable,dimension(:) :: r,q,p,z,g,gi
real(dpkind):: alpha,beta,qr,qrp,rmserr
integer :: iter , tbase , tgi , tcg , tickspersec , maxticks

allocate (gi(nxyz),g(nxyz))
call system_clock(tbase,tickspersec,maxticks)
call GetGI3D(1,nxyz)                 ! compute gi for preconditioning matrix
call system_clock(tgi,tickspersec,maxticks)
deallocate(g)

allocate (r(nxyz),q(nxyz),p(nxyz),z(nxyz))
CALL SPMMULT(x,r) ; r = b - r        ! compute initial residual vector

write(*,'(A)') ' Iter      Alpha        Beta     RMS Residual   Sum of Residuals'
write(*,'(I4,24X,2G18.7)') 0,sqrt(DOT_PRODUCT(r,r)/nxyz),sum(r)

                                     !  Do a single iteration with alpha =1
                                     !  to reduce sum of residuals to 0
p = r ; CALL NF3DPrecon(p,1,nxyz) ; CALL SPMMULT(p,z)
x = x + p ; r = r - z
write(*,'(I4,F12.5,12X,2G18.7)') 0,1.0,sqrt(DOT_PRODUCT(r,r)/nxyz),sum(r)

do iter = 1 , maxiter
   q = r ; CALL NF3DPrecon(q,1,nxyz)
   qr = DOT_PRODUCT(q,r)
   if ( iter==1 ) then
      beta = 0.0
      p = q
   else
      beta = qr/qrp
      p = q + beta*p
   endif
   qrp = qr
   CALL SPMMULT(p,z)
   alpha = qr/DOT_PRODUCT(p,z)
   x = x + alpha*p ; r = r - alpha*z
   rmserr = sqrt(DOT_PRODUCT(r,r)/nxyz)
   write(*,'(I4,2F12.5,3G18.7)') iter , alpha , beta , rmserr , sum(r)! , maxval(abs(r))
   if ( rmserr<targrms ) exit
enddo
call system_clock(tcg,tickspersec,maxticks)
write(*,'(/A,F10.3/A,F10.3/A,F10.3)') ' Time for setup     ',REAL(tgi-tbase)/REAL(tickspersec) , &
                                      ' Time per iteration ',REAL(tcg-tgi)/REAL(tickspersec*min(iter,maxiter)) , &
                                      ' Total Time         ',REAL(tcg-tbase)/REAL(tickspersec)
deallocate(r,q,p,z,gi)
contains
                                     !=========================================
                                     ! Banded matrix multiply b = A.x =========
subroutine spmmult(x,b)
real(dpkind),dimension(nxyz):: x,b
b = ad*x
b(1:nxyz-1)  = b(1:nxyz-1)  + au1(1:nxyz-1) *x(2:nxyz)
b(2:nxyz)  = b(2:nxyz)  + au1(1:nxyz-1) *x(1:nxyz-1) ! symmetric - so use au for lower band too
b(1:nxyz-nx)  = b(1:nxyz-nx)  + au2(1:nxyz-nx) *x(nx+1:nxyz)
b(nx+1:nxyz)  = b(nx+1:nxyz)  + au2(1:nxyz-nx) *x(1:nxyz-nx)
b(1:nxyz-nxy) = b(1:nxyz-nxy) + au3(1:nxyz-nxy)*x(nxy+1:nxyz)
b(nxy+1:nxyz) = b(nxy+1:nxyz) + au3(1:nxyz-nxy)*x(1:nxyz-nxy)
end subroutine spmmult               !=========================================

                                     !=========================================
subroutine GetGI1D(i1,i2)            ! compute gi for a line of cells =========
integer :: i1 , i2
integer :: i
gi(i1) = 1.0D0/g(i1)
do i = i1+1,i2
   g(i) = g(i) - gi(i-1)*au1(i-1)*au1(i-1)
   gi(i) = 1.0D0/g(i)
enddo
end subroutine GetGI1D               !=========================================

                                     !=========================================
subroutine trisolve(x,i1,i2)         ! solve along a single line of cells =====
integer :: i1 , i2
real(dpkind),dimension(i2)::x
integer :: i
x(i1) = gi(i1)* x(i1)
do i = i1+1 , i2
   x(i) = gi(i)*(x(i)-au1(i-1)*x(i-1))
enddo
do i = i2-1 , i1 , -1
   x(i) = x(i) - gi(i)*au1(i)*x(i+1)
enddo
end subroutine trisolve              !=========================================

                                     !=========================================
subroutine GetGI2D(i1,i2)            ! compute gi for a plane of cells ========
integer :: i1 , i2
integer :: i
do i = i1 , i2 , nx                  ! advance one line at a time
   if ( i>i1 ) then                  ! get contribution from previous line
      g(i-nx:i-1) = au2(i-nx:i-1)
      call trisolve(g,i-nx,i-1)
      g(i:i+nx-1) = g(i:i+nx-1) - au2(i-nx:i-1)*g(i-nx:i-1)
   endif
   call GetGI1D(i,i+nx-1)            ! get contribution from this line
enddo
end subroutine GetGI2D               !=========================================

                                     !=========================================
                                     ! solve for a plane of cells using  ======
subroutine NF2DPrecon(x,i1,i2)       ! 2D NF Preconditioning matrix
integer :: i1 , i2
real(dpkind),dimension(i2)::x,t
integer :: i
do i = i1 , i2 , nx
   if ( i>i1 ) x(i:i+nx-1) = x(i:i+nx-1) - au2(i-nx:i-1)*x(i-nx:i-1)
   call trisolve(x,i,i+nx-1)
enddo
do i = i2-2*nx+1 , i1 , -nx
   t(i:i+nx-1) = au2(i:i+nx-1)*x(i+nx:i+2*nx-1)
   call trisolve(t,i,i+nx-1)
   x(i:i+nx-1) = x(i:i+nx-1) - t(i:i+nx-1)
enddo
end subroutine NF2DPrecon            !=========================================

                                     !=========================================
subroutine GetGI3D(i1,i2)            ! compute gi for a 3D block of cells =====
integer :: i1 , i2
integer :: i
g = ad
do i = i1 , i2 , nxy                 ! advance one plane at a time
   if ( i>i1 ) then                  ! get contribution from previous plane
      g(i-nxy:i-1) = au3(i-nxy:i-1)
      call NF2DPrecon(g,i-nxy,i-1)
      g(i:i+nxy-1) = g(i:i+nxy-1) - au3(i-nxy:i-1)*g(i-nxy:i-1)
   endif
   call GetGI2D(i,i+nxy-1)           ! get contribution from this plane
enddo
end subroutine GetGI3D               !=========================================

                                     !=========================================
                                     ! solve for a 3D block of cells using
subroutine NF3DPrecon(x,i1,i2)       ! 3D Preconditioning matrix
integer :: i1 , i2
real(dpkind),dimension(i2)::x,t
integer :: i
do i = i1 , i2 , nxy
   if ( i>i1 ) x(i:i+nxy-1) = x(i:i+nxy-1) - au3(i-nxy:i-1)*x(i-nxy:i-1)
   call NF2DPrecon(x,i,i+nxy-1)
enddo
do i = i2-2*nxy+1 , i1 , -nxy
   t(i:i+nxy-1) = au3(i:i+nxy-1)*x(i+nxy:i+2*nxy-1)
   call NF2DPrecon(t,i,i+nxy-1)
   x(i:i+nxy-1) = x(i:i+nxy-1) - t(i:i+nxy-1)
enddo
end subroutine NF3DPrecon            !=========================================

end subroutine nfcg
!******************************************************************************

!include '\nf\vnfcg.f90'
!include '\nf\cgstab.f90'
!include '\nf\iccg.f90'
!include '\nf\sip3d.f90'


module extrapolation_limiting_mod
    !!
    !! Some useful routines for extrapolation and slope-limiting. These do not rely on the domain_type.
    !!

    use global_mod, only: dp, ip, charlen
    implicit none

    real(dp), parameter :: HALF_dp = 0.5_dp, ZERO_dp = 0.0_dp, ONE_dp=1.0_dp

    contains

    elemental function minmod(a,b) result(minmod_ab)
        !!
        !! minmod function, which is used in some gradient limiters
        !!
        !! @param a,b real numbers
        !!
        real(dp), intent(in):: a, b
        real(dp):: minmod_ab

        minmod_ab = merge(min(abs(a), abs(b))*sign(ONE_dp,a), ZERO_dp, sign(ONE_dp,a) == sign(ONE_dp,b))
        !minmod_ab = sign(one_dp, a) * max(zero_dp, min(abs(a), sign(one_dp, a)*b))

    end function

    elemental subroutine minmod_sub(a,b, minmod_ab)
        !!
        !! minmod subroutine, which is used in some gradient limiters
        !!
        !! @param a,b real numbers
        !!
        real(dp), intent(in):: a, b
        real(dp), intent(out):: minmod_ab

        if((a>ZERO_dp .and. b>ZERO_dp).or.(a<ZERO_dp .and. b<ZERO_dp)) then
            minmod_ab = min(abs(a), abs(b))*sign(ONE_dp, a)
        else
            minmod_ab = ZERO_dp
        end if

    end subroutine

    subroutine limited_gradient_dx_vectorized(U_local, U_lower, U_upper, theta, gradient_dx, n)
        !!
        !! Slope limiter -- get the "gradient times dx" around U_local, given the upper and lower values of U.
        !!
        integer(ip), intent(in):: n !! Length of the input arrays
        real(dp), intent(in):: U_local(n) !! U_{i}
        real(dp), intent(in):: U_lower(n) !! U_{i-1}
        real(dp), intent(in):: U_upper(n) !! U_{i+1}
        real(dp), intent(in):: theta(n) !! Limiter parameter, often in [1-2].
        real(dp), intent(out) :: gradient_dx(n) !! Output

        character(len=charlen), parameter :: limiter_type = 'MC' !'Minmod2' !'Superbee_variant' ! 'MC'! 'nolimit' !
        !! Type of limiter

        integer(ip) :: i
        real(dp):: a, b, c, d, e, th, sa, sb, half_sasb

        if(limiter_type == 'MC') then

            !$OMP SIMD
            do i = 1, n

                a = U_upper(i) - U_local(i)
                b = U_local(i) - U_lower(i)
                th = theta(i)
                sa = sign(ONE_dp,a)
                sb = sign(ONE_dp,b)
                half_sasb = HALF_dp * (sa + sb)
                d = min(abs(a), abs(b)) * half_sasb * th ! Limit on local gradient
                e = HALF_dp * (a + b)
                c = merge(ZERO_dp, e, d == ZERO_dp)
                ! NOTE: IF d /= 0, then clearly d, c have the same sign
                ! We exploit this to avoid a further minmod call (which seems
                ! expensive)
                gradient_dx(i) = merge(min(c, d), max(c, d), d > ZERO_dp)
            end do

        else if(limiter_type == "Superbee_variant") then

            !$OMP SIMD
            do i = 1, n

                a = U_upper(i) - U_local(i)
                b = U_local(i) - U_lower(i)
                ! Divide by 1.6 which is the default 'max theta' in the rk2 algorithms
                th = theta(i) * 2.0_dp/1.6_dp
                !d = minmod(a, th*b)
                d = merge(min(abs(a), abs(th*b))*sign(ONE_dp,a), ZERO_dp, sign(ONE_dp,a) == sign(ONE_dp,b))
                !e = minmod(th*a, b)
                e = merge(min(abs(th*a), abs(b))*sign(ONE_dp,a), ZERO_dp, sign(ONE_dp,a) == sign(ONE_dp,b))
                if(abs(e) > abs(d)) then
                    b = e
                else
                    b = d
                endif
                gradient_dx(i) = b
            end do

        else if(limiter_type == "Minmod2") then
            ! Same as 'MC' (!!!)

            !$OMP SIMD
            do i = 1, n

                a = U_upper(i) - U_local(i)
                b = U_local(i) - U_lower(i)
                th = theta(i)
                e = HALF_dp * (a + b)
                a = a * th
                b = b * th
                if(b > ZERO_dp .and. a > ZERO_dp) then
                    ! Positive slopes
                    if(b < a) a = b
                    d = min(e, a)
                else if(b < ZERO_dp .and. a < ZERO_dp) then
                    ! Negative slopes
                    if(b > a) a = b
                    d = max(e, a)
                else
                    d = ZERO_dp
                endif
                gradient_dx(i) = d
            end do

        else if(limiter_type == 'nolimit') then

            gradient_dx = HALF_dp * (U_upper - U_lower)

        else
            gradient_dx = ZERO_dp
        end if

    end subroutine

    !
    ! This is the same as the above routine, but elemental so not necessarily vectorized.
    ! It allows trying a different loop structure elsewhere in the code.
    !
    pure elemental subroutine limited_gradient_dx(U_local, U_lower, U_upper, theta, gradient_dx)
        !!
        !! Slope limiter -- get the "gradient times dx" around U_local, given the upper and lower values of U.
        !!
        real(dp), intent(in):: U_local !! U_{i}
        real(dp), intent(in):: U_lower !! U_{i-1}
        real(dp), intent(in):: U_upper !! U_{i+1}
        real(dp), intent(in):: theta !! Limiter parameter, often in [1-2].
        real(dp), intent(out) :: gradient_dx !! Output

        real(dp):: a, b, c, d, e, th, sa, sb, half_sasb

        a = U_upper - U_local
        b = U_local - U_lower
        th = theta
        sa = sign(ONE_dp,a)
        sb = sign(ONE_dp,b)
        half_sasb = HALF_dp * (sa + sb)
        d = min(abs(a), abs(b)) * half_sasb * th ! Limit on local gradient
        e = HALF_dp * (a + b)
        c = merge(ZERO_dp, e, d == ZERO_dp)
        ! NOTE: IF d /= 0, then clearly d, c have the same sign
        ! We exploit this to avoid a further minmod call (which seems
        ! expensive)
        gradient_dx = merge(min(c, d), max(c, d), d > ZERO_dp)

    end subroutine

    subroutine test_extrapolation_limiting_mod
        !! Unit tests

        integer(ip), parameter :: N = 10
        real(dp) :: U(N), U_lower(N), U_upper(N)
        real(dp) :: theta(N), extrapolation_sign(N)
        real(dp) :: desired_answer(N), answer(N)
        integer(ip) :: i, version

        ! Test both versions of the limited gradient extrapolation routine
        do version = 1, 2

            theta = 1.0_dp
            U = (/(i*1.0_dp - 5.5_dp, i = 1, N)/)
            U_lower = U - 1.0_dp
            U_upper = U + 1.0_dp

            ! Basic extrapolation tests, positive side
            extrapolation_sign=1.0_dp
            call test_both_limited_gradient_dx_vectorized(version, U, U_lower, U_upper, theta, answer, N)
            desired_answer = 0.5_dp * (U + U_upper)
            call assert_equal_within_tol(desired_answer, U + HALF_dp*extrapolation_sign*answer, __LINE__)

            ! As above, negative side
            extrapolation_sign = -1.0_dp
            call test_both_limited_gradient_dx_vectorized(version, U, U_lower, U_upper, theta, answer, N)
            desired_answer = 0.5_dp * (U + U_lower)
            call assert_equal_within_tol(desired_answer, U + HALF_dp*extrapolation_sign*answer, __LINE__)

            ! As above, negative side, reduced theta
            theta = 0.5_dp
            extrapolation_sign = -1.0_dp
            call test_both_limited_gradient_dx_vectorized(version, U, U_lower, U_upper, theta, answer, N)
            desired_answer = 0.5_dp * U + 0.5_dp*0.5_dp * (U + U_lower)
            call assert_equal_within_tol(desired_answer, U+HALF_dp*extrapolation_sign*answer, __LINE__)

            ! As above, negative side, zero theta
            theta = 0.0_dp
            extrapolation_sign = 1.0_dp
            call test_both_limited_gradient_dx_vectorized(version, U, U_lower, U_upper, theta, answer, N)
            desired_answer = 1.0_dp * U + 0.0_dp*0.5_dp * (U + U_lower)
            call assert_equal_within_tol(desired_answer, U+HALF_dp*extrapolation_sign*answer, __LINE__)

            ! Local min.
            theta = 4.0_dp
            extrapolation_sign = 1.0_dp
            U_lower = U + 2.0_dp
            U_upper = U + 3.0_dp
            call test_both_limited_gradient_dx_vectorized(version, U, U_lower, U_upper, theta, answer, N)
            desired_answer = U
            call assert_equal_within_tol(desired_answer, U+HALF_dp*extrapolation_sign*answer, __LINE__)

            ! Local max.
            theta = 4.0_dp
            U_lower = U - 2.0_dp
            U_upper = U - 3.0_dp
            extrapolation_sign = -1.0_dp
            call test_both_limited_gradient_dx_vectorized(version, U, U_lower, U_upper, theta, answer, N)
            desired_answer = U
            call assert_equal_within_tol(desired_answer, U+HALF_dp*extrapolation_sign*answer, __LINE__)

            ! Limited gradients
            !
            ! Central gradient = 2, lower-gradient=1, upper-gradient=3
            U_lower = U - 1.0_dp
            U_upper = U + 3.0_dp
            extrapolation_sign = 1.0_dp
            theta = 1.0_dp ! Limited-gradient = 1
            call test_both_limited_gradient_dx_vectorized(version, U, U_lower, U_upper, theta, answer, N)
            desired_answer = U + 0.5_dp * 1.0_dp
            call assert_equal_within_tol(desired_answer, U+HALF_dp*extrapolation_sign*answer, __LINE__)

            theta = 1.5_dp ! Limited-gradient = 1.5
            call test_both_limited_gradient_dx_vectorized(version, U, U_lower, U_upper, theta, answer, N)
            desired_answer = U + 0.5_dp * 1.5_dp
            call assert_equal_within_tol(desired_answer, U+HALF_dp*extrapolation_sign*answer, __LINE__)

            extrapolation_sign = -1.0_dp ! As above, negative side
            call test_both_limited_gradient_dx_vectorized(version, U, U_lower, U_upper, theta, answer, N)
            desired_answer = U - 0.5_dp * 1.5_dp
            call assert_equal_within_tol(desired_answer, U+HALF_dp*extrapolation_sign*answer, __LINE__)
        end do

        contains

            subroutine assert_equal_within_tol(desired_answer, answer, line)
                real(dp) :: desired_answer(N), answer(N)
                integer :: line

                real(dp) :: tol

                tol = spacing(1.0_dp) * 100

                if(all(abs(desired_answer - answer) < tol)) then
                    print*, 'PASS'
                else
                    print*, 'FAIL', line, desired_answer - answer
                end if

            end subroutine

            ! Use this to test one or the other variant of the extrapolation routine
            subroutine test_both_limited_gradient_dx_vectorized(version, U, U_lower, U_upper, theta, answer, N)
                integer(ip), intent(in) :: N, version
                real(dp), intent(in) :: U(N), U_lower(N), U_upper(N)
                real(dp), intent(in) :: theta(N)
                real(dp), intent(inout) :: answer(N)

                if(version == 1) then
                    call limited_gradient_dx_vectorized(U, U_lower, U_upper, theta, answer, N)
                else if (version == 2) then
                    call limited_gradient_dx(U, U_lower, U_upper, theta, answer)
                else
                    print*, 'unknown version of limited_gradient_dx in test suite'
                    stop
                end if

            end subroutine

    end subroutine

end module


!! module for hilbert transform
module m_hilbert_transform
    use constants, only : CUSTOM_REAL
    implicit none

    complex :: CI=(0.0,1.0)

contains

    subroutine hilbert(trace,nt)
        !! return hilbert transform of real signal trace(nt)
        !! i.e. imaginary part of analytic signal
        !! a = cmplx(trace, hilbert(trace))

        integer,                  intent(in)    :: nt
        real(kind=CUSTOM_REAL),         intent(inout) :: trace(nt)

        complex, allocatable, dimension(:) :: C
        integer :: NPT,IMID

        ! extend nt to a power of 2
        IF ( nt <= 0 ) STOP 'FATAL ERROR in HILBERT: nt must be positive'

        NPT = 2**( INT( LOG10( REAL( nt ) ) / 0.30104 ) + 1 )
        ! IF ( NPT /= nt) print*,'pad trace from length ', nt, ' to ',NPT
        IF (NPT > 16784) STOP 'FATAL ERROR in HILBERT: nt(NPT) exceeds 16784 '

        allocate(C(NPT))
        C=cmplx(0.,0.)
        C(1:nt)=cmplx(trace(1:nt),0.0)

        ! Fourier transform
        call CFFT(C,NPT,1)
        ! scaling
        C=C/NPT

        !  Multiply by i * sgn( f )
        IMID = NPT / 2
        C( 1:IMID-1 ) = -CI * C( 1:IMID-1 )   ! pos. spectrum (-i)
        C( IMID     ) = 0.0                   ! d.c. component
        C(IMID+1:NPT) = CI * C( IMID+1:NPT )   ! neg. spectrum (i)

        ! inverse Fourier transform
        call  CFFT(C,NPT,-1)

        ! output
        trace(1:nt)=real(C(1:nt))

        deallocate(C)

    end subroutine hilbert

    SUBROUTINE CFFT(trace,N,iforw)
        !!! complex FFT
        IMPLICIT NONE
        integer,         intent(in)    :: N, iforw
        complex,         intent(inout) :: trace(N)
        INTEGER :: I1, I2A, I2B, I3, I3Rev, IP1, IP2, ISign
        REAL    ::  theta, sinth
        COMPLEX :: TEMP, W, WSTP

        ISIGN = -IFORW
        I3REV = 1

        DO I3 = 1, N
        IF ( I3 < I3REV ) THEN   ! switch values
            TEMP          = trace( I3 )
            trace( I3 )    = trace( I3REV )
            trace( I3REV ) = TEMP
        ENDIF
        ! following loop is just to compute I3REV
        IP1 = N / 2
        DO WHILE (  I3REV > IP1 )
        IF ( IP1 <= 1 ) EXIT
        I3REV = I3REV - IP1
        IP1   = IP1 / 2
        END DO
        I3REV = I3REV + IP1
        END DO

        IP1 = 1

        DO WHILE  ( IP1 < N )
        IP2   = IP1 * 2
        THETA = 6.283185307 / FLOAT( ISIGN * IP2 )
        SINTH = SIN( THETA / 2.)
        WSTP  = CMPLX( -2. * SINTH * SINTH, SIN( THETA ) )
        W     = 1.

        DO I1 = 1, IP1
        DO I3 = I1, N, IP2
        I2A = I3
        I2B = I2A + IP1
        TEMP      = W * trace( I2B )
        trace( I2B ) = trace( I2A ) - TEMP
        trace( I2A ) = trace( I2A ) + TEMP
        END DO

        W = W * WSTP + W
        END DO

        IP1 = IP2
        END DO

        RETURN
    END SUBROUTINE CFFT

end module m_hilbert_transform


subroutine apply_linearized_pde_operator(t, q, p, output)

! For the PDE q_t = g(q), calculates g'[q](p), i.e. the linearization
! of g, about q, applied to perturbation p
!
! Args:
!   t: Time at which the operator is evaluated.
!   q: Base function of the linearization.
!   p: Perturbation to which the linearized operator is applied.
!   output: g'[q](p), calculated here.

    implicit none

    integer :: mx, mbc, meqn
    double precision :: dx, x_lower
    common /claw_config/ mx, mbc, x_lower, dx, meqn

    double precision, intent(in) :: t
    double precision, dimension(1-mbc:mx+mbc, meqn), intent(in) :: q, p
    double precision, dimension(1-mbc:mx+mbc, meqn), intent(out) :: output

    integer :: ix
    double precision, dimension(1:mx+1) :: fprime  ! Linearized flux
    double precision :: q1_face, p1_face, q1_xxx, p1_xxx

    ! Compute linearized flux at interfaces.
    !$omp parallel do
    do ix = 1, mx+1
        q1_face = (q(ix-1, 1) + q(ix, 1)) / 2.d0
        p1_face = (p(ix-1, 1) + p(ix, 1)) / 2.d0
        q1_xxx =  &
            (-q(ix-2, 1) + 3 * q(ix-1, 1) - 3 * q(ix, 1) + q(ix+1, 1))  &
            / dx**3
        p1_xxx =  &
            (-p(ix-2, 1) + 3 * p(ix-1, 1) - 3 * p(ix, 1) + p(ix+1, 1))  &
            / dx**3
        fprime(ix) = q1_xxx * p1_face + q1_face * p1_xxx
    end do

    !$omp parallel do
    do ix = 1, mx
        output(ix, 1) = -(fprime(ix+1) - fprime(ix)) / dx
    end do

end subroutine apply_linearized_pde_operator


!
!     (c) 2019 Guide Star Engineering, LLC
!     This Software was developed for the US Nuclear Regulatory Commission (US NRC)
!     under contract "Multi-Dimensional Physics Implementation into Fuel Analysis under
!     Steady-state and Transients (FAST)", contract # NRC-HQ-60-17-C-0007
!
program test_class_vector
  !! label: Morfeus-FV
  !!
  !! Test vector class behavior

    use assertions_interface, only : assert
    use class_vector, only : vector, operator(.dot.), vector_
    use class_psblas, only : psb_dpk_

    implicit none

    type(vector) :: a(3), b, c
    real(psb_dpk_), parameter :: tolerance=1.0E-06, one=1.0_psb_dpk_, zero=0.0_psb_dpk_

    a = [vector_(zero, zero, zero), vector_(one, zero, zero), vector_(zero, one, zero)]
    b = vector_(zero, zero, one) ! perpendicular to all vectors in a
    c = a .dot. b ! = [a(1) .dot. b,  a(2) .dot. b,  a(3) .dot. b] = [zero, zero, zero]

    test_operators: &
    block
      call assert( c%mag() <= tolerance, "fv-test-class_vector: mag()" )
    end block test_operators

    print *, "Test passed."

end program test_class_vector


module art

use iso_fortran_env, only: wp=>real64

implicit none

contains

pure subroutine logmart(A,b,relax,x0,sigma,max_iter, x)
! delta Chisquare.
! stopped if Chisquare increases.
!
! Inputs
! ------
! A: NxM array
! b: N vector
! relax: user specified relaxation constant	(default is 20.)
! x0: user specified initial guess (Nx1 vector)  (default is backproject y, i.e., y#A)
! max_iter: user specified max number of iterations (default is 20)
!
!
! Outputs
! -------
! x: N vector
!
!
!    AUTHOR:	Joshua Semeter
!    LAST MODIFIED:	5-2015
!
!      Simple test problem
!    A = diag([5, 5, 5])
!    x = [1,2,3]
!    b = A*x

! --- parameter check
real(wp), intent(in) :: A(:,:), b(:)
real(wp), optional, value :: relax, sigma
real(wp), intent(in),optional :: x0(:)
integer, optional, value :: max_iter
real(wp), intent(out) :: x(:)

real(wp), dimension(size(b)) :: W(size(b)), x_prev,c, op_b
integer :: i
real(wp) :: t,chi2,chiold

if (.not.size(A,1) == size(b)) error stop 'A and b row numbers must match'
if (any(A<0)) error stop 'A must be non-negative'
if (any(b<0)) error stop 'b must be non-negative'
op_b = b
! --- make sure there are no 0's in b
where(op_b <= 1e-8) op_b = 1e-8_wp

! --- set defaults
if (.not.present(relax)) relax = 1
if (.not.present(max_iter)) max_iter = 200
if (.not.present(sigma))  sigma = 1

if (.not.present(x0)) then
  x  = matmul(transpose(A), op_b) / sum(A)
  x  = x * maxval(op_b) / maxval(matmul(A, x))
else
  x = x0
endif

! W=sigma;
! W=linspace(1,0,size(A,1))';
! W=rand(size(A,1),1);
W = 1
W = W / sum(W)

! --- iterate solution
chi2 = chi_squared(A, op_b, x, sigma)

do i = 1, max_iter
  x_prev = x
  t = minval(1/matmul(A,x))
  C = relax*t*(1-(matmul(A,x)/op_b))
  x = x / (1-x*matmul(transpose(A),W*C))
! monitor solution
  chiold = chi2
  chi2 = chi_squared(A, op_b, x, sigma)
  if (chi2 > chiold .and. i > 2) exit
enddo

x = x_prev

end subroutine logmart

pure real(wp) function chi_squared(A, b, x, sigma)
real(wp), intent(in) :: A(:,:), b(:), x(:), sigma
chi_squared = sqrt(sum(((matmul(A,x) - b) / sigma)**2))

end function chi_squared

end module art


! =============================================================================
!                       Test ellipse orientation
!
!       This unit test checks the ellipse orientation computed using the
!       B matrix values, i.e., B11 and B12. The angle computed via the
!       B matrix is within [-pi/2, pi/2].
! =============================================================================
program test_ellipse_orientation
    use unit_test
    use constants, only : pi, zero, two, three, f14
    use parcel_container, only : parcels, n_parcels, parcel_alloc, parcel_dealloc
    use parcel_ellipse
    implicit none

    double precision :: extent(2) =  (/0.2d0, 0.2d0/)
    integer :: iter
    integer :: grid(2) = (/2, 2/)
    double precision :: angle, B11, B12, V, a2, b2
    double precision, parameter :: lam = three
    logical :: passed = .true.

    n_parcels = 1
    call parcel_alloc(1)

    parcels%position = zero
    parcels%volume = f14 * product(extent / (grid - 1))

    V = parcels%volume(1)

    a2 = (lam * V) / pi
    b2 = V / (pi * lam)

    do iter = 0, 360

        angle = dble(iter) * pi / 180.0d0

        B11 = a2 * dcos(angle) ** 2 + b2 * dsin(angle) ** 2

        B12 = (a2 - b2) * dsin(angle) * dcos(angle)

        parcels%B(1, 1) = B11

        parcels%B(2, 1) = B12

        ! get_angle computes the angle in the first and fourth quadrant, i.e.,
        ! -pi/2 <= get_angle <= pi/2
        if (angle > pi / two .and. angle <= three * pi / two) then
            angle = angle - pi
        else if (angle > three * pi / two) then
            angle = angle - two * pi
        endif

        passed = (passed .and. abs(angle - get_angle(B11, B12, V)) < dble(1.0e-13))

    enddo

    call parcel_dealloc()

    call print_result_logical('Test ellipse orientation', passed)

end program test_ellipse_orientation


      SUBROUTINE GAUSSJ(A,N,NP,B,M,MP)
c	note added from 2nd edition, which is not the same as the first,
c	below
c	linear equations solution by Gauss Jordan elimination, equation
c	(2.1.1) above.  a(1;n,1:n) is an input matrix stored in an array
c	of physical dimensions np by np.  b(1:n,1:m) is an input matrix
c	containing the m right-hand side vectors, stored in an array of
c	physical dimensions np by mp.  On output, a(1:n,1:n) is replaced
c	by its matrix inverse and b(1:n,1:m) is replace by the corresponding
c	set of solution vectors.
c	Parameter: NMAX is the largest anticpated value of n
c
      PARAMETER (NMAX=50)
      DIMENSION A(NP,NP),B(NP,MP),IPIV(NMAX),INDXR(NMAX),INDXC(NMAX)
      DO 11 J=1,N
        IPIV(J)=0
11    CONTINUE
      DO 22 I=1,N
        BIG=0.
        DO 13 J=1,N
          IF(IPIV(J).NE.1)THEN
            DO 12 K=1,N
              IF (IPIV(K).EQ.0) THEN
                IF (ABS(A(J,K)).GE.BIG)THEN
                  BIG=ABS(A(J,K))
                  IROW=J
                  ICOL=K
                ENDIF
              ELSE IF (IPIV(K).GT.1) THEN
C                PAUSE 'Singular matrix'
                PRINT*, 'Singular matrix'
		RETURN
              ENDIF
12          CONTINUE
          ENDIF
13      CONTINUE
        IPIV(ICOL)=IPIV(ICOL)+1
        IF (IROW.NE.ICOL) THEN
          DO 14 L=1,N
            DUM=A(IROW,L)
            A(IROW,L)=A(ICOL,L)
            A(ICOL,L)=DUM
14        CONTINUE
          DO 15 L=1,M
            DUM=B(IROW,L)
            B(IROW,L)=B(ICOL,L)
            B(ICOL,L)=DUM
15        CONTINUE
        ENDIF
        INDXR(I)=IROW
        INDXC(I)=ICOL
C        IF (A(ICOL,ICOL).EQ.0.) PAUSE 'Singular matrix.'
        IF (A(ICOL,ICOL).EQ.0.) THEN
		PRINT*, 'Singular matrix.'
		RETURN
	ENDIF
        PIVINV=1./A(ICOL,ICOL)
        A(ICOL,ICOL)=1.
        DO 16 L=1,N
          A(ICOL,L)=A(ICOL,L)*PIVINV
16      CONTINUE
        DO 17 L=1,M
          B(ICOL,L)=B(ICOL,L)*PIVINV
17      CONTINUE
        DO 21 LL=1,N
          IF(LL.NE.ICOL)THEN
            DUM=A(LL,ICOL)
            A(LL,ICOL)=0.
            DO 18 L=1,N
              A(LL,L)=A(LL,L)-A(ICOL,L)*DUM
18          CONTINUE
            DO 19 L=1,M
              B(LL,L)=B(LL,L)-B(ICOL,L)*DUM
19          CONTINUE
          ENDIF
21      CONTINUE
22    CONTINUE
      DO 24 L=N,1,-1
        IF(INDXR(L).NE.INDXC(L))THEN
          DO 23 K=1,N
            DUM=A(K,INDXR(L))
            A(K,INDXR(L))=A(K,INDXC(L))
            A(K,INDXC(L))=DUM
23        CONTINUE
        ENDIF
24    CONTINUE
      RETURN
      END


program test

  use precision
  use globals
  use fft
  use misc

  integer(idp) :: i, j, k
  integer(idp), dimension(2) :: n
  real(fdp), dimension(2) :: t
  complex(cdp), dimension(:,:), allocatable :: a, dely, delx, xdelydel, array_t, x, y, t1, t2

  read(*,*) n

  parameters%n = n
  parameters%pspacing = 1.0d0/dble(n)
  parameters%gridspacing = 1.0

  allocate(xdelydel(n(1), n(2)), dely(n(1), n(2)), delx(n(1), n(2)), array_t(n(1), n(2)), a(n(1), n(2)), x(n(1), n(2)), y(n(1), n(2)), t1(n(1), n(2)), t2(n(1), n(2)))

  do j=1, n(2)
     do i=1, n(1)

        a(i, j) = exp(-dble(i-n(1)/3)**2/50.0d0-dble(j-n(2)/3)**2/50)

     end do
  end do

  call s_momentumfac(xdelydel, (/ 1.0d0, 1.0d0 /), (/ 1, 1 /()

  call s_momentumfac(array_t, (/ 1.0d0, 1.0d0 /), (/ 1, 1 /))

  call s_momentumfac(dely, (/ 1.0d0, 1.0d0 /), (/ 1, 1 /))

  call s_momentumfac(delx, (/ 1.0d0, 1.0d0 /), (/ 1, 1 /))

  write(*,*) "a ",sum(abs(a))
  write(*,*) "array_t ",sum(abs(array_t))
  write(*,*) "xdelydel ",sum(abs(xdelydel))
  write(*,*) "delx ",sum(abs(delx))
  write(*,*) "dely ",sum(abs(dely))

  do i=1, n(1)

     xdelydel(i, :) = f_positionx(i)*xdelydel(i, :)
     x(i, :) = f_positionx(i)

  end do

  do i=1, n(2)

     xdelydel(:, i) = xdelydel(:, i)-f_positiony(i)*array_t(:, i)
     y(:, i) = f_positiony(i)

  end do

  xdelydel = xdelydel / dble(n(1)*n(2))
  delx = delx /  dble(n(1)*n(2))
  dely = dely /  dble(n(1)*n(2))

  call s_c2dfft(a, n, fftfor)

  array_t = a*xdelydel
  call s_c2dfft(array_t, n, fftbac)

  t1 = dely*a
  call s_c2dfft(t1, n, fftbac)

  t2 = delx*a
  call s_c2dfft(t2, n, fftbac)

  t2 = x*dely*a-y*delx*a
  call s_c2dfft(t2, n, fftbac)

  t1 = x*t1-y*t2

  write(*,*) "t1-t2 ",sum(abs(t2-t1))

  call s_c2dfft(a, n, fftbac)
  a = a / dble(n(1)*n(2))

  write(*,*) "a ",sum(abs(a))
  write(*,*) "array_t ",sum(abs(array_t))
  write(*,*) "t1 ",sum(abs(t1))
  write(*,*) "array_t-t1",sum(abs(array_t-t1))

end program test


! RUN: %python %S/test_folding.py %s %flang_fc1
! Tests folding of DIM()
module m
  logical, parameter :: test_i1 = dim(0, 0) == 0
  logical, parameter :: test_i2 = dim(1, 2) == 0
  logical, parameter :: test_i3 = dim(2, 1) == 1
  logical, parameter :: test_i4 = dim(2, -1) == 3
  logical, parameter :: test_i5 = dim(-1, 2) == 0
  logical, parameter :: test_a1 = dim(0., 0.) == 0.
  logical, parameter :: test_a2 = dim(1., 2.) == 0.
  logical, parameter :: test_a3 = dim(2., 1.) == 1.
  logical, parameter :: test_a4 = dim(2., -1.) == 3.
  logical, parameter :: test_a5 = dim(-1., 2.) == 0.
  !WARN: warning: invalid argument on division
  real, parameter :: nan = 0./0.
  logical, parameter :: test_a6 = dim(nan, 1.) /= dim(nan, 1.)
end module


c
c e1 and e2 values in fortran application differ
c slighly from the values in the wrapped function in R,
c since the the later use 16 decimal places
c

      subroutine cao97sub(x,ndp,maxd,tau,e1,e2)

      integer ndp, d, maxd, tau, maxtau
      double precision x(1:ndp),e1(1:maxd),e2(1:maxd),v(50),a(50),ya(50),v0,vij

      do d=1,maxd
        a(d)=0.
        ya(d)=0.
        ng=ndp-d*tau
        do i=1,ng
          v0=1.e+30
        do j=1,ng
          if(j.eq.i) go to 20
            do k=1,d
              v(k)=abs(x(i+(k-1)*tau)-x(j+(k-1)*tau))
            enddo
          if (d.eq.1) go to 50
            do k=1,d-1
               v(k+1)=max(v(k),v(k+1))
            enddo
 50         vij=v(d)
              if (vij.lt.v0.and.vij.ne.0.) then
                n0=j
                v0=vij
             endif
 20         continue
          enddo
          a(d)=a(d)+max(v0,abs(x(i+d*tau)-x(n0+d*tau)))/v0
          ya(d)=ya(d)+abs(x(i+d*tau)-x(n0+d*tau))
        enddo
        a(d)=a(d)/float(ng)
        ya(d)=ya(d)/float(ng)
        !write (*,*) a(d), ya(d)
        if (d.ge.2) then
         !write(*,*) d-1,' E1=', a(d)/a(d-1), ' E2=', ya(d)/ya(d-1)
         e1(d-1) = a(d) / a(d-1)
         e2(d-1) = ya(d) / ya(d-1)
      endif
      enddo
      end


      subroutine fd_solar_elevation(lyear,idayjl,isecdy,xlat,xlon, sun_theta)
      implicit none

	real(4), parameter :: solar_constant=1366.2   !watts/m**2
      real(4), parameter :: pi=3.141592654
c     inputs and outputs
	integer(4) lyear,idayjl,isecdy  ! year, julian day, seconds in day
	real(4)    xlat                 ! latitude of observation
	real(4)    sun_theta                 ! sun elevation
	real(4) sunlat,sunlon,sundis,hh,xlon,local_time,cosZ

	call sunloc1(lyear,idayjl,isecdy, sunlat,sunlon,sundis)	  !sundis is radius/(mean radius)
	local_time=(isecdy/86400.*24.+xlon/360.*24.)
	if(local_time>24)local_time=local_time-24.
	hh=local_time
	cosZ=sind(xlat)*sind(sunlat) + cosd(xlat)*cosd(sunlat)*cos((hh+12)/24.*2*pi)
	sun_theta=asin(cosZ)*180./pi
	if(sun_theta<-90)sun_theta=-90
	if(sun_theta>90)sun_theta=90
      return
      end


program oned_mc_impsampling

      !Author : Anantha Rao
      ! Reg no : 20181044
      integer:: n,i
      real*8:: p, crude_mc, x, func, sigma, var, length, actual

      length=3.0d0
      actual=exp(3.0d0) -1

      n = 1
      open(unit=1, file="20181044_p2_MC_sampling.dat")

      7 crude_mc = 0.0d0
      sigma=0.0d0

      do i=1,n
        call random_number(p)
        x = 3.0d0*p**(1.0/3.0)
        crude_mc = crude_mc+func(x)
        sigma=sigma+func(x)*func(x)
      end do

      crude_mc=crude_mc/real(n)
      sigma=sigma/real(n)
      var = sigma - crude_mc*crude_mc

      crude_mc = length*crude_mc
      var=length*sqrt(var/real(n))
      write(*,*) n,"",crude_mc," ", var
      write(1,*) n,"",crude_mc,"",abs(crude_mc-actual)

      !automation
      n=n*10
      if (n .le. 100000000) goto 7
      print*, "Output written to 20181044_p2_MC_impsampling.dat"
      ! end automation

      end program oned_mc_impsampling

real*8 function func(x)
    implicit none
    real*8 ::x
    func=3.0d0*x**(-2.0)*exp(x)
end function