*
* diagopsi.f subroutine for goldstein to calculate overturning
* streamfunctions nre 27/11/2
* hacked to find Atlantic extrema in lower half of domain nre 11/6/3
*
* AY (05/05/04) : above hack unhacked and replaced with explicit
*                 parameter controlling the depth from which max
*                 or min overturning calculated from (overdep)
*
      subroutine diagopsi(ominp,omaxp,omina,omaxa,opsi,opsia,opsip,
     +     iposa)

#include "ocean.cmn"

      real opsi(0:maxj,0:maxk), ou(maxj,maxk)
      real opsia(0:maxj,0:maxk), omina, omaxa
      real opsip(0:maxj,0:maxk), ominp, omaxp
      integer iposa(2)

      integer i, j, k

c Calculate meridional overturning streamfunction opsi on C grid only

      do j=0,jmax
         do k=0,kmax
            opsi(j,k) = 0
            opsia(j,k) = 0
            opsip(j,k) = 0
         enddo
      enddo

      do 70 j=1,jmax-1
         do 80 k=1,kmax-1
            ou(j,k) = 0
            do 90 i=1,imax
               ou(j,k) = ou(j,k) + cv(j)*u(2,i,j,k)*dphi
   90       continue
            opsi(j,k) = opsi(j,k-1) - dz(k)*ou(j,k)
   80    continue
   70 continue
c
c Pacific and Atlantic overturning streamfunctions
c
      ominp = 0
      omaxp = 0
      do j=jsf+1,jmax-1
         do k=1,kmax-1
            ou(j,k) = 0
            do i=ips(j),ipf(j)
               ou(j,k) = ou(j,k) + cv(j)*u(2,i,j,k)*dphi
            enddo
            opsip(j,k) = opsip(j,k-1) - dz(k)*ou(j,k)
            if(opsip(j,k).lt.ominp.and.k.le.overdep)
     +           ominp = opsip(j,k)
            if(opsip(j,k).gt.omaxp.and.k.le.overdep)
     +           omaxp = opsip(j,k)
         enddo
      enddo

      omina = 0
      omaxa = 0
      do j=jsf+1,jmax-1
         do k=1,kmax-1
            ou(j,k) = 0
c conditionality to take care of "split Atlantic" (rma, 5/10/05)
            if(ias(j).gt.iaf(j)) then
               do i=ias(j),imax
                  ou(j,k) = ou(j,k) + cv(j)*u(2,i,j,k)*dphi
               enddo
               do i=1,iaf(j)
                  ou(j,k) = ou(j,k) + cv(j)*u(2,i,j,k)*dphi
               enddo
            else
               do i=ias(j),iaf(j)
                  ou(j,k) = ou(j,k) + cv(j)*u(2,i,j,k)*dphi
               enddo
            endif
            opsia(j,k) = opsia(j,k-1) - dz(k)*ou(j,k)
c           if(opsia(j,k).lt.omina)omina = opsia(j,k)
c           if(opsia(j,k).gt.omaxa)omaxa = opsia(j,k)
c AY (05/05/04)
c           if(opsia(j,k).lt.omina.and.k.le.kmax/2)omina = opsia(j,k)
c           if(opsia(j,k).gt.omaxa.and.k.le.kmax/2)omaxa = opsia(j,k)
            if(opsia(j,k).lt.omina.and.k.le.overdep)
     +           omina = opsia(j,k)
            if(opsia(j,k).gt.omaxa.and.k.le.overdep) then
               omaxa = opsia(j,k)
c AY (05/05/04) : position of Atlantic maximum overturning now recorded
               iposa(1) = j
               iposa(2) = k
            endif
         enddo
      enddo

      end


      program drran1
c>> 1996-05-28 DRRAN1 Krogh Added external statement.
c>> 1992-05-15 CLL  Added <CR> after final END.
c>> 1992-03-13 CLL
c   Demo driver for RAN1 and RANSIZ
c   Also references SRANU, SRANG, SRANUA
c     ------------------------------------------------------------------
      integer I, KSIZE
      external SRANU, SRANG
      real SRANU, SRANG, X(5), Y(5)
c     ------------------------------------------------------------------
      call RANSIZ(KSIZE)
      print'(a//a,i3)',' DRRAN1..  Demo driver for RAN1 and RANSIZ.',
     * ' RANSIZ returns KSIZE = ',KSIZE
      call SRANUA(X, 3)
      X(4) = SRANU()
      X(5) = SRANG()
      call RAN1
      call SRANUA(Y, 3)
      Y(4) = SRANU()
      Y(5) = SRANG()
      do 10 I=1,5
         if(X(I) .ne. Y(I)) then
            print'(/a/a/a/1x,i2,2g14.6)',
     *      ' Reinitialization of the random number generators by use',
     *      ' of RAN1 failed.  The following two floating-point',
     *      ' numbers should have been identical.',I, X(I), Y(I)
            stop
         endif
   10 continue
      print'(/a/a)',
     *      ' Reinitialization of the random number generators by use',
     *      ' of RAN1 succeeded.'
      end


! { dg-do "run" }

  INTEGER, PARAMETER :: n = 5
  INTEGER, PARAMETER :: a1(n) = SPREAD(1, 1, n)
  INTEGER, PARAMETER :: a2(n, 3) = SPREAD([1,2,3], DIM=1, NCOPIES=n)
  INTEGER, PARAMETER :: a3(3, n) = SPREAD([1,2,3], DIM=2, NCOPIES=n)

  IF (ANY(a1 /= [ 1, 1, 1, 1, 1 ])) CALL abort()

  IF (ANY(a2(:, 1) /= 1)) CALL abort()
  IF (ANY(a2(:, 2) /= 2)) CALL abort()
  IF (ANY(a2(:, 3) /= 3)) CALL abort()

  IF (ANY(a3(1, :) /= 1)) CALL abort()
  IF (ANY(a3(2, :) /= 2)) CALL abort()
  IF (ANY(a3(3, :) /= 3)) CALL abort()
END


PROGRAM wlOpacityAlignTest

  USE wlKindModule, ONLY: &
    dp
  USE wlOpacityTableModule, ONLY: &
    OpacityTableType
  USE wlIOModuleHDF, ONLY: &
    InitializeHDF, &
    FinalizeHDF
  USE wlOpacityTableIOModuleHDF, ONLY: &
    ReadOpacityTableHDF
  USE wlInterpolationModule, ONLY: &
    LogInterpolateSingleVariable_2D_Custom_Point, &
    LogInterpolateSingleVariable_2D2D_Custom_Point, &
    LogInterpolateSingleVariable_2D2D_Custom_Aligned

  IMPLICIT NONE

  INTEGER :: &
    i, j, k, l, iE, iX, n_rndm, Shape_H1(4)
  INTEGER, PARAMETER :: &
    iD = 1, iT = 2, iY = 3, &
    nPointsX = 2**16, &
    nPointsE = 2**05
  REAL(dp) :: &
    tBegin, tEnd
  REAL(dp), DIMENSION(nPointsE) :: &
    E, LogE
  REAL(dp), DIMENSION(nPointsX) :: &
    T, LogT, &
    Eta, LogEta, &
    rndm_T, &
    rndm_Eta
  REAL(dp), DIMENSION(nPointsE,nPointsE,nPointsX) :: &
    Interpolated_H1_0, &
    Interpolated_H1_1, &
    Interpolated_H1_2
  REAL(dp), ALLOCATABLE :: &
    Tabulated_H1(:,:,:,:), &
    Aligned_H1(:,:,:,:)
  TYPE(OpacityTableType) :: &
    OpTab

  CALL InitializeHDF( )

  CALL ReadOpacityTableHDF &
         ( OpTab, FileName_NES_Option &
             = 'wl-Op-SFHo-15-25-50-E40-B85-NES.h5', &
           Verbose_Option = .TRUE. )

  CALL FinalizeHDF( )

  WRITE(*,*)
  WRITE(*,'(A4,A12,ES10.4E2,A3,ES10.4E2)') &
    '', 'Max/Min E = ', OpTab % EnergyGrid % MinValue, &
    ' / ', OpTab % EnergyGrid % MaxValue
  WRITE(*,'(A4,A12,ES10.4E2,A3,ES10.4E2)') &
    '', 'Max/Min D = ', OpTab % EOSTable % TS % MinValues(iD), &
    ' / ', OpTab % EOSTable % TS % MaxValues(iD)
  WRITE(*,'(A4,A12,ES10.4E2,A3,ES10.4E2)') &
    '', 'Max/Min T = ', OpTab % EOSTable % TS % MinValues(iT), &
    ' / ', OpTab % EOSTable % TS % MaxValues(iT)
  WRITE(*,'(A4,A12,ES10.4E2,A3,ES10.4E2)') &
    '', 'Max/Min Y = ', OpTab % EOSTable % TS % MinValues(iY), &
    ' / ', OpTab % EOSTable % TS % MaxValues(iY)
  WRITE(*,*)
  WRITE(*,'(A4,A11,I10.10)') &
    '', 'nPointsX = ', nPointsX
  WRITE(*,'(A4,A11,I10.10)') &
    '', 'nPointsE = ', nPointsE
  WRITE(*,*)

  ! --- Energy Points ---

  ASSOCIATE &
    ( minE => OpTab % EnergyGrid % MinValue, &
      maxE => OpTab % EnergyGrid % MaxValue )

  DO iE = 1, nPointsE

    E(iE) = 10**( LOG10(minE) + ( LOG10(maxE) - LOG10(minE) ) &
                                * DBLE(iE) / DBLE(nPointsE+1) )

  END DO

  LogE = LOG10( E )

  END ASSOCIATE

  n_rndm = nPointsX

  ! --- Initialize Temperature Points ---

  CALL RANDOM_SEED( SIZE = n_rndm )
  CALL RANDOM_NUMBER( rndm_T )

  ASSOCIATE &
    ( minT => OpTab % EOSTable % TS % MinValues(iT), &
      maxT => OpTab % EOSTable % TS % MaxValues(iT) )

  T(:) = 10**( LOG10(minT) + ( LOG10(maxT) - LOG10(minT) ) * rndm_T )

  LogT = LOG10( T )

  END ASSOCIATE

  ! --- Initialize Degeneracy Parameter Points ---

  CALL RANDOM_SEED( SIZE = n_rndm )
  CALL RANDOM_NUMBER( rndm_Eta )

  ASSOCIATE &
    ( minEta => MINVAL( OpTab % EtaGrid % Values ), &
      maxEta => MAXVAL( OpTab % EtaGrid % Values ) )

  Eta(:) = 10**( LOG10(minEta) + ( LOG10(maxEta) - LOG10(minEta) ) * rndm_Eta )

  LogEta = LOG10( Eta )

  END ASSOCIATE

  ASSOCIATE &
    ( LogEs   => LOG10( OpTab % EnergyGrid      % Values ), &
         Es   =>        OpTab % EnergyGrid      % Values  , &
      LogTs   => LOG10( OpTab % TS % States(iT) % Values ), &
         Ts   =>        OpTab % TS % States(iT) % Values  , &
      LogEtas => LOG10( OpTab % EtaGrid         % Values ), &
         Etas =>        OpTab % EtaGrid         % Values  , &
      OS      => OpTab % Scat_NES % Offsets(1,1) )

  Shape_H1 = SHAPE( OpTab % Scat_NES % Kernel(1) % Values(:,:,1,:,:) )

  ALLOCATE( Tabulated_H1(Shape_H1(1),Shape_H1(2),Shape_H1(3),Shape_H1(4)) )

  Tabulated_H1 = OpTab % Scat_NES % Kernel(1) % Values(:,:,1,:,:)

  CALL CPU_TIME( tBegin )

  Interpolated_H1_0 = 0.0d0

  DO iX = 1, nPointsX

    CALL LogInterpolateSingleVariable_2D2D_Custom_Point &
           ( LogE, LogT(iX), LogEta(iX), LogEs, LogTs, LogEtas, &
             OS, Tabulated_H1, Interpolated_H1_0(:,:,iX) )

  END DO

  CALL CPU_TIME( tEnd )

  WRITE(*,*)
  WRITE(*,'(A4,A48,ES10.4E2)') &
    '', 'Interpolate H1 (Original): ', tEnd - tBegin

  ALLOCATE( Aligned_H1(SIZE(LogTs),SIZE(LogEtas),nPointsE,nPointsE) )

  CALL CPU_TIME( tBegin )

  DO l = 1, SIZE( LogEtas )
  DO k = 1, SIZE( LogTs   )
  DO j = 1, SIZE( E )
  DO i = 1, SIZE( E )

    CALL LogInterpolateSingleVariable_2D_Custom_Point &
           ( E(i), E(j), Es, Es, OS, Tabulated_H1(:,:,k,l), Aligned_H1(k,l,i,j) )

    Aligned_H1(k,l,i,j) = LOG10( Aligned_H1(k,l,i,j) + OS )

  END DO
  END DO
  END DO
  END DO

  CALL CPU_TIME( tEnd )

  WRITE(*,'(A4,A48,ES10.4E2)') &
    '', 'Align H1: ', tEnd - tBegin

  ! --- Initial Test of Aligned Interpolation ---

  CALL CPU_TIME( tBegin )

  Interpolated_H1_1 = 0.0d0

  DO j = 1, nPointsE
  DO i = 1, j

    DO iX = 1, nPointsX

      CALL LogInterpolateSingleVariable_2D_Custom_Point &
             ( T(iX), Eta(iX), Ts, Etas, OS, Aligned_H1(:,:,i,j), &
               Interpolated_H1_1(i,j,iX) )

    END DO

  END DO
  END DO

  CALL CPU_TIME( tEnd )

  WRITE(*,'(A4,A48,ES10.4E2)') &
    '', 'Interpolate H1 (Aligned 1): ', tEnd - tBegin
  WRITE(*,*)

  PRINT*, "  diff 1 = ", MAXVAL( ABS( Interpolated_H1_0 - Interpolated_H1_1 ) )
  PRINT*, "       0 = ", Interpolated_H1_0(1,1,1)
  PRINT*, "       1 = ", Interpolated_H1_1(1,1,1)

  ! --- Aligned Interpolation ---

  CALL CPU_TIME( tBegin )

  Interpolated_H1_2 = 0.0d0

  CALL LogInterpolateSingleVariable_2D2D_Custom_Aligned &
         ( LogT, LogEta, LogTs, LogEtas, OS, Aligned_H1, Interpolated_H1_2 )

  CALL CPU_TIME( tEnd )

  WRITE(*,'(A4,A48,ES10.4E2)') &
    '', 'Interpolate H1 (Aligned 2): ', tEnd - tBegin
  WRITE(*,*)

  print*, "  diff 2 = ", MAXVAL( ABS( Interpolated_H1_0 - Interpolated_H1_2 ) )
  PRINT*, "       0 = ", Interpolated_H1_0(1,1,1)
  PRINT*, "       1 = ", Interpolated_H1_2(1,1,1)

  END ASSOCIATE ! LogEs, etc.

  DEALLOCATE( Tabulated_H1 )
  DEALLOCATE( Aligned_H1 )

END PROGRAM wlOpacityAlignTest


!
!  time_integr_mod.f90
!
! This module contains routines used for time integration
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
module time_integr_mod
use nrtype ! contains kind parameters (DP), (DP), (I4B) etc.
   implicit none

contains

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! TimeIntegratorORK_SH_DGV
!
! This subroutine implements Optimal Runge Kutta integration in the spatially homogeneous case.
!
! It is dependent on the main program: uses variables from the
! commvar
!
! the called subroutines look up varaibles in commvar
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

SUBROUTINE TimeIntegratorORK_SH_DGV(f,dt)

USE commvar, only: rkmts, frhs1
USE spat_oper_mod

REAL (DP), DIMENSION (:), INTENT(OUT) :: f                  					! arrays to store the right hand side of the solution.
REAL (DP), intent(in) :: dt ! the time step

!!! LOCAL ARRAYS USED IN THE RK STEPS - NOT TO BE CONFUSED WITH THE SOLUTION STORAGE ARRAYS USED ELSEWHERE IN time_integrator_mod AND misc_setup_mod
REAL (DP), DIMENSION (:), ALLOCATABLE :: ft2, ft3, ft4							! auxiliary variables to keep intermediate time steps

!!! MISC. USEFUL LOCAL VARIABLES AND COUNTERS
INTEGER :: loc_alloc_stat
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SELECT CASE (rkmts)
	!!! RUNGE-KUTTA FIRST ORDER (EULER METHOD)
	CASE (1)
		CALL SpatialOperSH_DGV (f,frhs1,dt)
		f = f + frhs1
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!!! RUNGE KUTTA SECOND ORDER (OPTIMAL 2ND ORDER METHOD)
	CASE (2)
      !!! ALLOCATE THE ARRAYS NEEDED FOR THE RK STEPS
      ALLOCATE(ft2(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"TimeIntegratorORK_SH_DGV: Allocation error for variable (ft2)"
	  END IF
	  !!!!! BEGIN THE RUNGE-KUTTA STEP !!!!!
	  !!! t_1:
	  CALL SpatialOperSH_DGV (f, frhs1, dt)
      !!! t_2:
	  CALL SpatialOperSH_DGV (f + frhs1*2/3.0_DP, ft2, dt)
	  !!!!
	   f = f + frhs1/4.0_DP + ft2*3.0_DP/4
	  !!!!
	  deallocate(ft2)
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!! RUNGE KUTTA THIRD ORDER (OPTIMAL 3RD ORDER METHOD)
	CASE (3)
		!!! ALLOCATE THE ARRAYS NEEDED FOR THE RK STEPS
	  ALLOCATE(ft2(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"TimeIntegratorORK_SH_DGV: Allocation error for variable (ft2)"
	  END IF
	  ALLOCATE(ft3(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"TimeIntegratorORK_SH_DGV: Allocation error for variable (ft3)"
	  END IF
	  !!!!! BEGIN THE RUNGE-KUTTA STEP !!!!!
	  !!! t_1:
	  CALL SpatialOperSH_DGV (f, frhs1, dt)
	  !!! t_2:
	  CALL SpatialOperSH_DGV (f + frhs1/2.0_DP, ft2, dt)
	  !!! t_3:
	  CALL SpatialOperSH_DGV (f + ft2*3.0_DP/4, ft3, dt)

	  f = f + frhs1*2/9.0_DP + ft2*3.0_DP/9.0_DP + ft3*4/9.0_DP
	  deallocate (ft2,ft3)
	  !!! RUNGE-KUTTA FOURTH ORDER (RALSTON AND RABINOWITZ)
	CASE (4)
      !!! ALLOCATE THE ARRAYS NEEDED FOR THE RK STEPS
   	  ALLOCATE(ft2(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"TimeIntegratorORK_SH_DGV: Allocation error for variable (ft2)"
	  END IF
	  ALLOCATE(ft3(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"TimeIntegratorORK_SH_DGV: Allocation error for variable (ft3)"
	  END IF
      !!!!! BEGIN THE RUNGE-KUTTA STEP !!!!!
	  !!! t_1:
	  CALL SpatialOperSH_DGV (f, frhs1, dt)
      !!! t_2:
	  CALL SpatialOperSH_DGV (f + frhs1/2.0_DP, ft2, dt)
	  !!! t_3:
	  CALL SpatialOperSH_DGV (f + frhs1/4.0_DP + ft2/4.0_DP, ft3, dt)
	  !!! t_4:
	  CALL SpatialOperSH_DGV (f - ft2 + ft3*2, ft2, dt)
	  f = f + frhs1/6.0_DP + ft3*2/3.0_DP + ft2/6.0_DP  ! :2nd componenent is re-used for 4th component!
	  deallocate (ft2,ft3)
	!!! RUNGE-KUTTA FIFTH ORDER (RALSTON AND RABINOWITZ - COMPATIBLE WITH THE FOURTH ORDER)
	CASE (5)
	  !!! ALLOCATE THE ARRAYS NEEDED FOR THE RK STEPS
   	  ALLOCATE(ft2(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"TimeIntegratorORK_SH_DGV: Allocation error for variable (ft2)"
	  END IF
	  ALLOCATE(ft3(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"TimeIntegratorORK_SH_DGV: Allocation error for variable (ft3)"
	  END IF
      ALLOCATE(ft4(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"TimeIntegratorORK_SH_DGV: Allocation error for variable (ft4)"
	  END IF
	  !!!!! BEGIN THE RUNGE-KUTTA STEP !!!!!
	  !!! t_1:
	  CALL SpatialOperSH_DGV (f, frhs1, dt)
	  print *, "1"
	  !!! t_2:
	  CALL SpatialOperSH_DGV (f + frhs1/2.0_DP, ft2, dt)
	  print *, "2"
	  !!! t_3:
	  CALL SpatialOperSH_DGV (f + frhs1/4.0_DP + ft2/4.0_DP, ft3, dt)
	  print *, "3"
	  !!! t_4:
	  CALL SpatialOperSH_DGV (f - ft2 + ft3*2.0_DP, ft4, dt)
	  print *, "4"
	  !!! WE NOW INTRODUCE SOME MEMORY SAVINGS AND REPLACE FT3 WITH -FT2/5_DP+FT3*546/625_DP THAT IS GOING TO BE USED IN STEP 6
	  ft3 = -ft2/5.0_DP+ft3*546/625.0_DP
      !!! t_5:
	  !!! ON THIS STEP, WE RE-USE ft2 TO TAKE PLACE OF ft5
	  CALL SpatialOperSH_DGV (f + frhs1*7.0_DP/27.0_DP + ft2*10.0_DP/27.0_DP + ft4/27.0_DP, ft2, dt)
	  print *, "5"
	  !!! t_6:
	  !!! ON THIS STEP, WE RE-USE ft3 TO TAKE PLACE OF ft6
	  CALL SpatialOperSH_DGV (f + frhs1*28.0_DP/625.0_DP + ft3 + ft4*54/625.0_DP - ft2*378/625.0_DP, ft3, dt)
	  print *, "6"
	  f = f + frhs1/24.0_DP + ft4*5.0_DP/48.0_DP + ft2*27.0_DP/56.0_DP + ft3*125/336.0_DP
	  deallocate (ft2,ft3,ft4)
	CASE default
			PRINT *, "Unsupported degree of Runge-Kutta method passed"
			stop

END SELECT
	   frhs1 = frhs1/dt
END SUBROUTINE TimeIntegratorORK_SH_DGV

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! TimeIntegratorORK_SH_MPI_DGV
!
! This is an MPI verstion of the subroutine above
! This subroutine implements Optimal Runge Kutta integration in the spatially homogeneous case.
!
! the only change is the call of the MPI-enhanced spatial operator.. all the rest is the same...
! The spatial operator has an MPI fork
! It is dependent on the main program: uses variables from the
! commvar
!
! the called subroutines look up varaibles in commvar
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

SUBROUTINE TimeIntegratorORK_SH_MPI_DGV(f,dt)

USE commvar, only: rkmts, frhs1
USE spat_oper_mod

REAL (DP), DIMENSION (:), INTENT(OUT) :: f                  					! arrays to store the right hand side of the solution.
REAL (DP), intent(in) :: dt ! the time step

!!! LOCAL ARRAYS USED IN THE RK STEPS - NOT TO BE CONFUSED WITH THE SOLUTION STORAGE ARRAYS USED ELSEWHERE IN time_integrator_mod AND misc_setup_mod
REAL (DP), DIMENSION (:), ALLOCATABLE :: ft2, ft3, ft4							! auxiliary variables to keep intermediate time steps

!!! MISC. USEFUL LOCAL VARIABLES AND COUNTERS
INTEGER :: loc_alloc_stat
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

SELECT CASE (rkmts)
	!!! RUNGE-KUTTA FIRST ORDER (EULER METHOD)
	CASE (1)
		CALL SpatialOperSH_MPI_DGV (f,frhs1,dt)   ! HAS MPI FORK INSIDE
		f = f + frhs1
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!!! RUNGE KUTTA SECOND ORDER (OPTIMAL 2ND ORDER METHOD)
	CASE (2)
      !!! ALLOCATE THE ARRAYS NEEDED FOR THE RK STEPS
      ALLOCATE(ft2(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"TimeIntegratorORK_SH_DGV: Allocation error for variable (ft2)"
	  END IF
	  !!!!! BEGIN THE RUNGE-KUTTA STEP !!!!!
	  !!! t_1:
	  CALL SpatialOperSH_MPI_DGV (f, frhs1, dt)
      !!! t_2:
	  CALL SpatialOperSH_MPI_DGV (f + frhs1*2/3.0_DP, ft2, dt)
	  !!!!
	   f = f + frhs1/4.0_DP + ft2*3.0_DP/4
	  !!!!
	  deallocate(ft2)
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!! RUNGE KUTTA THIRD ORDER (OPTIMAL 3RD ORDER METHOD)
	CASE (3)
		!!! ALLOCATE THE ARRAYS NEEDED FOR THE RK STEPS
	  ALLOCATE(ft2(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"TimeIntegratorORK_SH_DGV: Allocation error for variable (ft2)"
	  END IF
	  ALLOCATE(ft3(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"TimeIntegratorORK_SH_DGV: Allocation error for variable (ft3)"
	  END IF
	  !!!!! BEGIN THE RUNGE-KUTTA STEP !!!!!
	  !!! t_1:
	  CALL SpatialOperSH_MPI_DGV (f, frhs1, dt)                       ! HAS MPI FORK INSIDE
	  !!! t_2:
	  CALL SpatialOperSH_MPI_DGV (f + frhs1/2.0_DP, ft2, dt)          ! HAS MPI FORK INSIDE
	  !!! t_3:
	  CALL SpatialOperSH_MPI_DGV (f + ft2*3.0_DP/4, ft3, dt)          ! HAS MPI FORK INSIDE

	  f = f + frhs1*2/9.0_DP + ft2*3.0_DP/9.0_DP + ft3*4/9.0_DP
	  deallocate (ft2,ft3)
	  !!! RUNGE-KUTTA FOURTH ORDER (RALSTON AND RABINOWITZ)
	CASE (4)
      !!! ALLOCATE THE ARRAYS NEEDED FOR THE RK STEPS
   	  ALLOCATE(ft2(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"TimeIntegratorORK_SH_DGV: Allocation error for variable (ft2)"
	  END IF
	  ALLOCATE(ft3(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"TimeIntegratorORK_SH_DGV: Allocation error for variable (ft3)"
	  END IF
      !!!!! BEGIN THE RUNGE-KUTTA STEP !!!!!
	  !!! t_1:
	  CALL SpatialOperSH_MPI_DGV (f, frhs1, dt)                               ! HAS MPI FORK INSIDE
      !!! t_2:
	  CALL SpatialOperSH_MPI_DGV (f + frhs1/2.0_DP, ft2, dt)                  ! HAS MPI FORK INSIDE
	  !!! t_3:
	  CALL SpatialOperSH_MPI_DGV (f + frhs1/4.0_DP + ft2/4.0_DP, ft3, dt)     ! HAS MPI FORK INSIDE
	  !!! t_4:
	  CALL SpatialOperSH_MPI_DGV (f - ft2 + ft3*2, ft2, dt)                   ! HAS MPI FORK INSIDE
	  f = f + frhs1/6.0_DP + ft3*2/3.0_DP + ft2/6.0_DP  ! :2nd componenent is re-used for 4th component!
	  deallocate (ft2,ft3)
	!!! RUNGE-KUTTA FIFTH ORDER (RALSTON AND RABINOWITZ - COMPATIBLE WITH THE FOURTH ORDER)
	CASE (5)
	  !!! ALLOCATE THE ARRAYS NEEDED FOR THE RK STEPS
   	  ALLOCATE(ft2(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"TimeIntegratorORK_SH_DGV: Allocation error for variable (ft2)"
	  END IF
	  ALLOCATE(ft3(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"TimeIntegratorORK_SH_DGV: Allocation error for variable (ft3)"
	  END IF
      ALLOCATE(ft4(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"TimeIntegratorORK_SH_DGV: Allocation error for variable (ft4)"
	  END IF
	  !!!!! BEGIN THE RUNGE-KUTTA STEP !!!!!
	  !!! t_1:
	  CALL SpatialOperSH_MPI_DGV (f, frhs1, dt)                                          ! HAS MPI FORK INSIDE
	  print *, "1"
	  !!! t_2:
	  CALL SpatialOperSH_MPI_DGV (f + frhs1/2.0_DP, ft2, dt)                             ! HAS MPI FORK INSIDE
	  print *, "2"
	  !!! t_3:
	  CALL SpatialOperSH_MPI_DGV (f + frhs1/4.0_DP + ft2/4.0_DP, ft3, dt)                ! HAS MPI FORK INSIDE
	  print *, "3"
	  !!! t_4:
	  CALL SpatialOperSH_MPI_DGV (f - ft2 + ft3*2.0_DP, ft4, dt)                         ! HAS MPI FORK INSIDE
	  print *, "4"
	  !!! WE NOW INTRODUCE SOME MEMORY SAVINGS AND REPLACE FT3 WITH -FT2/5_DP+FT3*546/625_DP THAT IS GOING TO BE USED IN STEP 6
	  ft3 = -ft2/5.0_DP+ft3*546/625.0_DP
      !!! t_5:
	  !!! ON THIS STEP, WE RE-USE ft2 TO TAKE PLACE OF ft5
	  CALL SpatialOperSH_MPI_DGV (f + frhs1*7.0_DP/27.0_DP + ft2*10.0_DP/27.0_DP + ft4/27.0_DP, ft2, dt) ! HAS MPI FORK INSIDE
	  print *, "5"
	  !!! t_6:
	  !!! ON THIS STEP, WE RE-USE ft3 TO TAKE PLACE OF ft6
	  CALL SpatialOperSH_MPI_DGV (f + frhs1*28.0_DP/625.0_DP + ft3 + ft4*54/625.0_DP - ft2*378/625.0_DP, ft3, dt) ! HAS MPI FORK INSIDE
	  print *, "6"
	  f = f + frhs1/24.0_DP + ft4*5.0_DP/48.0_DP + ft2*27.0_DP/56.0_DP + ft3*125/336.0_DP
	  deallocate (ft2,ft3,ft4)
	CASE default
			PRINT *, "Unsupported degree of Runge-Kutta method passed"
			stop

END SELECT
	   frhs1 = frhs1/dt

END SUBROUTINE TimeIntegratorORK_SH_MPI_DGV

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! TimeIntegratorMTS_HOV1D
!
! Modified by  Alex 10/21/2011
!
! This subroutine implements Multiple Step Time integration.
!
! It is dependent on the main program: uses variables from the
! common_variables_mod
!
! the called subroutines look up varaibles in common_variables_mod
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

SUBROUTINE TimeIntegratorMTS_SH_DGV(f,dt)

USE commvar, only: f1,f2,f3,f4,frhs1,frhs2,frhs3,frhs4, &
                    rkmts,frhs5,e_time
USE spat_oper_mod

REAL (DP), dimension (:), intent (out) :: f ! the solution at the current time step
REAL (DP), intent (in) :: dt ! the time step.

!!!!!!!!

SELECT CASE (rkmts)
	CASE (1)
	 !!! MTS FIRST ORDER (EULER METHOD)
	 CALL SpatialOperSH_DGV (f, frhs1, dt)
	 !
	 f = f + frhs1
     !!! END MTS 1ST ORDER (EULER METHOD)
	CASE (2)
	 !!! ADAMS-BASHFORTH TWO STEP EXPLICIT METHOD
	 f1 = f; frhs2 = frhs1 !! first we need to push the solution into the storage arrays
	 CALL SpatialOperSH_DGV (f, frhs1, dt)
	 f = f + frhs1*3.0_DP/2.0_DP - dt*frhs2/2.0_DP
	 !!! END ADAMS-BASHFORTH TWO STEP EXPLICIT METHOD
	CASE (3)
	 !!! BEGIN ADAMS-BASHFORTH THREE STEP
	 f2 = f1; f1 = f; frhs3 = frhs2; frhs2 = frhs1 !! first we need to push the solution into the storage arrays
	 CALL SpatialOperSH_DGV (f, frhs1, dt)
	 f = f + frhs1*23.0_DP/12.0_DP - dt*frhs2*4/3.0_DP + dt*frhs3*5.0_DP/12.0_DP
    !!! END ADAMS-BASHFORTH THREE STEP
	CASE (4)
   	 !!! ADAMS-BASHFORTH FOUR STEP
	 f3 = f2; f2 = f1; f1 = f; frhs4 = frhs3; frhs3 = frhs2; frhs2 = frhs1 !! first we need to push the solution into the storage arrays
	 CALL SpatialOperSH_DGV (f, frhs1, dt)
	 f = f + frhs1*55.0_DP/24.0_DP - dt*frhs2*59.0_DP/24.0_DP + dt*frhs3*37.0_DP/24.0_DP - dt*frhs4*3.0_DP/8
	 !!! END ADAMS-BASHFORTH FOUR STEP
	CASE (5)
	 !!! ADAMS-BASHFORTH FIVE STEP METHOD
	 f4 = f3; f3 = f2; f2 = f1; f1 = f
	 frhs5 = frhs4; frhs4 = frhs3; frhs3 = frhs2; frhs2 = frhs1 !! first we need to push the solution into the storage arrays
	 CALL SpatialOperSH_DGV (f, frhs1, dt)
	 f = f + frhs1*(1901.0_DP/720.0_DP) - dt*frhs2*(2774.0_DP/720.0_DP) + dt*frhs3*(2616.0_DP/720.0_DP) &
	       - dt*frhs4*(1274.0_DP/720.0_DP) + dt*frhs5*(251.0_DP/720.0_DP)
	 !!! END ADAMS-BASHFORTH FIVE STEP METHOD
    CASE default
	 PRINT *, "Unsupported degree of Multiple Time Stepping method passed"
	 stop
	END SELECT
    frhs1 = frhs1/dt
    e_time = e_time + dt ! advance the time for one step
END SUBROUTINE TimeIntegratorMTS_SH_DGV

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! TimeIntegratorMTS_MPI_SH_MPI_DGV
!
! Modified by  Alex 10/21/2011
!
! This subroutine implements Multiple Step Time integration.
!
!  This is an MPI analog of the above subroutine. SpatialOperSH_MPI_DGV has an MPI fork in it.
!
! It is dependent on the main program: uses variables from the
! common_variables_mod
!
! the called subroutines look up varaibles in common_variables_mod
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

SUBROUTINE TimeIntegratorMTS_SH_MPI_DGV(f,dt)

USE commvar, only: f1,f2,f3,f4,frhs1,frhs2,frhs3,frhs4, &
                    rkmts,frhs5,e_time
USE spat_oper_mod

REAL (DP), dimension (:), intent (out) :: f ! the solution at the current time step
REAL (DP), intent (in) :: dt ! the time step.

!!!!!!!!

SELECT CASE (rkmts)
	CASE (1)
	 !!! MTS FIRST ORDER (EULER METHOD)
	 CALL SpatialOperSH_MPI_DGV (f, frhs1, dt)
	 !
	 f = f + frhs1
     !!! END MTS 1ST ORDER (EULER METHOD)
	CASE (2)
	 !!! ADAMS-BASHFORTH TWO STEP EXPLICIT METHOD
	 f1 = f; frhs2 = frhs1 !! first we need to push the solution into the storage arrays
	 CALL SpatialOperSH_MPI_DGV (f, frhs1, dt)
	 f = f + frhs1*3.0_DP/2.0_DP - dt*frhs2/2.0_DP
	 !!! END ADAMS-BASHFORTH TWO STEP EXPLICIT METHOD
	CASE (3)
	 !!! BEGIN ADAMS-BASHFORTH THREE STEP
	 f2 = f1; f1 = f; frhs3 = frhs2; frhs2 = frhs1 !! first we need to push the solution into the storage arrays
	 CALL SpatialOperSH_MPI_DGV (f, frhs1, dt)
	 f = f + frhs1*23.0_DP/12.0_DP - dt*frhs2*4/3.0_DP + dt*frhs3*5.0_DP/12.0_DP
    !!! END ADAMS-BASHFORTH THREE STEP
	CASE (4)
   	 !!! ADAMS-BASHFORTH FOUR STEP
	 f3 = f2; f2 = f1; f1 = f; frhs4 = frhs3; frhs3 = frhs2; frhs2 = frhs1 !! first we need to push the solution into the storage arrays
	 CALL SpatialOperSH_MPI_DGV (f, frhs1, dt)
	 f = f + frhs1*55.0_DP/24.0_DP - dt*frhs2*59.0_DP/24.0_DP + dt*frhs3*37.0_DP/24.0_DP - dt*frhs4*3.0_DP/8
	 !!! END ADAMS-BASHFORTH FOUR STEP
	CASE (5)
	 !!! ADAMS-BASHFORTH FIVE STEP METHOD
	 f4 = f3; f3 = f2; f2 = f1; f1 = f
	 frhs5 = frhs4; frhs4 = frhs3; frhs3 = frhs2; frhs2 = frhs1 !! first we need to push the solution into the storage arrays
	 CALL SpatialOperSH_MPI_DGV (f, frhs1, dt)
	 f = f + frhs1*(1901.0_DP/720.0_DP) - dt*frhs2*(2774.0_DP/720.0_DP) + dt*frhs3*(2616.0_DP/720.0_DP) &
	       - dt*frhs4*(1274.0_DP/720.0_DP) + dt*frhs5*(251.0_DP/720.0_DP)
	 !!! END ADAMS-BASHFORTH FIVE STEP METHOD
    CASE default
	 PRINT *, "Unsupported degree of Multiple Time Stepping method passed"
	 stop
	END SELECT
    frhs1 = frhs1/dt
    e_time = e_time + dt ! advance the time for one step
END SUBROUTINE TimeIntegratorMTS_SH_MPI_DGV

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! subroutine PrepareMTS_SH_DGV
!
! Subroutine prepares the intermediate time steps to be used in the multi-step methods.
! f stores the actual solution.
! f1, f2, f3, f4, frhs1, frhs2, frhs3, frhs4 store the value of the
!	spatial operator and the right hand side on those intermediate time steps
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE PrepareMTS_SH_DGV (f, dt)

USE commvar, only:  f1, f2, f3, f4, frhs1, frhs2, frhs3, frhs4, &
							frhs5, rkmts, e_time
USE spat_oper_mod
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! DIAGNOSTIC A (use together with B)
USE dgvtools_mod, only: RecordMomDerivRelaxTimes_DGV
!! END DIAGNOSTIC A
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

REAL (DP), dimension (:) :: f ! the solution on the initial time step
REAL (DP), intent (in) :: dt ! the time step..

!!!!!! DECLARE LOCAL VARIABLES !!!!!
INTEGER :: i													! Local counters
INTEGER :: loc_alloc_stat ! to keep the allocation status
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! First, we need to allocate the storages
SELECT CASE(rkmts)
	CASE(1)
	  !!! ALLOCATE THE ARRAYS NEEDED FOR THE MTS STEPS
   	  ALLOCATE(frhs1(1:size(f,1)),f1(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"PrepareMTS_SH_DGV: Allocation error for variable (frhs1)"
		stop
	  END IF
	CASE(2)
	  !!! ALLOCATE THE ARRAYS NEEDED FOR THE MTS STEPS
   	  ALLOCATE(frhs1(1:size(f,1)),frhs2(1:size(f,1)),f1(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"PrepareMTS_SH_DGV: Allocation error for variable (frhs1,f1)"
		stop
	  END IF
	CASE(3)
	  !!! ALLOCATE THE ARRAYS NEEDED FOR THE MTS STEPS
   	  ALLOCATE(frhs1(1:size(f,1)),f1(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"PrepareMTS_SH_DGV: Allocation error for variable (frhs1,f1)"
		stop
	  END IF
	ALLOCATE(frhs2(1:size(f,1)),frhs3(1:size(f,1)),f2(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"PrepareMTS_SH_DGV: Allocation error for variable (frhs2,f2)"
		stop
	  END IF
	CASE(4)
	  !!! ALLOCATE THE ARRAYS NEEDED FOR THE MTS STEPS
   	  ALLOCATE(frhs1(1:size(f,1)),f1(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"PrepareMTS_SH_DGV: Allocation error for variable (frhs1,f1)"
		stop
	  END IF
	ALLOCATE(frhs2(1:size(f,1)),f2(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"PrepareMTS_SH_DGV: Allocation error for variable (frhs2,f2)"
		stop
	  END IF
	  ALLOCATE(frhs3(1:size(f,1)),frhs4(1:size(f,1)),f3(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"PrepareMTS_SH_DGV: Allocation error for variable (frhs3,f3)"
		stop
	  END IF
    CASE(5)
      !!! ALLOCATE THE ARRAYS NEEDED FOR THE MTS STEPS
   	  ALLOCATE(frhs1(1:size(f,1)),f1(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"PrepareMTS_SH_DGV: Allocation error for variable (frhs1,f1)"
		stop
	  END IF
	  ALLOCATE(frhs2(1:size(f,1)),f2(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"PrepareMTS_SH_DGV: Allocation error for variable (frhs2,f2)"
		stop
	  END IF
	ALLOCATE(frhs3(1:size(f,1)),f3(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"PrepareMTS_SH_DGV: Allocation error for variable (frhs3,f3)"
		stop
	  END IF
	  ALLOCATE(frhs4(1:size(f,1)),frhs5(1:size(f,1)),f4(1:size(f,1)), stat = loc_alloc_stat)
	  IF(loc_alloc_stat > 0) THEN
		PRINT *,"PrepareMTS_SH_DGV: Allocation error for variable (frhs4,f4)"
		stop
	  END IF
	CASE default
			PRINT *, "PrepareMTS_SH_DGV: The value of (rkmts) must be from 1 to 5. No such RK or MTS methods implemented"
			stop
END SELECT
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Now we assume that f contains the intial data. We need to set up the arrays
! If rkmts=1 - no action is needed all data is in place
! If the rkmts>2 then we need to actually prepare some arrays.
do i=2,rkmts
 !! FIRST WE NEED TO PUSH THE SOLUTION AND THE RIGHT SIDE DOWN THE STORAGE TO OPEN SOME SPACE FOR THE NEW DATA
 SELECT CASE(rkmts)
 CASE(2)
  f1=f
 CASE(3)
  f2=f1; f1=f; frhs2=frhs1
 CASE(4)
  f3=f2; f2=f1; f1=f; frhs3=frhs2; frhs2=frhs1
 CASE(5)
  f4=f3; f3=f2; f2=f1; f1=f; frhs4=frhs3; frhs3=frhs2; frhs2=frhs1
 CASE default
  PRINT *, "PrepareMTS_SH_DGV: The value of (rkmts) must be from 1 to 5. No such RK or MTS methods implemented"
  stop
 END SELECT
! now, the f contains the solution at the current time. We call the time integrator and then f will contain the next time step and
! frhs1 will contain the solution at the curent time.
!!! MPI FORK IS USED THERE !!!
 call TimeIntegratorORK_SH_MPI_DGV(f,dt)
!!! END OF the MPI FORK

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! DIAGNOSTIC B (use together with A)  call to record a derivatives of macroparameters and the relaxation times of macroparameters.
! The function will use the updated frhs1 directly from commvar and the old f can be found in f1;
! The time corresponds to the initial time step.
!!!!
call RecordMomDerivRelaxTimes_DGV(e_time)
!!!!
! END DIAGNOSTIC B (use together with A)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

 e_time = e_time+dt ! advance the time
end do
END SUBROUTINE PrepareMTS_SH_DGV

end module time_integr_mod


program cfd

  use mpi

  use boundary
  use jacobi
  use cfdio

  implicit none

! Output frequency

  integer, parameter :: printfreq = 1000

! Variables associated with convergence

  double precision :: localerror, error, localbnorm, bnorm

! Set tolerance for convergence; zero or negative means do not check

  double precision, parameter :: tolerance = 0.0

! Main arrays

  double precision, allocatable ::  psi(:,:), zet(:,:)
  double precision, allocatable ::  psitmp(:,:), zettmp(:,:)

! Command-line arguments

  integer :: scalefactor,  numiter

  double precision :: re  ! re = 3.7 seems to be stability limit with Jacobi

  integer, parameter :: maxline = 32
  character(len=maxline) :: tmparg

!  Basic sizes of simulation

  integer, parameter :: bbase = 10
  integer, parameter :: hbase = 15
  integer, parameter :: wbase =  5
  integer, parameter :: mbase = 32
  integer, parameter :: nbase = 32

  logical :: irrotational = .true., checkerr = .false.

!  Some auxiliary parameters and variables

  integer :: m, n, ln, b, h, w
  integer :: iter

  double precision :: tstart, tstop, ttot, titer, modvsq, hue

!  Variables needed for parallelisation

  integer :: comm, rank, size, ierr

!  Are we stopping based on tolerance?

  if (tolerance .gt. 0.0) checkerr = .true.

!  Parallel initialisation

  comm = MPI_COMM_WORLD

  call mpi_init(ierr)

  call mpi_comm_rank(comm, rank, ierr)
  call mpi_comm_size(comm, size, ierr)

!  Read in parameters

  if (command_argument_count() /= 2 .and. command_argument_count() /= 3) then

     if (rank == 0) write(*,*) 'Usage: cfd <scale> <numiter> [reynolds]'
     call mpi_finalize(ierr)
     stop

  end if

  if (rank == 0) then

     call get_command_argument(1, tmparg)
     read(tmparg,*) scalefactor
     call get_command_argument(2, tmparg)
     read(tmparg,*) numiter

     if (command_argument_count() == 3) then

        irrotational = .false.
        call get_command_argument(3, tmparg)
        read(tmparg,*) re

     else

        re = -1.0

     end if

     if (.not. checkerr) then
        write(*,fmt='('' Scale factor = '',i3,'', iterations = '', i6)') &
             scalefactor, numiter
     else
        write(*,fmt='('' Scale factor = '',i3,'', iterations = '', i6, &
             &'', tolerance = '', g11.4)') scalefactor, numiter, tolerance
     end if

     if (irrotational) then

        write(*,*) 'Irrotational flow'

     else

        write(*,fmt='('' Reynolds number = '', f6.3)') re

     end if

  end if

!  Broadcast runtime parameters to all the other processors

  call mpi_bcast(scalefactor,  1, MPI_INTEGER, 0, comm, ierr)
  call mpi_bcast(numiter,      1, MPI_INTEGER, 0, comm, ierr)
  call mpi_bcast(re, 1,  MPI_DOUBLE_PRECISION, 0, comm, ierr)
  call mpi_bcast(irrotational, 1, MPI_LOGICAL, 0, comm, ierr)

!  Calculate b, h & w and m & n

  b = bbase*scalefactor
  h = hbase*scalefactor
  w = wbase*scalefactor
  m = mbase*scalefactor
  n = nbase*scalefactor

  re = re / dble(scalefactor)

!  Calculate local size

  ln = n/size

!  Consistency check

  if (size*ln /= n) then

     if (rank == 0) write(*,*) 'ERROR: n = ', n, ' does not divide onto ', &
          size, ' processes'

     call mpi_finalize(ierr)
     stop

  end if

  if (rank == 0) then
     write(*,fmt='('' Running CFD on '', i4, '' x '', i4, '' grid using '', &
                  &i4, '' process(es)'')') m, n, size
  end if

!  Allocate arrays, including halos on psi and tmp

  allocate(psi(0:m+1, 0:ln+1))
  allocate(zet(0:m+1, 0:ln+1))

  allocate(psitmp(0:m+1, 0:ln+1))

  if (.not. irrotational) then

     allocate(zettmp(0:m+1, 0:ln+1))

  end if

!  Zero the psi array

  psi(:,:) = 0.0
  zet(:,:) = 0.0

!  Set the psi boundary condtions which are constant

   call boundarypsi(psi, m, ln, b, h, w, comm)

!  Compute normalisation factor for error

   localbnorm = sum(psi(:,:)**2)

!  Do a boundary swap of psi

   call haloswap(psi, m, ln, comm)

   if (.not. irrotational) then

!    Update the zeta boundary condtions which depend on psi

     call boundaryzet(zet, psi, m, ln, comm)

!    Update the normalisation

     localbnorm = localbnorm + sum(zet(:,:)**2)

!  Do a boundary swap of zeta

     call haloswap(zet, m, ln, comm)

  end if

  call mpi_allreduce(localbnorm, bnorm, 1, MPI_DOUBLE_PRECISION, &
                     MPI_SUM, comm, ierr)

   bnorm = sqrt(bnorm)

!  Begin iterative Jacobi loop

  if (rank == 0) then
     write(*,*)
     write(*,*) 'Starting main loop ...'
     write(*,*)
  end if

!  Barriers purely to get consistent timing - not needed for correctness

  call mpi_barrier(comm, ierr)

  tstart = mpi_wtime()

  do iter = 1, numiter

!  Compute the new psi based on the old one

     if (irrotational) then

!  Call function with no vorticity

        call jacobistep(psitmp, psi, m, ln)

     else

!  Call function containing vorticity

        call jacobistepvort(zettmp, psitmp, zet, psi, m, ln, re)

     end if

!  Compute current error value if required

     if (checkerr .or. iter == numiter) then

        localerror = deltasq(psitmp, psi, m, ln)

        if (.not. irrotational) then

           localerror = localerror + deltasq(zettmp, zet, m, ln)

        end if

        call mpi_allreduce(localerror, error, 1, MPI_DOUBLE_PRECISION, &
                           MPI_SUM, comm, ierr)

        error = sqrt(error)

        error = error / bnorm

     end if

!  Quit early if we have reached required tolerance

     if (checkerr) then
        if (error .lt. tolerance) then
           if (rank == 0) write(*,*) 'CONVERGED iteration ', iter, &
                                     ': terminating'
           exit
        end if
     end if

!  Copy back

     psi(1:m, 1:ln) = psitmp(1:m, 1:ln)

     if (.not. irrotational) then

        zet(1:m, 1:ln) = zettmp(1:m, 1:ln)

     end if

!  Do a boundary swap

     call haloswap(psi, m, ln, comm)

     if (.not. irrotational) then

        call haloswap(zet, m, ln, comm)

!    Update the zeta boundary condtions which depend on psi

        call boundaryzet(zet, psi, m, ln, comm)

     end if

!  End iterative Jacobi loop

     if (mod(iter,printfreq) == 0) then

        if (rank == 0) then

           if (.not. checkerr) then
              write(*,*) 'completed iteration ', iter
           else
              write(*,*) 'completed iteration ', iter, ', error = ', error
           end if

        end if
     end if

  end do

  if (iter .gt. numiter) iter = numiter

  call mpi_barrier(comm, ierr)

  tstop = mpi_wtime()

  ttot  = tstop-tstart
  titer = ttot/dble(iter)

  if (rank == 0) then

     write(*,*)
     write(*,*) '... finished'
     write(*,*)
     write(*,fmt='('' After    '', i6, '' iterations, error is '', g11.4)') &
          iter, error
     write(*,fmt='('' Time for '', i6, '' iterations was '',&
          &g11.4, '' seconds'')') iter, ttot
     write(*,fmt='('' Each individual iteration took '', g11.4, '' seconds'')') &
          titer
     write(*,*)
     write(*,*) 'Writing output file ...'

  end if

!  Output results

  call writedatafiles(psi, m, ln, scalefactor, comm)

!  Output gnuplot file

  if (rank == 0) then

     call writeplotfile(m, n, scalefactor)

  end if

! Finish

  call mpi_finalize(ierr)

  if (rank == 0) then
     write(*,*) ' ... finished'
     write(*,*)
     write(*,*) 'CFD completed'
     write(*,*)
  end if

end program cfd


SUBROUTINE trans(a, m, n, mn, iok)

! Code converted using TO_F90 by Alan Miller
! Date: 2003-06-03  Time: 17:05:40

! *****
!  ALGORITHM 380 - REVISED
! *****
!  A IS A ONE-DIMENSIONAL ARRAY OF LENGTH MN=M*N, WHICH CONTAINS THE MXN
!  MATRIX TO BE TRANSPOSED (STORED COLUMNWISE).
!  IOK INDICATES THE SUCCESS OR FAILURE OF THE ROUTINE.
!  NORMAL RETURN  IOK=0
!  ERRORS         IOK=-1 ,MN NOT EQUAL TO M*N
!                 IOK > 0, (SHOULD NEVER OCCUR), IN THIS CASE WE SET IOK
!  EQUAL TO THE FINAL VALUE OF I WHEN THE SEARCH IS COMPLETED BUT SOME LOOPS
!  HAVE NOT BEEN MOVED.
!  NOTE * MOVE(I) WILL STAY ZERO FOR FIXED POINTS

IMPLICIT NONE

REAL, INTENT(IN OUT)  :: a(:)
INTEGER, INTENT(IN)   :: m
INTEGER, INTENT(IN)   :: n
INTEGER, INTENT(IN)   :: mn
INTEGER, INTENT(OUT)  :: iok

! Local variables
INTEGER  :: i, i1, i2, i1c, i2c, im, ir0, ir1, ir2, j, j1, k, kmi,  &
            MAX, n1, ncount
REAL     :: b, c, d

!  MOVE IS A ONE-DIMENSIONAL ARRAY OF LENGTH IWRK USED TO STORE INFORMATION
!  TO SPEED UP THE PROCESS.  THE VALUE IWRK=(M+N)/2 IS RECOMMENDED.
INTEGER  :: iwrk
INTEGER  :: move( (m+n)/2 )

! CHECK ARGUMENTS AND INITIALIZE.
IF (m >= 2 .AND. n >= 2) THEN
  IF (mn /= m*n) GO TO 140
  IF (m == n) GO TO 90
  ncount = 2
  k = mn - 1
  iwrk = (m+n)/2
  move(1:iwrk) = 0
  IF (m >= 3 .AND. n >= 3) THEN

! CALCULATE THE NUMBER OF FIXED POINTS, EUCLIDS ALGORITHM FOR GCD(M-1,N-1).
    ir2 = m - 1
    ir1 = n - 1
    20     ir0 = MOD(ir2,ir1)
    ir2 = ir1
    ir1 = ir0
    IF (ir0 /= 0) GO TO 20
    ncount = ncount + ir2 - 1
  END IF

! SET INITIAL VALUES FOR SEARCH
  i = 1
  im = m
! AT LEAST ONE LOOP MUST BE RE-ARRANGED
  GO TO 60

! SEARCH FOR LOOPS TO REARRANGE
  30   MAX = k - i
  i = i + 1
  IF (i > MAX) GO TO 120
  im = im + m
  IF (im > k) im = im - k
  i2 = im
  IF (i == i2) GO TO 30
  IF (i > iwrk) GO TO 50
  IF (move(i) == 0) GO TO 60
  GO TO 30

  40   i2 = m * i1 - k * (i1/n)
  50   IF (i2 > i.AND.i2 < MAX) THEN
    i1 = i2
    GO TO 40
  END IF
  IF (i2 /= i) GO TO 30

! REARRANGE THE ELEMENTS OF A LOOP AND ITS COMPANION LOOP
  60   i1 = i
  kmi = k - i
  b = a(i1+1)
  i1c = kmi
  c = a(i1c+1)
  70   i2 = m * i1 - k * (i1/n)
  i2c = k - i2
  IF (i1 <= iwrk) move(i1) = 2
  IF (i1c <= iwrk) move(i1c) = 2
  ncount = ncount + 2
  IF (i2 /= i) THEN
    IF (i2 /= kmi) THEN
      a(i1+1) = a(i2+1)
      a(i1c+1) = a(i2c+1)
      i1 = i2
      i1c = i2c
      GO TO 70
    END IF

! FINAL STORE AND TEST FOR FINISHED
    d = b
    b = c
    c = d
  END IF
  a(i1+1) = b
  a(i1c+1) = c
  IF (ncount < mn) GO TO 30
END IF

! NORMAL RETURN
80 iok = 0
RETURN

! IF MATRIX IS SQUARE, EXCHANGE ELEMENTS A(I,J) AND A(J,I).
90 n1 = n - 1
DO  i = 1, n1
  j1 = i + 1
  DO  j = j1, n
    i1 = i + (j-1) * n
    i2 = j + (i-1) * m
    b = a(i1)
    a(i1) = a(i2)
    a(i2) = b
  END DO
END DO
GO TO 80

! ERROR RETURNS.
120 iok = i
130 RETURN
140 iok = -1
GO TO 130
END SUBROUTINE trans


        subroutine allocwrk
#ifdef USE_IMSL
        COMMON /WORKSP/  RWKSP
        REAL RWKSP(58388)
        CALL IWKIN(58388)
#endif
        return
        end
c=============================================================================c
        function calcs( ximax1, dxmin1, ds1)
c=============================================================================c
c       implicit double precision (a-h,o-z)
        parameter (zero=0.0d0, pt5=0.5d0, one=1.0d0, two=2.0d0)

        common /stuffs/ ximax, dxmin, ds

        external funcs, rtflsp
c=============================================================================c
        ximax = ximax1
        dxmin = dxmin1
        ds = ds1

c       calcs = rtflsp(funcs, 1.01d0, 1.02d0, 1.0d-14)
        calcs = zbrent(funcs, 1.0001e0, 1.2e0, 1.0e-14)

        return
        end
c=============================================================================c
        function funcs(sx)
c=============================================================================c
c       implicit double precision (a-h,o-z)
        parameter (zero=0.0d0, pt5=0.5d0, one=1.0d0, two=2.0d0)

        common /stuffs/ ximax, dxmin, ds
c=============================================================================c
        c2 = log( dxmin / ds )
        c1 = (log( sx*dxmin / ds) - c2) / ds

        funcs = ximax - one / c1 * ( exp(c1 + c2) - exp(c2) )

        return
        end
c=============================================================================c
        function calcdd(d1,d2)
c=============================================================================c
c       implicit double precision (a-h,o-z)
        parameter (zero=0.0d0, pt5=0.5d0, one=1.0d0, two=2.0d0)

        common /stuff/ rd1, rd2

        external func
c=============================================================================c
        rd1 = d1
        rd2 = d2

        dd1 = 3.0
        dd2 = 7.0

c       calcdd = rtflsp(func,dd1,dd2,1.0d-14)
        calcdd = zbrent(func,dd1,dd2,1.0e-14)

        return
        end
c=============================================================================c
        function func(x)
c=============================================================================c
c       implicit double precision (a-h,o-z)
        parameter (zero=0.0d0, pt5=0.5d0, one=1.0d0, two=2.0d0)

        common /stuff/ rd1, rd2
c=============================================================================c
        func = sinh(x)/x - one / sqrt(rd1 * rd2)

        return
        end


ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c        this is the end of the debugging code and the beginning
c        of the exponential representation routines
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c
c
        subroutine hwts3e(ier,eps,rk,cxs,cws,n)
        implicit real *8 (a-h,o-z)
        complex *16 cxs(*),cws(*)
        complex *16 rk,ima
        real *8, allocatable :: xs(:),ws(:)
        complex *16, allocatable :: xs1(:),ws1(:)
        data ima/(0.0d0,1.0d0)/
c
c
c       This subroutine returns the nodes and weights for
c       the exponential representation
c
c       exp(ima*rk*sqrt(u^2+v^2)/sqrt(u^2+v^2) =
c       \int_0^{+\infty} exp(-sqrt(t^2-rk^2)*t) J_0(tv) t/sqrt(t^2-rk^2) dt
c
c       u in [1,4], v in [0, 4*sqrt(2)]
c
c       All tables are valid in
c
c       rk range [0, 16*pi] \times [0, 12*pi]
c
c
c
c       Input parameter:
c
c       iprec - precision required:
c           iprec = 0 - 2 digits
c           iprec = 1 - 3 digits
c           iprec = 2 - 6 digits
c           iprec = 3 - 9 digits
c           iprec = 4 - 12 digits
c
c       Output parameters:
c
c       n - the number of nodes
c       cxs - the nodes: complex *16 (n)
c       cws - the weights: complex *16 (n)
c

        lxs = 10000
        allocate(xs(lxs),ws(lxs),xs1(lxs),ws1(lxs))

        n = 0
c
        ier = 0
c
        call hwts3dgetd(ier,rk,idomain)
c
ccc        call prinf('ier=*',ier,1)
ccc        write(*,*) 'idomain=*', idomain
ccc        call prinf('idomain=*',idomain,1)
c

        iprec = 0
        if(eps.lt.0.5d-2) iprec = 1
        if(eps.lt.0.5d-3) iprec = 2
        if(eps.lt.0.5d-6) iprec = 3
        if(eps.lt.0.5d-9) iprec = 4

        if( iprec .eq. 0 ) errmax = .1d-2
        if( iprec .eq. 1 ) errmax = .1d-3
        if( iprec .eq. 2 ) errmax = .1d-6
        if( iprec .eq. 3 ) errmax = .1d-9
        if( iprec .eq. 4 ) errmax = .1d-12

        if( iprec .eq. 0 ) call hwts3p0(idomain,xs,ws,n,iquadtype,err)
        if( iprec .eq. 1 ) call hwts3p1(idomain,xs,ws,n,iquadtype,err)
        if( iprec .eq. 2 ) call hwts3p2(idomain,xs,ws,n,iquadtype,err)
        if( iprec .eq. 3 ) call hwts3p3(idomain,xs,ws,n,iquadtype,err)
        if( iprec .eq. 4 ) call hwts3p4(idomain,xs,ws,n,iquadtype,err)

 1100   continue

ccc        write(*,*) 'iquad=*', iquad
ccc        call prinf('iquad=*',iquad,1)
ccc        pause
c
c
cc        call prinf('n=*',n,1)
cc        call prin2('xs=*',xs,n)
cc        call prin2('ws=*',ws,n)
cc        call prinf('iquadtype=*',iquadtype,1)
c
        do 1200 k=1,n
c
        if( iquadtype .eq. 1 ) then
        cxs(k)=sqrt(xs(k)**2-rk**2)
        cws(k)=ws(k)*xs(k)/sqrt(xs(k)**2-rk**2)
        endif

        if( iquadtype .eq. 2 ) then
        xmin=0
        xmax=100
        call linmap0(xs(k),u,uweight,xmin,xmax)
ccc           if( dble(rk) .gt. 1d0 ) then
ccc           xmid=dble(rk)
ccc           call linmap1(xs(k),u,uweight,xmin,xmax,xmid)
ccc           endif
c
        gamma=0
        v=u/(1+gamma*abs(dble(-ima*rk)))
        cxs(k)=u-ima*rk+abs(imag(-ima*rk))*ima*(v/(1+v))
        cws(k)=1+abs(imag(-ima*rk))*ima*((1+v)-v)/(1+v)**2
     $     /(1+gamma*abs(dble(-ima*rk)))
        cws(k)=cws(k)*ws(k)*uweight
        endif
c
        if( iquadtype .eq. 5 ) then
        xs1(k)=xs(k)-ima*atan(xs(k))
        ws1(k)=ws(k)*(1-ima/(1+xs(k)**2))
        cxs(k)=sqrt(xs1(k)**2-rk**2)
        cws(k)=ws1(k)*xs1(k)/sqrt(xs1(k)**2-rk**2)
        endif
c
 1200   continue
c
        return
        end

c
c
c
c
        subroutine linmap0(t,u,w,ax,bx)
        implicit real *8 (a-h,o-z)
c
c       this subroutine contructs a linear mapping from interval
c       [0,1] to [ax,bx]
c
        u=ax+t*(bx-ax)
        w=(bx-ax)
c
        return
        end
c
c
c
c
c
        subroutine linmap1(t,u,w,ax,bx,cx)
        implicit real *8 (a-h,o-z)
c
c       this subroutine contructs a piecewise linear mapping from interval
c       [0,1] to [ax,bx], such that [0,0.5]->[ax,cx], [0.5,1]->[cx,bx]
c
        if( t .le. 0.5d0 ) then
        u=ax+2*t*(cx-ax)
        w=2*(cx-ax)
        endif
c
        if( t .gt. 0.5d0 ) then
        u=cx+2*(t-0.5d0)*(bx-cx)
        w=2*(bx-cx)
        endif
c
        return
        end
c
c
c
c
c

        subroutine hwts3dgetd(ier,rk,idomain)
        implicit real *8 (a-h,o-z)
        complex *16 ima,rk
        dimension cx(100),cy(100)
        data ima/(0.0d0,1.0d0)/
c
        done=1
        pi=4*atan(done)
c
c       rk range [0, 16*pi] \times [0, 12*pi]
c
        nx=23
        ny=19
c
        cx(1)=0.00d0
        cx(2)=0.02d0
        cx(3)=0.04d0
        cx(4)=0.10d0
        cx(5)=0.20d0
        cx(6)=0.40d0
        cx(7)=1.00d0
        cx(8)=pi/2
        cx(9)=pi
        cx(10)=2*pi
        cx(11)=3*pi
        cx(12)=4*pi
        cx(13)=5*pi
        cx(14)=6*pi
        cx(15)=7*pi
        cx(16)=8*pi
        cx(17)=9*pi
        cx(18)=10*pi
        cx(19)=11*pi
        cx(20)=12*pi
        cx(21)=13*pi
        cx(22)=14*pi
        cx(23)=15*pi
        cx(24)=16*pi
c
        cy(1)=0.00d0
        cy(2)=0.02d0
        cy(3)=0.04d0
        cy(4)=0.10d0
        cy(5)=0.20d0
        cy(6)=0.40d0
        cy(7)=1.00d0
        cy(8)=pi/2
        cy(9)=pi
        cy(10)=2*pi
        cy(11)=3*pi
        cy(12)=4*pi
        cy(13)=5*pi
        cy(14)=6*pi
        cy(15)=7*pi
        cy(16)=8*pi
        cy(17)=9*pi
        cy(18)=10*pi
        cy(19)=11*pi
        cy(20)=12*pi
        cy(21)=13*pi
        cy(22)=14*pi
        cy(23)=15*pi
        cy(24)=16*pi
c
        rkrea=dble(rk)
        rkima=imag(rk)
c
        idomain = 0
        ier = 0
c
        ix=0
        do 1200 i=1,nx
        if( rkrea .ge. cx(i+1) ) ix=i+1
 1200   continue
c
 1300   continue
c
        iy=0
        do 2200 i=1,ny
        if( rkima .ge. cy(i+1) ) iy=i+1
 2200   continue
c
 2300   continue
c
ccc        write(*,*) rk
ccc        write(*,*) ix,iy
c
        if( ix .gt. nx ) ier = 4
        if( iy .gt. ny ) ier = 4
        if( ix .gt. nx ) return
        if( iy .gt. ny ) return
c
        if( ix .eq. 0 ) ix = 1
        if( iy .eq. 0 ) iy = 1
c
        if( ix .gt. nx ) ix = nx
        if( iy .gt. ny ) iy = ny
c
        idomain = ix + (iy-1) * nx
c
c        write(*,*) ix,iy
cc        write(*,*) idomain
c
ccc        stop
c
        return
        end
c
c
c
c
        subroutine getrkinfo2(inum,ndomains,rkmin,rkmax)
        implicit real *8 (a-h,o-z)
        complex *16 rkmin,rkmax,ima
        complex *16 cx(100),cy(100)
        data ima/(0.0d0,1.0d0)/
c
        done=1
        pi=4*atan(done)
c
c       rk range [0, 16*pi] \times [0, 12*pi]
c
        nx=23
        ny=19
c
        cx(1)=0.00d0
        cx(2)=0.02d0
        cx(3)=0.04d0
        cx(4)=0.10d0
        cx(5)=0.20d0
        cx(6)=0.40d0
        cx(7)=1.00d0
        cx(8)=pi/2
        cx(9)=pi
        cx(10)=2*pi
        cx(11)=3*pi
        cx(12)=4*pi
        cx(13)=5*pi
        cx(14)=6*pi
        cx(15)=7*pi
        cx(16)=8*pi
        cx(17)=9*pi
        cx(18)=10*pi
        cx(19)=11*pi
        cx(20)=12*pi
        cx(21)=13*pi
        cx(22)=14*pi
        cx(23)=15*pi
        cx(24)=16*pi
c
        cy(1)=0.00d0
        cy(2)=0.02d0
        cy(3)=0.04d0
        cy(4)=0.10d0
        cy(5)=0.20d0
        cy(6)=0.40d0
        cy(7)=1.00d0
        cy(8)=pi/2
        cy(9)=pi
        cy(10)=2*pi
        cy(11)=3*pi
        cy(12)=4*pi
        cy(13)=5*pi
        cy(14)=6*pi
        cy(15)=7*pi
        cy(16)=8*pi
        cy(17)=9*pi
        cy(18)=10*pi
        cy(19)=11*pi
        cy(20)=12*pi
        cy(21)=13*pi
        cy(22)=14*pi
        cy(23)=15*pi
        cy(24)=16*pi
c
        ndomains=nx*ny
c
        ix=mod(inum-1,nx)+1
        iy=(inum-1)/nx+1
c
        rkmin=cx(ix)+ima*cy(iy)
        rkmax=cx(ix+1)+ima*cy(iy+1)
c
        return
        end
c
c
c
c
c
        subroutine hwts3p0(idomain,xs,ws,n,iquadtype,err)
        implicit real *8 (a-h,o-z)
        dimension xs(*), ws(*)
c
        n = 0
        iquadtype = 0
c
        INCLUDE 'hwts_3d_iprec0.txt'
c
        return
        end
c
c
c
c
c
        subroutine hwts3p1(idomain,xs,ws,n,iquadtype,err)
        implicit real *8 (a-h,o-z)
        dimension xs(*), ws(*)
c
        n = 0
        iquadtype = 0
c
        INCLUDE 'hwts_3d_iprec1.txt'
c
        return
        end
c
c
c
c
c
        subroutine hwts3p2(idomain,xs,ws,n,iquadtype,err)
        implicit real *8 (a-h,o-z)
        dimension xs(*), ws(*)
c
        n = 0
        iquadtype = 0
c
        INCLUDE 'hwts_3d_iprec2.txt'
c
        return
        end
c
c
c
c
c
        subroutine hwts3p3(idomain,xs,ws,n,iquadtype,err)
        implicit real *8 (a-h,o-z)
        dimension xs(*), ws(*)
c
        n = 0
        iquadtype = 0
c
        INCLUDE 'hwts_3d_iprec3.txt'
c
        return
        end
c
c
c
c
c
        subroutine hwts3p4(idomain,xs,ws,n,iquadtype,err)
        implicit real *8 (a-h,o-z)
        dimension xs(*), ws(*)
c
        n = 0
        iquadtype = 0
c
        INCLUDE 'hwts_3d_iprec4.txt'
c
        return
        end
c
c
c
c
c


C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 1999 by UCAR                   *
C     *                                                               *
C     *       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                      FISHPACK version 4.1                     *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C
C     PROGRAM TO ILLUSTRATE THE USE OF HWSSSP
C
      DIMENSION       F(19,73)   ,BDTF(73)   ,SINT(19)   ,SINP(73)   ,
     1                W(600)
C
      PI = PIMACH(DUM)
      TS = 0
      TF = PI/2.
      M = 18
      MBDCND = 6
      PS = 0
      PF = PI+PI
      N = 72
      NBDCND = 0
      ELMBDA = 0.
      IDIMF = 19
C
C     GENERATE SINES FOR USE IN SUBSEQUENT COMPUTATIONS
C
      DTHETA = TF/FLOAT(M)
      MP1 = M+1
      DO 101 I=1,MP1
         SINT(I) = SIN(FLOAT(I-1)*DTHETA)
  101 CONTINUE
      DPHI = (PI+PI)/FLOAT(N)
      NP1 = N+1
      DO 102 J=1,NP1
         SINP(J) = SIN(FLOAT(J-1)*DPHI)
  102 CONTINUE
C
C     COMPUTE RIGHT SIDE OF EQUATION AND STORE IN F
C
      DO 104 J=1,NP1
         DO 103 I=1,MP1
            F(I,J) = 2.-6.*(SINT(I)*SINP(J))**2
  103    CONTINUE
  104 CONTINUE
C
C     STORE DERIVATIVE DATA AT THE EQUATOR
C
      DO 105 J=1,NP1
         BDTF(J) = 0.
  105 CONTINUE
C
      CALL HWSSSP (TS,TF,M,MBDCND,BDTS,BDTF,PS,PF,N,NBDCND,BDPS,BDPF,
     1             ELMBDA,F,IDIMF,PERTRB,IERROR,W)
C
C     COMPUTE DISCRETIZATION ERROR. SINCE PROBLEM IS SINGULAR, THE
C     SOLUTION MUST BE NORMALIZED.
C
      ERR = 0
      DO 107 J=1,NP1
         DO 106 I=1,MP1
            Z = ABS(F(I,J)-(SINT(I)*SINP(J))**2-F(1,1))
            IF (Z .GT. ERR) ERR = Z
  106    CONTINUE
  107 CONTINUE
C
      IW = INT(W(1))
      PRINT 1001 , IERROR,ERR,IW
      STOP IERROR
C
C
 1001 FORMAT (1H1,20X,25HSUBROUTINE HWSSSP EXAMPLE///
     1        10X,46HTHE OUTPUT FROM THE NCAR CONTROL DATA 7600 WAS//
     2        32X,10HIERROR = 0/
     3        18X,34HDISCRETIZATION ERROR = 3.38107E-03/
     4        12X,32HREQUIRED LENGTH OF W ARRAY = 600//
     5        10X,32HTHE OUTPUT FROM YOUR COMPUTER IS//
     6        32X,8HIERROR =,I2/18X,22HDISCRETIZATION ERROR =,E12.5 /
     7        12X,28HREQUIRED LENGTH OF W ARRAY =,I4)
C
      END


!
! Spline_Interpolation
!
! Module containing spline interpolation routines
!
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, CIMSS/SSEC 06-Oct-2006
!                       paul.vandelst@ssec.wisc.edu
!

MODULE Spline_Interpolation

  ! ------------------
  ! Environment set up
  ! ------------------
  ! Modules used
  USE Type_Kinds,      ONLY: fp=>fp_kind
  USE Message_Handler, ONLY: SUCCESS, FAILURE, Display_Message
  USE Search_Utility,  ONLY: Value_Locate, Bisection_Search
  ! Disable all implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  PRIVATE
  PUBLIC :: Spline_Interpolate
  PUBLIC :: Spline_Initialize

  ! ---------------------
  ! Procedure overloading
  ! ---------------------
  INTERFACE Spline_Interpolate
    MODULE PROCEDURE splint_scalar
    MODULE PROCEDURE splint_rank1
  END INTERFACE Spline_Interpolate

  ! -----------------
  ! Module parameters
  ! -----------------
  ! RCS Id field
  CHARACTER(*), PRIVATE, PARAMETER :: MODULE_RCS_ID = &
  ! Literal constants
  REAL(fp), PARAMETER :: ZERO = 0.0_fp
  REAL(fp), PARAMETER :: ONE  = 1.0_fp
  REAL(fp), PARAMETER :: TWO  = 2.0_fp
  REAL(fp), PARAMETER :: SIX  = 6.0_fp
  REAL(fp), PARAMETER :: TOLERANCE = EPSILON( ZERO )

CONTAINS

!------------------------------------------------------------------------------
!
! NAME:
!       Spline_Initialize
!
! PURPOSE:
!       Function is called to establish the type of interpolating
!       spline for a tabulated set of functional values,
!           Xi, Yi = F(Xi)
!
! CALLING SEQUENCE:
!       Error_Status = Spline_Initialize( x,                      &  ! Input
!                                         y,                      &  ! Input
!                                         y2,                     &  ! Output
!                                         RCS_Id     =RCS_Id,     &  ! Optional output
!                                         Message_Log=Message_Log )  ! Error messaging
! INPUT ARGUMENTS:
!       x:            The abscissa values for the tabulated function, y=F(x).
!                     Must be monotonically ascending values.
!                     UNITS:      Data dependent.
!                     TYPE:       REAL(fp)
!                     DIMENSION:  Rank-1 array
!                     ATTRIBUTES: INTENT(IN)
!
!       y:            An input vector of tabulated values, y=F(x), for which
!                     interpolates are required. Must have the same number of
!                     elements as the X input argument.
!                     UNITS:      Data dependent.
!                     TYPE:       REAL(fp)
!                     DIMENSION:  Rank-1 array
!                     ATTRIBUTES: INTENT(IN)
!
! OPTIONAL INPUT ARGUMENTS:
!       Message_Log:  Character string specifying a filename in which any
!                     messages will be logged. If not specified, or if an
!                     error occurs opening the log file, the default action
!                     is to output messages to the screen.
!                     UNITS:      N/A
!                     TYPE:       CHARACTER(*)
!                     DIMENSION:  Scalar
!                     ATTRIBUTES: OPTIONAL, INTENT(IN)
!
! OUTPUT ARGUMENTS:
!       y2:           Values of the second derivative of the interpolating
!                     function at the points defined by X. Must have the same
!                     number of elements as the X/Y input arguments.
!                     UNITS:      Data dependent.
!                     TYPE:       REAL(fp)
!                     DIMENSION:  Rank-1 array
!                     ATTRIBUTES: INTENT(IN)
!
! OPTIONAL OUTPUT ARGUMENTS:
!       RCS_Id:       Character string containing the Revision Control System
!                     Id field for the module.
!                     UNITS:      N/A
!                     TYPE:       CHARACTER(*)
!                     DIMENSION:  Scalar
!                     ATTRIBUTES: OPTIONAL, INTENT(OUT)
!
! FUNCTION RESULT:
!       Error_Status: The return value is an integer defining the error status.
!                     The error codes are defined in the Message_Handler module.
!                     If == SUCCESS the function executed normally.
!                        == FAILURE an unrecoverable error occurred.
!                     UNITS:      N/A
!                     TYPE:       INTEGER
!                     DIMENSION:  Scalar
!
! RESTRICTIONS:
!       Input X vectors *must* be monotonically ascending.
!
! PROCEDURE:
!       Adapted from SPL_INIT in "Numerical Recipes in FORTRAN; The Art of
!       Scientific Computing" 2nd ed. by W.H. Press et al., Cambridge University
!       Press, 1992, New York, New York, pp109.
!
!       SPLINE_INITIALIZE should be called only *once* to process an entire
!       tabulated function in the input arrays X and Y. Once this has been
!       done, values of the interpolated function for any value of X can be
!       obtained by calls to the separate routine SPLINE_INTERPOLATE.
!
! CREATION HISTORY:
!       Written by:   Paul van Delst, CIMSS/SSEC, 22-Mar-1996
!                     paul.vandelst@ssec.wisc.edu
!
!------------------------------------------------------------------------------

  FUNCTION Spline_Initialize( x,            &  ! Input
                              y,            &  ! Input
                              y2,           &  ! Output
                              RCS_Id,       &  ! Optional output
                              Message_Log ) &  ! Error messaging
                            RESULT ( Error_Status )
    ! Arguments
    REAL(fp), DIMENSION(:), INTENT(IN)  :: x
    REAL(fp), DIMENSION(:), INTENT(IN)  :: y
    REAL(fp), DIMENSION(:), INTENT(OUT) :: y2
    CHARACTER(*), OPTIONAL, INTENT(OUT) :: RCS_Id
    CHARACTER(*), OPTIONAL, INTENT(IN)  :: Message_Log
    ! Function result
    INTEGER :: Error_Status
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Spline_Initialize'
    ! Local variables
    INTEGER :: i
    INTEGER :: n
    REAL(fp) :: p
    REAL(fp) :: qn
    REAL(fp) :: sig
    REAL(fp) :: un
    REAL(fp) :: numer1
    REAL(fp) :: numer2
    REAL(fp) :: numerator
    REAL(fp) :: denominator
    REAL(fp) :: offset
    REAL(fp), DIMENSION(SIZE(x)) :: u

    ! ------
    ! Set up
    ! ------
    Error_Status = SUCCESS
    IF ( PRESENT( RCS_Id ) ) RCS_Id = MODULE_RCS_Id

    ! Are vector sizes consistent?
    n = SIZE(x)
    IF ( SIZE(y) /= n ) THEN
      Error_Status = FAILURE
      CALL Display_Message( ROUTINE_NAME, &
                            'Input X, Y arguments are different sizes.', &
                            Error_Status, &
                            Message_Log=Message_Log )
      RETURN
    END IF

    IF ( SIZE(y2) /= n ) THEN
      Error_Status = FAILURE
      CALL Display_Message( ROUTINE_NAME, &
                            'Output Y2 argument has inconsistent size.', &
                            Error_Status, &
                            Message_Log=Message_Log )
      RETURN
    END IF

    ! Is X-data in ascending order?
    u(1:n-1) = x(2:n) - x(1:n-1)
    IF ( ANY( u(1:n-1) < TOLERANCE ) ) THEN
      Error_Status = FAILURE
      CALL Display_Message( ROUTINE_NAME, &
                            'Input X data must be in ascending order', &
                            Error_Status, &
                            Message_Log=Message_Log )
      RETURN
    END IF

    ! ---------------------------------------
    ! Set second derivative at lower boundary
    ! ---------------------------------------
    y2(1) = ZERO
    u(1)  = ZERO

    ! -------------------------------------------------
    ! Begin decomposition loop of tridiagonal algorithm
    ! -------------------------------------------------
    DO i = 2, n - 1
      sig     = ( x(i) - x(i-1) ) / ( x(i+1) - x(i-1) )
      p       = ( sig * y2( i-1 ) ) + TWO
      y2( i ) = ( sig - ONE ) / p

      numer1    = ( y(i+1) - y(i) ) / ( x(i+1) - x(i) )
      numer2    = ( y(i) - y(i-1) ) / ( x(i) - x(i-1) )
      numerator   = SIX * ( numer1 - numer2 )
      denominator = x(i+1) - x(i-1)
      offset      = sig * u(i-1)

      u( i ) = ( ( numerator / denominator ) - offset ) / p
    END DO

    ! ---------------------------------------
    ! Set second derivative at upper boundary
    ! ---------------------------------------
    qn = ZERO
    un = ZERO
    y2( n ) = ( un - ( qn * u(n-1) ) ) / ( ( qn * y2(n-1) ) + ONE )

    ! ----------------------------------------------
    ! Backsubstitution loop of tridiagonal algorithm
    ! ----------------------------------------------
    DO i = n - 1, 1, -1
      y2( i ) = ( y2(i) * y2(i+1) ) + u(i)
    END DO

  END FUNCTION Spline_Initialize

!--------------------------------------------------------------------------------
!
! NAME:
!       Spline_Interpolate
!
! PURPOSE:
!       Function to calculate the cubic-spline interpolated value of a tabulated
!       function, X, Y=F(X), at a given value of Xi.
!
! CALLING SEQUENCE:
!       Error_Status = Spline_Interpolate( x,                      &  ! Input
!                                          y,                      &  ! Input
!                                          x_int,                  &  ! Input
!                                          y_int,                  &  ! Output
!                                          y2         =y2,         &  ! Optional input
!                                          RCS_Id     =RCS_Id,     &  ! Optional output
!                                          Message_Log=Message_Log )  ! Error messaging
!
! INPUTS:
!       x:            The abscissa values for the tabulated function, y=F(x).
!                     Must be monotonically ascending values.
!                     UNITS:      Data dependent.
!                     TYPE:       REAL(fp)
!                     DIMENSION:  Rank-1 array
!                     ATTRIBUTES: INTENT(IN)
!
!       y:            An input vector of tabulated values, y=F(x), for which
!                     interpolates are required. Must have the same number of
!                     elements as the X input argument.
!                     UNITS:      Data dependent.
!                     TYPE:       REAL(fp)
!                     DIMENSION:  Rank-1 array
!                     ATTRIBUTES: INTENT(IN)
!
!       x_int:        Abscissa values for which interpolates are required.
!                     Must be monotonically ascending or descending in the
!                     same direction as the X input argument.
!                     UNITS:      Data dependent, same as x.
!                     TYPE:       REAL(fp)
!                     DIMENSION:  Scalar or Rank-1 array
!                     ATTRIBUTES: INTENT(IN)
!
! OPTIONAL INPUTS:
!       y2:           Values of the second derivative of the interpolating
!                     function at the points defined by X. Must have the same
!                     number of elements as the X/Y input arguments.
!                     If this argument is not supplied, it is obtained via a
!                     call to SPLINE_INITIALIZE.
!                     UNITS:      Data dependent.
!                     TYPE:       REAL(fp)
!                     DIMENSION:  Rank-1 array
!                     ATTRIBUTES: INTENT(IN)
!
!       Message_Log:  Character string specifying a filename in which any
!                     messages will be logged. If not specified, or if an
!                     error occurs opening the log file, the default action
!                     is to output messages to the screen.
!                     UNITS:      N/A
!                     TYPE:       CHARACTER(*)
!                     DIMENSION:  Scalar
!                     ATTRIBUTES: OPTIONAL, INTENT(IN)
!
! OUTPUTS:
!       y_int:        Interpolate values corresponding to the X_INT abscissa
!                     values. Must have the same number of elements as the
!                     X_INT input argument.
!                     UNITS:      Data dependent, same as y.
!                     TYPE:       REAL(fp)
!                     DIMENSION:  Scalar or Rank-1 array
!                     ATTRIBUTES: INTENT(OUT)
!
! OPTIONAL OUTPUT ARGUMENTS:
!       RCS_Id:       Character string containing the Revision Control System
!                     Id field for the module.
!                     UNITS:      N/A
!                     TYPE:       CHARACTER(*)
!                     DIMENSION:  Scalar
!                     ATTRIBUTES: OPTIONAL, INTENT(OUT)
!
! FUNCTION RESULT:
!       Error_Status: The return value is an integer defining the error status.
!                     The error codes are defined in the Message_Handler module.
!                     If == SUCCESS the function executed normally.
!                        == FAILURE an unrecoverable error occurred.
!                     UNITS:      N/A
!                     TYPE:       INTEGER
!                     DIMENSION:  Scalar
!
! RESTRICTIONS:
!       Input X vectors *must* be monotonically ascending.
!
! PROCEDURE:
!       Taken from "Numerical Recipes in FORTRAN; The Art of Scientific Computing"
!       2nd ed. by W.H. Press et al., Cambridge University Press, 1992, New York,
!       New York, pp109.
!
!       Given arrays of a tabulated function, X and Y = F(X), and optionally
!       the array of the second derivatives of the interpolating function at
!       the points X, SPLINE_INTERPOLATE calculates a cubic-spline interpolated
!       value for the given value(s) of Xi.
!
! CREATION HISTORY:
!       Written by:   Paul van Delst, CIMSS/SSEC, 22-Mar-1996
!                     paul.vandelst@ssec.wisc.edu
!
!--------------------------------------------------------------------------------

  FUNCTION splint_scalar( x,            &  ! Input
                          y,            &  ! Input
                          x_int,        &  ! Input
                          y_int,        &  ! Output
                          y2,           &  ! Optional input
                          RCS_Id,       &  ! Optional output
                          Message_Log ) &  ! Error messaging
                        RESULT ( Error_Status )
    ! Arguments
    REAL(fp),               DIMENSION(:), INTENT(IN)  :: x
    REAL(fp),               DIMENSION(:), INTENT(IN)  :: y
    REAL(fp),                             INTENT(IN)  :: x_int
    REAL(fp),                             INTENT(OUT) :: y_int
    REAL(fp),     OPTIONAL, DIMENSION(:), INTENT(IN)  :: y2
    CHARACTER(*), OPTIONAL,               INTENT(OUT) :: RCS_Id
    CHARACTER(*), OPTIONAL,               INTENT(IN)  :: Message_Log
    ! Function result
    INTEGER :: Error_Status
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Spline_Interpolate(scalar)'
    ! Local variables
    CHARACTER(256) :: Message
    INTEGER :: n
    INTEGER :: i_lo, i_hi
    REAL(fp) :: a, b, dx
    REAL(fp), DIMENSION(SIZE(x)) :: y2_derivative

    ! ------
    ! Set up
    ! ------
    Error_Status = SUCCESS
    IF ( PRESENT( RCS_Id ) ) RCS_Id = MODULE_RCS_Id

    ! Are vector sizes consistent?
    n = SIZE(x)
    IF ( SIZE(y) /= n ) THEN
      Error_Status = FAILURE
      CALL Display_Message( ROUTINE_NAME, &
                            'Input X, Y arguments are different sizes.', &
                            Error_Status, &
                            Message_Log=Message_Log )
      RETURN
    END IF

    ! Check for second derivatives
    IF ( PRESENT( y2 ) ) THEN
      IF ( SIZE( y2 ) /= n ) THEN
        Error_Status = FAILURE
        CALL Display_Message( ROUTINE_NAME, &
                              'Input Y2 argument has inconsistent size.', &
                              Error_Status, &
                              Message_Log=Message_Log )
        RETURN
      END IF
      y2_derivative = y2
    ELSE
      ! Calculate them. This is inefficient so should only be done
      ! if X and Y are different each call.
      Error_Status = Spline_Initialize( x, y, y2_derivative,    &
                                        Message_Log=Message_Log )
      IF ( Error_Status /= SUCCESS ) THEN
        CALL Display_Message( ROUTINE_NAME, &
                              'Error occurred in spline initialisation function.', &
                              Error_Status, &
                              Message_Log=Message_Log )
        RETURN
      END IF
    END IF

    ! ---------------------------------------------------------
    ! Find the x-values in x that bracket the input x_int value
    ! by means of bisection. This is optimal if sequential
    ! calls to this function are at random values of x_int.
    ! ---------------------------------------------------------
    i_lo = MAX( 1, Bisection_Search( x, x_int ) )
    i_hi = MIN( i_lo + 1, n )

    ! ---------------------
    ! Calculate dx and test
    ! ---------------------
    dx = x(i_hi) - x(i_lo)
    IF ( dx < TOLERANCE ) THEN
      Error_Status = FAILURE
      WRITE( Message, '( "Error : dx < or = 0. i_lo, i_hi : ", i6, 2x, i6, &
                        &" x(i_lo), x(i_hi) : ", f12.6, 2x, f12.6 )' ) &
                      i_lo, i_hi, x(i_lo), x(i_hi)
      CALL Display_Message( ROUTINE_NAME, &
                            TRIM( Message ), &
                            Error_Status, &
                            Message_Log=Message_Log )
      RETURN
    END IF

    ! ---------------------
    ! Evaluate cubic dpline
    ! ---------------------
    a = ( x(i_hi) - x_int ) / dx
    b = ( x_int - x(i_lo) ) / dx
    y_int = ( a * y(i_lo) ) + ( b * y(i_hi) ) + &
            ( ( ( (a**3) - a ) * y2_derivative(i_lo) ) + &
              ( ( (b**3) - b ) * y2_derivative(i_hi) )   ) * &
            (dx*dx) / SIX

  END FUNCTION splint_scalar

  FUNCTION splint_rank1( x,            &  ! Input
                         y,            &  ! Input
                         x_int,        &  ! Input
                         y_int,        &  ! Output
                         y2,           &  ! Optional input
                         RCS_Id,       &  ! Optional output
                         Message_Log ) &  ! Error messaging
                       RESULT ( Error_Status )
    ! Arguments
    REAL(fp),               DIMENSION(:), INTENT(IN)  :: x      ! N
    REAL(fp),               DIMENSION(:), INTENT(IN)  :: y      ! N
    REAL(fp),               DIMENSION(:), INTENT(IN)  :: x_int  ! N_int
    REAL(fp),               DIMENSION(:), INTENT(OUT) :: y_int  ! N_int
    REAL(fp),     OPTIONAL, DIMENSION(:), INTENT(IN)  :: y2     ! N
    CHARACTER(*), OPTIONAL,               INTENT(OUT) :: RCS_Id
    CHARACTER(*), OPTIONAL,               INTENT(IN)  :: Message_Log
    ! Function result
    INTEGER :: Error_Status
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Spline_Interpolate(rank-1)'
    ! Local variables
    CHARACTER(256) :: Message
    INTEGER :: n, n_int
    INTEGER :: i
    REAL(fp)  :: a, b, dx
    INTEGER,  DIMENSION(SIZE(x_int)) :: i_lo, i_hi
    REAL(fp), DIMENSION(SIZE(x))     :: y2_derivative

    ! ------
    ! Set up
    ! ------
    Error_Status = SUCCESS
    IF ( PRESENT( RCS_Id ) ) RCS_Id = MODULE_RCS_Id

    ! Are input vector sizes consistent?
    n = SIZE(x)
    IF ( SIZE(y) /= n ) THEN
      Error_Status = FAILURE
      CALL Display_Message( ROUTINE_NAME, &
                            'Input X, Y arguments are different sizes.', &
                            Error_Status, &
                            Message_Log=Message_Log )
      RETURN
    END IF

    ! Are interpolate vector sizes consistent?
    n_int = SIZE(x_int)
    IF ( SIZE(y_int) /= n_int ) THEN
      Error_Status = FAILURE
      CALL Display_Message( ROUTINE_NAME, &
                            'Interpolate X_INT, Y_INT arguments are different sizes.', &
                            Error_Status, &
                            Message_Log=Message_Log )
      RETURN
    END IF

    ! Check for second derivatives
    IF ( PRESENT(y2) ) THEN
      IF ( SIZE(y2) /= n ) THEN
        Error_Status = FAILURE
        CALL Display_Message( ROUTINE_NAME, &
                              'Input Y2 argument has inconsistent size.', &
                              Error_Status, &
                              Message_Log=Message_Log )
        RETURN
      END IF
      y2_derivative = y2
    ELSE
      ! Calculate them.
      Error_Status = Spline_Initialize( x, y, y2_derivative,    &
                                        Message_Log=Message_Log )
      IF ( Error_Status /= SUCCESS ) THEN
        CALL Display_Message( ROUTINE_NAME, &
                              'Error occurred in spline initialisation function.', &
                              Error_Status, &
                              Message_Log=Message_Log )
        RETURN
      END IF
    END IF

    ! ---------------------------------------------------------
    ! Find the x-values in x that bracket the input x_int value
    ! by means of bisection. This is optimal if sequential
    ! calls to this function are at random values of x_int.
    ! ---------------------------------------------------------
    i_lo = Value_Locate( x, x_int )
    i_hi = i_lo + 1

    ! ----------------------------
    ! Calculate interpolated array
    ! ----------------------------
    DO i = 1, n_int

      ! Calculate dx and test
      dx = x(i_hi(i)) - x(i_lo(i))
      IF ( dx < TOLERANCE ) THEN
        Error_Status = FAILURE
        WRITE( Message, '( "Error : dx < or = 0. i_lo, i_hi : ", i6, 2x, i6, &
                          &" x(i_lo), x(i_hi) : ", f12.6, 2x, f12.6 )' ) &
                        i_lo(i), i_hi(i), x(i_lo(i)), x(i_hi(i))
        CALL Display_Message( ROUTINE_NAME, &
                              TRIM( Message ), &
                              Error_Status, &
                              Message_Log=Message_Log )
        RETURN
      END IF

      ! Evaluate cubic spline
      a = ( x(i_hi(i)) - x_int(i) ) / dx
      b = ( x_int(i) - x(i_lo(i)) ) / dx
      y_int(i) = ( a * y(i_lo(i)) ) + ( b * y(i_hi(i)) ) + &
                 ( ( ( (a**3) - a ) * y2_derivative(i_lo(i)) ) + &
                   ( ( (b**3) - b ) * y2_derivative(i_hi(i)) )   ) * &
                 (dx*dx) / SIX

    END DO

  END FUNCTION splint_rank1

END MODULE Spline_Interpolation


      intrinsic sqrt
      a = sqrt(cos(0.35))
      end


program test_intrinsic_trailz
   implicit none

   call test_trailz(0_1,0_2,0_4,0_8,1_1,1_2,1_4,1_8,8_1,8_2,8_4,8_8)
   stop

   contains

        subroutine test_trailz(z1,z2,z4,z8,i1,i2,i4,i8,e1,e2,e4,e8)
           integer(kind=1) :: z1, i1, e1
           integer(kind=2) :: z2, i2, e2
           integer(kind=4) :: z4, i4, e4
           integer(kind=8) :: z8, i8, e8

           if (trailz(0_1) /=  8) call abort()
           if (trailz(0_2) /= 16) call abort()
           if (trailz(0_4) /= 32) call abort()
           if (trailz(0_8) /= 64) call abort()

           if (trailz(1_1) /=  0) call abort()
           if (trailz(1_2) /=  0) call abort()
           if (trailz(1_4) /=  0) call abort()
           if (trailz(1_8) /=  0) call abort()

           if (trailz(8_1) /=  3) call abort()
           if (trailz(8_2) /=  3) call abort()
           if (trailz(8_4) /=  3) call abort()
           if (trailz(8_8) /=  3) call abort()

           if (trailz(z1) /=  8) call abort()
           if (trailz(z2) /= 16) call abort()
           if (trailz(z4) /= 32) call abort()
           if (trailz(z8) /= 64) call abort()

           if (trailz(i1) /=  0) call abort()
           if (trailz(i2) /=  0) call abort()
           if (trailz(i4) /=  0) call abort()
           if (trailz(i8) /=  0) call abort()

           if (trailz(e1) /=  3) call abort()
           if (trailz(e2) /=  3) call abort()
           if (trailz(e4) /=  3) call abort()
           if (trailz(e8) /=  3) call abort()
        end subroutine test_trailz

end program


C A very simple implementation of a 2D wave equation solver,
C aimed at testing high-performance computing techniques.
C To make the code as simple as possible, the initial condition
C is implemented in a rough way.

      PROGRAM wave2D
      INTEGER n, nsteps, dumpsolution
      PARAMETER (n=31)
C      PARAMETER (n=501)
C      PARAMETER (n=101)

      REAL*8 up(n,n), u(n,n), um(n,n), lambda(n,n)
      REAL*8 dt, tstop, delta, h1, bell1
      EXTERNAL h1, bell1
C     domain has size 10x10 in x and y direction
C     delta is the cell size:
      delta = 10.0/(n-1)

      dt = SQRT(1.0/(1.0/(delta*delta) + 1.0/(delta*delta)))
C     dt = delta
      write(*,*) 'Give number of time steps:'
      read(*,*) nsteps
      tstop = nsteps*dt
      write(*,*) 'time step =',dt
      dumpsolution = 1
      call timeloop(up, u, um, lambda, n, tstop, dt, h1, bell1,
     >              dumpsolution)

      END

C     function for coefficient in the wave equation ("lambda"):
      REAL*8 FUNCTION h1(x, y)
      REAL*8 x,y
      h1 = 1.0
      RETURN
      END

C     initial surface shape:
      REAL*8 FUNCTION bell1(x, y)
      REAL*8 x,y
      bell1 = exp(-x*x - y*y)
      RETURN
      END

      SUBROUTINE setIC(u, um, n, surface)
C     set initial conditions (rough approximations)
      INTEGER n
      REAL*8 u(n,n), um(n,n), surface
      EXTERNAL surface
Cf2py intent(in, out) u
C2fpy intent(in, out) um
      INTEGER i, j
      REAL*8 x, y, delta
C     domain has size 10x10 in x and y direction
C     delta is the cell size:
      delta = 10.0/(n-1)

      DO 20 j=1,n
         DO 10 i=1,n
            x = (i-1)*delta
            y = (j-1)*delta
            u(i,j) = surface(x,y)
C           this is a rough approximation to du/dt=0:
            um(i,j) = u(i,j)
 10      CONTINUE
 20   CONTINUE
      RETURN
      END

      SUBROUTINE setBottom(lambda, n, bottom)
      INTEGER n
      REAL*8 lambda(n,n), bottom
      EXTERNAL bottom
C2fpy intent(in, out) lambda
      INTEGER i, j
      REAL*8 x, y, delta
C     domain has size 10x10 in x and y direction
C     delta is the cell size:
      delta = 10.0/(n-1)

      DO 20 j=1,n
         DO 10 i=1,n
            x = (i-1)*delta
            y = (j-1)*delta
            lambda(i,j) = bottom(x,y)
 10      CONTINUE
 20   CONTINUE
      RETURN
      END

      SUBROUTINE timeloop(up, u, um, lambda, n, tstop, dt,
     >                    bottom, surface, dumpsolution)
      INTEGER n, dumpsolution
      REAL*8 up(n,n), u(n,n), um(n,n), lambda(n,n)
      REAL*8 tstop, dt, t, bottom, surface
      EXTERNAL bottom, surface
Cf2py intent(in, out) up

      INTEGER nsteps, timelevel
      nsteps = int(tstop/dt)

      t = 0
      call setIC(u, um, n, surface)
      call setBottom(lambda, n, bottom)
      if (dumpsolution .eq. 1) then
         call dump(u, n, 0, 0.0D0)
      end if

      DO 30 timelevel=1,nsteps
         t = t + dt
         write(*,*) 'time level', timelevel
         call solveAtThisTimeStep(up,u,um,lambda,n,dt)
         if (dumpsolution .eq. 1) then
            call dump(u, n, timelevel, t)
         end if

C        update for next step:
         DO 20 j=1,n
            DO 10 i=1,n
               um(i,j) = u(i,j)
               u(i,j) = up(i,j)
 10         CONTINUE
 20      CONTINUE
 30   CONTINUE
      RETURN
      END

      SUBROUTINE solveAtThisTimeStep(up, u, um, lambda, n, dt)
      INTEGER n
      REAL*8 up(n,n), u(n,n), um(n,n), lambda(n,n)
Cf2py intent(in, out) up
      REAL*8 dt

      REAL*8 delta, a, b, c

      delta = 10.0/(n-1)
      a = 1.0
      b = 1.0
      c = 1.0

      call F77WAVE(up, u, um, lambda, a, b, c, n, n, dt, delta, delta)
      END

C     dump solution in ASCII plotmtv format:
      SUBROUTINE dump(u, n, timelevel, time)
      INTEGER n, i, j, timelevel, iunit
      REAL*8 u(n,n), time
      CHARACTER*40 filename
      WRITE(filename,1000) 'tmp_',timelevel,'.mtv'
 1000 FORMAT(A,I5.5,A)
      iunit = 20
      OPEN(iunit, FILE=filename, STATUS='UNKNOWN', FORM='FORMATTED')
      WRITE(iunit,*) '$ DATA=CONTOUR'
      WRITE(iunit,*) '% toplabel="t =',time,'"'
      WRITE(iunit,*) '% contstyle=2 nsteps=30 nx=',n,' ny=',n,
     & ' xmin=0 xmax=10 ymin=0 ymax=10'
      WRITE(iunit,*) '% cmin=-0.2 cmax=0.4 zmin=-0.2 zmax=0.6'
      WRITE(iunit,*) '% leftworld=False'
      WRITE(iunit,*) '% eyepos.x=0.5 eyepos.y=-1.5 eyepos.z=0.5'
C     plotmtv requires i to have the fastest variation:
      DO 20 j=1,n
         DO 10 i=1,n
            WRITE(iunit,*) u(i,j)
 10      CONTINUE
 20   CONTINUE
      CLOSE(iunit)
      RETURN
      END

C     dump solution in binary plotmtv format:
      SUBROUTINE dumpb(u, n, timelevel)
C     note: this subroutine does not work; the ASCII output
C     must be formatted first in a string and then dumped
C     as un unformatted string
      INTEGER n, i, j, timelevel, iunit
      REAL*8 u(n,n)
      CHARACTER*40 filename
      WRITE(filename,1000) 'tmp_',timelevel,'.mtv'
 1000 FORMAT(A,I5.5,A)
      iunit = 20
      OPEN(iunit, FILE=filename, STATUS='UNKNOWN', FORM='UNFORMATTED')
      WRITE(iunit,*) '$ DATA=CONTOUR\n'
      WRITE(iunit,*) '% contstyle=2 nsteps=30 nx=',n,' ny=',n,
     & ' xmin=0 xmax=10 ymin=0 ymax=10\n'
      WRITE(iunit,*) '% cmin=-0.2 cmax=0.4 zmin=-0.2 zmax=0.6\n'
      WRITE(iunit,*) '% leftworld=False\n'
      WRITE(iunit,*) '% eyepos.x=0.5 eyepos.y=-1.5 eyepos.z=0.5\n'
      WRITE(iunit,*) '% binary=T\n'
C     plotmtv requires i to have the fastest variation:
      WRITE(iunit) ((u(i,j), i=1,n), j=1,n)
      CLOSE(iunit)
      RETURN
      END


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! This program computes multiple distributed 3D FFTs
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

program blocking

  use decomp_2d
  use MPI

  implicit none

  include "fftw3.f"

  integer, parameter :: nx=16, ny=16, nz=16
  integer, parameter :: p_row=2, p_col=2
  integer, parameter :: NFFT=20   ! number of independent FFTs

  integer :: i,j,k, m, nmax, ierror
  real(mytype) :: tmp1, tmp2

  double precision :: t1, t2

  ! FFTW plans for the 1D forward/backward transforms
  integer*8, save :: x_plan_f, x_plan_b
  integer*8, save :: y_plan_f, y_plan_b
  integer*8, save :: z_plan_f, z_plan_b

  ! dummy array used for planning
  complex(mytype), allocatable, dimension(:) :: buf1, buf2

  ! input/output of the FFT
  complex(mytype), allocatable, dimension(:,:,:) :: in, out, wk2

  call MPI_INIT(ierror)
  call decomp_2d_init(nx,ny,nz,p_row,p_col)

  ! ===== planning 1D FFT in x =====
  allocate(buf1(xsize(1)), buf2(xsize(1)))

#ifdef DOUBLE_PREC
  call dfftw_plan_dft_1d(x_plan_f, xsize(1), buf1, buf2,  &
       FFTW_FORWARD,  FFTW_MEASURE)
  call dfftw_plan_dft_1d(x_plan_b, xsize(1), buf1, buf2,  &
       FFTW_BACKWARD, FFTW_MEASURE)
#else
  call sfftw_plan_dft_1d(x_plan_f, xsize(1), buf1, buf2,  &
       FFTW_FORWARD,  FFTW_MEASURE)
  call sfftw_plan_dft_1d(x_plan_b, xsize(1), buf1, buf2,  &
       FFTW_BACKWARD, FFTW_MEASURE)
#endif

  deallocate(buf1,buf2)

  ! ===== planning 1D FFT in Y =====
  allocate(buf1(ysize(2)), buf2(ysize(2)))

#ifdef DOUBLE_PREC
  call dfftw_plan_dft_1d(y_plan_f, ysize(2), buf1, buf2,  &
       FFTW_FORWARD,  FFTW_MEASURE)
  call dfftw_plan_dft_1d(y_plan_b, ysize(2), buf1, buf2,  &
       FFTW_BACKWARD, FFTW_MEASURE)
#else
  call sfftw_plan_dft_1d(y_plan_f, ysize(2), buf1, buf2,  &
       FFTW_FORWARD,  FFTW_MEASURE)
  call sfftw_plan_dft_1d(y_plan_b, ysize(2), buf1, buf2,  &
       FFTW_BACKWARD, FFTW_MEASURE)
#endif

  deallocate(buf1,buf2)

  ! ===== planning 1D FFT in Z =====
  allocate(buf1(zsize(3)), buf2(zsize(3)))

#ifdef DOUBLE_PREC
  call dfftw_plan_dft_1d(z_plan_f, zsize(3), buf1, buf2,  &
       FFTW_FORWARD,  FFTW_MEASURE)
  call dfftw_plan_dft_1d(z_plan_b, zsize(3), buf1, buf2,  &
       FFTW_BACKWARD, FFTW_MEASURE)
#else
  call sfftw_plan_dft_1d(z_plan_f, zsize(3), buf1, buf2,  &
       FFTW_FORWARD,  FFTW_MEASURE)
  call sfftw_plan_dft_1d(z_plan_b, zsize(3), buf1, buf2,  &
       FFTW_BACKWARD, FFTW_MEASURE)
#endif

  deallocate(buf1,buf2)

  allocate( in(xsize(1),xsize(2),xsize(3)))   ! x-pencil input
  allocate(out(zsize(1),zsize(2),zsize(3)))   ! z-pencil output
  allocate(wk2(ysize(1),ysize(2),ysize(3)))   ! y-pencil intermediate

  ! 1D temp buffer
  nmax = max(xsize(1),max(ysize(2),zsize(3)))
  allocate (buf1(nmax))
  allocate (buf2(nmax))

  t1 = MPI_WTIME()

  do m=1,NFFT

     do k=1,xsize(3)
        do j=1,xsize(2)
           do i=1,xsize(1)
              tmp1 = real(xstart(1)+i-1, mytype) / real(nx, mytype) &
                   * real(xstart(2)+j-1, mytype) / real(ny, mytype) &
                   * real(xstart(3)+k-1, mytype) / real(nz, mytype) &
                   * real(m, mytype) / real(NFFT, mytype)
              in(i,j,k) = cmplx(tmp1, 0._mytype, mytype)
           end do
        end do
     end do

     ! This shows how to perform 3D FFT by using the FFTW basic interface.
     ! Copy data to/from 1D buffers and loop through all 1D FFTs.

     ! 1D FFT in X
     do k=1,xsize(3)
        do j=1,xsize(2)
           do i=1,xsize(1)
              buf1(i) = in(i,j,k)
           end do
#ifdef DOUBLE_PREC
           call dfftw_execute_dft(x_plan_f, buf1, buf2)
#else
           call sfftw_execute_dft(x_plan_f, buf1, buf2)
#endif
           do i=1,xsize(1)
              in(i,j,k) = buf2(i)
           end do
        end do
     end do

     ! ===== Swap X --> Y =====
     call transpose_x_to_y(in,wk2)

     ! ===== 1D FFTs in Y =====
     do k=1,ysize(3)
        do i=1,ysize(1)
           do j=1,ysize(2)
              buf1(j) = wk2(i,j,k)
           end do
#ifdef DOUBLE_PREC
           call dfftw_execute_dft(y_plan_f, buf1, buf2)
#else
           call sfftw_execute_dft(y_plan_f, buf1, buf2)
#endif
           do j=1,ysize(2)
              wk2(i,j,k) = buf2(j)
           end do
        end do
     end do

     ! ===== Swap Y --> Z =====
     call transpose_y_to_z(wk2,out)

     ! ===== 1D FFTs in Z =====
     do j=1,zsize(2)
        do i=1,zsize(1)
           do k=1,zsize(3)
              buf1(k) = out(i,j,k)
           end do
#ifdef DOUBLE_PREC
           call dfftw_execute_dft(z_plan_f, buf1, buf2)
#else
           call sfftw_execute_dft(z_plan_f, buf1, buf2)
#endif
           do k=1,zsize(3)
              out(i,j,k) = buf2(k)
           end do
        end do
     end do

     if (nrank==0) write(*,*) 'TEST ', m, out(1:2,1:2,1:2)

  end do ! NFFT

  t2 = MPI_WTIME() - t1
  call MPI_ALLREDUCE(t2,t1,1,MPI_DOUBLE_PRECISION,MPI_SUM, &
       MPI_COMM_WORLD,ierror)
  t1 = t1 / real(nproc, mytype)

  if (nrank==0) then
     write(*,*) 'Average Forward FFT Time(sec): ', t1
  end if

  ! clean up
#ifdef DOUBLE_PREC
  call dfftw_destroy_plan(x_plan_f)
  call dfftw_destroy_plan(x_plan_b)
  call dfftw_destroy_plan(y_plan_f)
  call dfftw_destroy_plan(y_plan_b)
  call dfftw_destroy_plan(z_plan_f)
  call dfftw_destroy_plan(z_plan_b)
#else
  call sfftw_destroy_plan(x_plan_f)
  call sfftw_destroy_plan(x_plan_b)
  call sfftw_destroy_plan(y_plan_f)
  call sfftw_destroy_plan(y_plan_b)
  call sfftw_destroy_plan(z_plan_f)
  call sfftw_destroy_plan(z_plan_b)
#endif

  call decomp_2d_finalize
  call MPI_FINALIZE(ierror)
  deallocate(in,out,wk2,buf1,buf2)

end program blocking