module equations_mod

use globals_mod
use config_mod, only: kappa

integer, parameter :: N_VARS = 4

integer, parameter :: DENS_VAR = 1
integer, parameter :: MOMX_VAR = 2
integer, parameter :: MOMY_VAR = 3
integer, parameter :: ENER_VAR = 4

character(len=16), parameter :: varnames(N_VARS) = (/&
    "density        ", &
    "x-momentum     ", &
    "y-momentum     ", &
    "total-energy   "  &
/)

interface xflux
    procedure xflux_0d
    procedure xflux_1d
    procedure xflux_2d
end interface

interface yflux
    procedure yflux_0d
    procedure yflux_1d
    procedure yflux_2d
end interface

interface pressure
    procedure pressure_0d
    procedure pressure_1d
    procedure pressure_2d
end interface

interface xlambdaMax
    procedure xlambdaMax_0d
    procedure xlambdaMax_1d
    procedure xlambdaMax_2d
end interface

interface ylambdaMax
    procedure ylambdaMax_0d
    procedure ylambdaMax_1d
    procedure ylambdaMax_2d
end interface

interface isvalid
    procedure isvalid_0d
    procedure isvalid_1d
    procedure isvalid_2d
end interface

contains

!! ========================================================================== !!

pure function xflux_0d(u) result(f)

    real(dp), intent(in)    :: u(N_VARS)
    real(dp)                :: f(N_VARS)
    real(dp)                :: pres

    pres = pressure(u)

    f(DENS_VAR) = u(MOMX_VAR)
    f(MOMX_VAR) = u(MOMX_VAR)*u(MOMX_VAR)/u(DENS_VAR) + pres
    f(MOMY_VAR) = u(MOMX_VAR)*u(MOMY_VAR)/u(DENS_VAR)
    f(ENER_VAR) = u(MOMX_VAR)/u(DENS_VAR)*(u(ENER_VAR) + pres)

end function

pure function xflux_1d(u) result(f)

    real(dp),intent(in)    :: u(:,:)
    real(dp)               :: f(size(u,dim=1),size(u,dim=2))

    integer :: i

    do i = 1,size(u,dim=1)
        f(i,:) = xflux(u(i,:))
    end do

end function

pure function xflux_2d(u) result(f)

    real(dp),intent(in)    :: u(:,:,:)
    real(dp)               :: f(size(u,dim=1),size(u,dim=2),size(u,dim=3))

    integer :: i,j

    do i = 1,size(u,dim=1)
        do j = 1,size(u,dim=2)
            f(i,j,:) = xflux(u(i,j,:))
        end do
    end do

end function

pure function yflux_0d(u) result(f)

    real(dp), intent(in)    :: u(N_VARS)
    real(dp)                :: f(N_VARS)
    real(dp)                :: ru(N_VARS), rf(N_VARS) !! rotated

    !! rotating to x-direction
    ru(DENS_VAR) = u(DENS_VAR)
    ru(MOMX_VAR) = u(MOMY_VAR)
    ru(MOMY_VAR) = u(MOMX_VAR)
    ru(ENER_VAR) = u(ENER_VAR)

    rf = xflux(ru)

    !! rotating back
    f(DENS_VAR) = rf(DENS_VAR)
    f(MOMX_VAR) = rf(MOMY_VAR)
    f(MOMY_VAR) = rf(MOMX_VAR)
    f(ENER_VAR) = rf(ENER_VAR)

end function

pure function yflux_1d(u) result(f)

    real(dp),intent(in)    :: u(:,:)
    real(dp)               :: f(size(u,dim=1),size(u,dim=2))

    integer :: i

    do i = 1,size(u,dim=1)
        f(i,:) = yflux(u(i,:))
    end do

end function

pure function yflux_2d(u) result(f)

    real(dp),intent(in)    :: u(:,:,:)
    real(dp)               :: f(size(u,dim=1),size(u,dim=2),size(u,dim=3))

    integer :: i,j

    do i = 1,size(u,dim=1)
        do j = 1,size(u,dim=2)
            f(i,j,:) = yflux(u(i,j,:))
        end do
    end do

end function

!! ========================================================================== !!

pure function pressure_0d(u) result(p)

    real(dp),intent(in)    :: u(N_VARS)
    real(dp)               :: p

    p = (kappa-1) * (u(ENER_VAR) - 0.5/u(DENS_VAR) * (u(MOMX_VAR)*u(MOMX_VAR) + u(MOMY_VAR)*u(MOMY_VAR)))

end function

pure function pressure_1d(u) result(p)

    real(dp),intent(in)    :: u(:,:)
    real(dp)               :: p(size(u,dim=1))

    integer :: i

    do i = 1,size(u,dim=1)
        p(i) = pressure(u(i,:))
    end do

end function

pure function pressure_2d(u) result(p)

    real(dp),intent(in)    :: u(:,:,:)
    real(dp)               :: p(size(u,dim=1),size(u,dim=2))

    integer :: i,j

    do i = 1,size(u,dim=1)
        do j = 1,size(u,dim=2)
            p(i,j) = pressure(u(i,j,:))
        end do
    end do

end function

!! ========================================================================== !!

pure function xlambdaMax_0d(u) result(r)

    real(dp),intent(in)    :: u(N_VARS)
    real(dp)               :: r

    r = abs(u(MOMX_VAR)/u(DENS_VAR)) + sqrt(kappa*pressure(u)/u(DENS_VAR))

end function

pure function xlambdaMax_1d(u) result(r)

    real(dp),intent(in)    :: u(:,:)
    real(dp)               :: r(size(u,dim=1))

    integer :: i

    do i = 1,size(u,dim=1)
        r(i) = xlambdaMax(u(i,:))
    end do

end function

pure function xlambdaMax_2d(u) result(r)

    real(dp),intent(in)    :: u(:,:,:)
    real(dp)               :: r(size(u,dim=1),size(u,dim=2))

    integer :: i,j

    do i = 1,size(u,dim=1)
        do j = 1,size(u,dim=2)
            r(i,j) = xlambdaMax(u(i,j,:))
        end do
    end do

end function

pure function ylambdaMax_0d(u) result(r)

    real(dp),intent(in)    :: u(N_VARS)
    real(dp)               :: r

    r = abs(u(MOMY_VAR)/u(DENS_VAR)) + sqrt(kappa*pressure(u)/u(DENS_VAR))

end function

pure function ylambdaMax_1d(u) result(r)

    real(dp),intent(in)    :: u(:,:)
    real(dp)               :: r(size(u,dim=1))

    integer :: i

    do i = 1,size(u,dim=1)
        r(i) = ylambdaMax(u(i,:))
    end do

end function

pure function ylambdaMax_2d(u) result(r)

    real(dp),intent(in)    :: u(:,:,:)
    real(dp)               :: r(size(u,dim=1),size(u,dim=2))

    integer :: i,j

    do i = 1,size(u,dim=1)
        do j = 1,size(u,dim=2)
            r(i,j) = ylambdaMax(u(i,j,:))
        end do
    end do

end function

!! ========================================================================== !!

function isvalid_0d(u) result(ok)

    real(dp),intent(in) :: u(N_VARS)
    logical             :: ok

    ok = (u(DENS_VAR) > 0) .and. (pressure(u) > 0)

end function

function isvalid_1d(u) result(ok)

    real(dp),intent(in)     :: u(:,:)
    logical                 :: ok

    integer :: i

    do i = 1,size(u,dim=1)
        ok = isvalid(u(i,:))
        if (.not.ok) return
    end do

end function

function isvalid_2d(u) result(ok)

    real(dp),intent(in)     :: u(:,:,:)
    logical                 :: ok

    integer :: i,j

    do i = 1,size(u,dim=1)
        do j = 1,size(u,dim=2)
            ok = isvalid(u(i,j,:))
            if (.not.ok) return
        end do
    end do

end function

end module


!=======================================================================
!			Pablo Ouro Barba
!			Cardiff 2013-2014
!=======================================================================
!######################################################################
      Real function phi_r1smth(r)
!######################################################################
      implicit none
      REAL, intent(in) :: r
      REAL :: PI,abr
       PI = 4.D0*DATAN(1.D0)
       abr=SQRT(r*r)
      IF (abr.ge.1.5) THEN
        phi_r1smth = 0.0
      ELSE IF ((abr.lt.1.5).and.(abr.ge.0.5)) THEN
        phi_r1smth = 9./8.-3.*abr/2+abr**2/2
      ELSE IF ((abr.lt.0.5).and.(abr.ge.0.0)) THEN
        phi_r1smth = 3./4.-abr**2
      END IF
      RETURN
      End Function
!######################################################################
      Real function phi_r2smth(r)
!######################################################################
      implicit none
      REAL, intent(in) :: r
      REAL :: PI
       PI = 4.D0*DATAN(1.D0)
      IF (r.le.-2.5) THEN
        phi_r2smth = 0.0
      ELSE IF ((r.ge.-2.5).and.(r.le.-1.5)) THEN
        phi_r2smth= -1./8./PI*(-5.*PI-2.*PI*r+4.*sin(PI/4.*(-2.*r-1.)))
      ELSE IF ((r.ge.-1.5).and.(r.le.0.0)) THEN
        phi_r2smth = 1./4./PI*(PI+2.*sin(PI/4.*(-2.*r+1.))
     &                           -2.*sin(PI/4.*(-2.*r-1.)))
      ELSE IF ((r.ge.0.0).and.(r.le.1.5)) THEN
        phi_r2smth = 1./4./PI*(PI+2.*sin(PI/4.*(2.*r+1.))
     &                           -2.*sin(PI/4.*(2.*r-1.)))
      ELSE IF ((r.ge.1.5).and.(r.le.2.5)) THEN
        phi_r2smth= -1./8./PI*(-5.*PI+2.*PI*r+4.*sin(PI/4.*(2.*r-1.)))
      ELSE IF (r.ge.2.5) THEN
        phi_r2smth = 0.0
      END IF

      RETURN
      End Function
!######################################################################
      Real function phi_r3(r)
!######################################################################
      implicit none
      REAL, intent(in) :: r
      IF (r.le.-1.5) THEN
        phi_r3 = 0.0
      ELSE IF ((r.ge.-1.5).and.(r.le.-0.5)) THEN
        phi_r3 = 1.0/6.0*(5.0+3.0*r-sqrt(-3.0*(1.0+r)**2+1.0))
      ELSE IF ((r.ge.-0.5).and.(r.le.0.0)) THEN
        phi_r3 = 1.0/3.0*(1.0+sqrt(-3.0*r**2+1.0))
      ELSE IF ((r.ge.0.0).and.(r.le.0.5)) THEN
        phi_r3 = 1.0/3.0*(1.0+sqrt(-3.0*r**2+1.0))
      ELSE IF ((r.ge.0.5).and.(r.le.1.5)) THEN
        phi_r3 = 1.0/6.0*(5.0-3.0*r-sqrt(-3.0*(1.0-r)**2+1.0))
      ELSE IF (r.ge.1.5) THEN
        phi_r3 = 0.0
      END IF

      RETURN
      End Function
!######################################################################
      Real function phi_r3smth2(r)
!######################################################################
      implicit none
      REAL, intent(in) :: r
      REAL :: PI
       PI = 4.D0*DATAN(1.D0)
      IF (r.le.-2.0) THEN
        phi_r3smth2 = 0.0
      ELSE IF ((r.ge.-2.0).and.(r.le.-1.0)) THEN
        phi_r3smth2 = 55.0/48.0 - sqrt(3.0)*pi/108.0 + 13.0*r/12.0
     &+ r**2/4.0 + (-2.0*r-3.0)/48.0*sqrt(-12.0*r**2-36.0*r-23.0)
     &+ sqrt(3.0)/36.0*ASIN(sqrt(3.0)/2.0*(-2.0*r-3.0))
      ELSE IF ((r.ge.-1.0).and.(r.le.0.0)) THEN
        phi_r3smth2 = 17.0/48.0 + sqrt(3.0)*pi/108.0 - r/4.0
     &- r**2/4.0 + (2.0*r+1.0)/16.0*sqrt(-12.0*r**2-12.0*r+1.0)
     &- sqrt(3.0)/12.0*ASIN(sqrt(3.0)/2.0*(-2.0*r-1.0))
      ELSE IF ((r.ge.0.0).and.(r.le.1.0)) THEN
        phi_r3smth2 = 17.0/48.0 + sqrt(3.0)*pi/108.0 + r/4.0
     &- r**2/4.0 + (-2.0*r+1.0)/16.0*sqrt(-12.0*r**2+12.0*r+1.0)
     &- sqrt(3.0)/12.0*ASIN(sqrt(3.0)/2.0*(2.0*r-1.0))
      ELSE IF ((r.ge.1.0).and.(r.le.2.0)) THEN
        phi_r3smth2 = 55.0/48.0 - sqrt(3.0)*pi/108.0 - 13.0*r/12.0
     &+ r**2/4.0 + (2.0*r-3.0)/48.0*sqrt(-12.0*r**2+36.0*r-23.0)
     &+ sqrt(3.0)/36.0*ASIN(sqrt(3.0)/2.0*(2.0*r-3.0))
      ELSE IF (r.ge.2.0) THEN
        phi_r3smth2 = 0.0
      END IF

      RETURN
      End Function
!######################################################################
      Real function phi_r3smth(r)
!######################################################################
      implicit none
      Double precision, intent(in) :: r
!      REAL :: PI
      REAL :: scal1,scal2,scal3,scal4,scal5,scal6

      scal1 = 1.095450017660160615261  ! 55.0/48.0 - sqrt(3.0)*pi/108.0
      scal2 = 1.083333333333333333333  ! 13.0/12.0
      scal3 = 0.4045499823398393847387 ! 17.0/48.0 + sqrt(3.0)*pi/108.0
      scal4 = 0.0481125224324688137091 ! sqrt(3.0)/36.0
      scal5 = 0.1443375672974064411273 ! sqrt(3.0)/12.0
      scal6 = 0.8660254037844386467637 ! sqrt(3.0)/2.0

!       PI = 4.D0*DATAN(1.D0)

      IF (r.le.-2.0) THEN
        phi_r3smth = 0.0
      ELSE IF ((r.ge.-2.0).and.(r.le.-1.0)) THEN
        phi_r3smth = scal1 + scal2*r + scal4*ASIN(scal6*(-2.0*r-3.0))
     &+ 0.25*r**2 + (-2.0*r-3.0)/48.0*sqrt(-12.0*r**2-36.0*r-23.0)
      ELSE IF ((r.ge.-1.0).and.(r.le.0.0)) THEN
        phi_r3smth = scal3 - r/4.0 - scal5*ASIN(scal6*(-2.0*r-1.0))
     &- 0.25*r**2 + (2.0*r+1.0)/16.0*sqrt(-12.0*r**2-12.0*r+1.0)
      ELSE IF ((r.ge.0.0).and.(r.le.1.0)) THEN

        phi_r3smth = scal3 + r/4.0 - scal5*ASIN(scal6*(2.0*r-1.0))
     &- 0.25*r**2 + (-2.0*r+1.0)/16.0*sqrt(-12.0*r**2+12.0*r+1.0)
      ELSE IF ((r.ge.1.0).and.(r.le.2.0)) THEN
        phi_r3smth = scal1 - scal2*r + scal4*ASIN(scal6*(2.0*r-3.0))
     &+ 0.25*r**2 + (2.0*r-3.0)/48.0*sqrt(-12.0*r**2+36.0*r-23.0)
      ELSE IF (r.ge.2.0) THEN
        phi_r3smth = 0.0
      END IF

      RETURN
      End Function
!######################################################################
      Real function phi_r4(r)
!######################################################################
      implicit none
      REAL, intent(in) :: r
      IF (r.le.-2.0) THEN
        phi_r4 = 0.0
      ELSE IF ((r.ge.-2.0).and.(r.le.-1.0)) THEN
        phi_r4 = 1.0/8.0*(5.0+2.0*r-sqrt(-7.0-12.0*r-4.0*r**2))
      ELSE IF ((r.ge.-1.0).and.(r.le.0.0)) THEN
        phi_r4 = 1.0/8.0*(3.0+2.0*r+sqrt(1.0-4.0*r-4.0*r**2))
      ELSE IF ((r.ge.0.0).and.(r.le.1.0)) THEN
        phi_r4 = 1.0/8.0*(3.0-2.0*r+sqrt(1.0+4.0*r-4.0*r**2))
      ELSE IF ((r.ge.1.0).and.(r.le.2.0)) THEN
        phi_r4 = 1.0/8.0*(5.0-2.0*r-sqrt(-7.0+12.0*r-4.0*r**2))
      ELSE IF (r.ge.2.0) THEN
        phi_r4 = 0.0
      END IF

      RETURN
      End Function
!######################################################################
      Real function phi_r4smth(r)
!######################################################################
      implicit none
      REAL, intent(in) :: r
      REAL :: PI,ar
       PI = 4.D0*DATAN(1.D0)
	ar=abs(r)
      IF ((ar.ge.0.0).and.(ar.le.0.5)) THEN
	phi_r4smth = 3.0/8.0+ PI/32.0 - r*r/4.0
      ELSE IF ((ar.ge.0.5).and.(ar.le.1.5)) THEN
	phi_r4smth = 1.0/4.0 + (1.0-ar)/8.0*SQRT(-2.0+8.0*ar -4.0*r*r)
     & -1.0/8.0*ASIN(sqrt(2.0)*(ar-1.0))
      ELSE IF ((ar.ge.1.5).and.(ar.le.2.5)) THEN
	phi_r4smth = 17.0/16.0 - PI/64.0 - 3.0*ar/4.0+ r*r/8.0
     & + (ar-2.0)/16.0 * SQRT(-14.0+ 16.0*ar - 4.0*r*r)
     & + 1.0/16.0*ASIN(sqrt(2.0)*(ar-2.0))
      ELSE IF (ar.ge.2.5) THEN
        phi_r4smth = 0.0
      END IF
      RETURN
      End Function
!######################################################################
      double precision function dh(dx,dy,dz,xij,yij,zij,Xl,Yl,Zl,order)
!######################################################################
! ..... The salient properties of the kernels DIRAC DELTA,dh are the following:
! * dh is a continuously diﬀerentiable function and therefore yields
!   a smoother transfer than e.g. linear interpolation.
! * Interpolation using the kernels dh is second-order accurate
!   for smooth ﬁelds (Uhlmann(2005) cf. Section 5.1.1).
! * The support of the regularized delta function is small, which makes
!   the evaluation of the sums in Eq. (9) relatively cheap. In particular,
!   we use the expression for dh deﬁned by Roma et al., involving only
!   three grid points in each coordinate direction.
! * (ORDER=3) A. Roma, C. Peskin, M. Berger, An adaptive version of the
!   immersed boundary method, J. Comput. Phys. 153 (1999)
! * (ORDER=4) C. Peskin, The immersed boundary method,
!   Acta Numerica 11 (2002) 1–39
!
      implicit none

      REAL,    intent(in) :: dx,dy,dz,xij,yij,zij,Xl,Yl,Zl
      INTEGER, intent(in) :: order
      REAL*8 ::phi_r2smth,phi_r3smth,phi_r4,phi_r3,phi_r1smth,phi_r4smth

      SELECT CASE (order)

         CASE (1)
      dh =  phi_r1smth((xij-Xl)/dx)
     & * phi_r1smth((yij-Yl)/dy) * phi_r1smth((zij-Zl)/dz)
         CASE (2)
      dh =   phi_r2smth((xij-Xl)/dx)
     & * phi_r2smth((yij-Yl)/dy) * phi_r2smth((zij-Zl)/dz)
         CASE (3)
       dh =   phi_r3smth((xij-Xl)/dx)
     &   * phi_r3smth((yij-Yl)/dy) * phi_r3smth((zij-Zl)/dz)
         CASE (4)
       dh =   phi_r4smth((xij-Xl)/dx)
     &   * phi_r4smth((yij-Yl)/dy) * phi_r4smth((zij-Zl)/dz)
         CASE (5)
       dh =   phi_r3((xij-Xl)/dx)
     &   * phi_r3((yij-Yl)/dy) * phi_r3((zij-Zl)/dz)
         CASE (6)
      dh =   phi_r4((xij-Xl)/dx)
     &   * phi_r4((yij-Yl)/dy) * phi_r4((zij-Zl)/dz)

      Case default

         print*, '===ERROR==='
         print*, ' order of delta function is not selected '
          STOP

      End Select

      RETURN
      End Function


C 	This routine was copied from the stsdas$pkg/analysis/gasp/gasplib/
C	directory. See stsdas$copyright.stsdas for copyright restrictions.
C
	subroutine fitsvd (x, y, wg, npts, coef, nterms,
     *			  u, v, w, chisq)
	parameter(nmax=1000,mmax=50,tol=1.d-14)

	real   wg(npts)
	real*8 x(npts,nterms), y(npts), coef(nterms), v(nterms,nterms),
     *		u(npts,nterms), w(nterms), b(nmax)
	real*8 wmax, thresh, chisq, sum

	do i=1,npts
		do j=1,nterms
			u(i,j)=x(i,j)*wg(i)
		enddo
		b(i)=y(i)*wg(i)
	enddo
	call dcmpsv (u,npts,nterms,w,v)
	wmax=0.
	do j=1,nterms
		if(w(j).gt.wmax) wmax=w(j)
	enddo
	thresh=tol*wmax
	do j=1,nterms
		if(w(j).lt.thresh) w(j)=0.
	enddo
	call ksbsvd (u, w, v, npts, nterms, b, coef)
	chisq=0.
	do i=1,npts
		sum=0.
		do j=1,nterms
			sum=sum+coef(j)*x(i,j)
		enddo
		chisq=chisq+((y(i)-sum)*wg(i))**2
	enddo
	return
	end


subroutine SHBias(Shh, lwin, incspectra, ldata, outcspectra, save_cg)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This subroutine will compute the expected windowed (cross-)power spectra
!	given the power spectrum of an arbitrary window, and the "known" input (cross-)power
!	spectra. Note that this routine makes the assumption that
!	the known spectra can be described as a random variable.
!
!	Calling Parameteters
!		IN
!			Shh		Window power spectrum.
!			lwin		Maximum spherical harmonic degree of the window.
!			incspectra	Knonw input (cross-)power spectrum as a function of degree.
!			ldata		Maximum degree of incspectra. Beyong this degree
!					incspectra is assumed to be zero.
!		OUT
!			outcspectra	Biassed estimate of the windowed
!					power spectra. Maximum degree calculated is equal
!					to lwin + ldata, or the dimension of outcspectra.
!		IN, OPTIONAL
!			save_cg		If 1, the Clebsch-Gordon coefficients will be calculated
!					and saved, and then used in all subsequent calls (if lwin
!					and ldata are not changed).
!					If -1, the allocated memory for these terms will be deallocated.
!
!	Dependencies: Wigner3j
!
!	Written by Mark Wieczorek, August 2004.
!
!	Modified May 28, 2006 so that one inputs the window's power spectrum instead
!	of the window's coefficients. Also, the routine now assumes that incspectra is zero
!	beyond ldata.
!
!	Modified May 5 2009 in oder to allow the Clebsch-Gordon coefficients to be precomputed and saved.
!
!
!	Copyright (c) 2005-2009, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use SHTOOLS, only: Wigner3j
	implicit none

	real*8, intent(in) ::	Shh(:), incspectra(:)
	real*8, intent(out) ::	outcspectra(:)
	integer, intent(in) ::	lwin, ldata
	integer, intent(in), optional :: save_cg
	integer ::	l, i, j, lmax, imin, imax, astat
	real*8 ::	wig(2*lwin+ldata+1)
	real*8, allocatable, save ::	cg2(:,:,:)

	lmax = ldata + lwin
	outcspectra = 0.0d0

	if (size(Shh) < lwin+1) then
		print*, "Error --- SHBias"
		print*, "SHH must be dimensioned as (LWIN+1) where LWIN is ", lwin
		print*, "Input array is dimensioned as ", size(Shh)
		stop
	elseif (size(incspectra) < ldata+1) then
		print*, "Error --- SHBias"
		print*, "INCSPECTRA must be dimensioned as (LDATA+1) where LDATA is ", ldata
		print*, "Input array is dimensioned as ", size(incspectra)
		stop
	endif

	if (present(save_cg)) then
		if (save_cg /= 1 .and. save_cg /= -1 .and. save_cg /= 0) then
			print*, "Error --- SHBias"
			print*, "SAVE_CG must be 1 (to save the Clebsch-Gordon coefficients), -1 (to deallocate the memory)"
			print*, "or 0 (to do nothing)."
			print*, "Input value is ", save_cg
			stop
		endif
	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Calculate the biassed power spectrum
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	if (present(save_cg)) then

		if (save_cg == -1) then

			if (allocated(cg2)) deallocate(cg2)
			return

		elseif (save_cg == 0) then

			do l=0, min(lmax, size(outcspectra)-1)
				do j=0, lwin
					call Wigner3j(wig, imin, imax, j, l, 0, 0, 0)
					do i=imin, min(imax, ldata), 2
						outcspectra(l+1) = outcspectra(l+1) + Shh(j+1) * &
							incspectra(i+1) * (2.0d0*l+1.0d0) * wig(i-imin+1)**2
					enddo
				enddo
			enddo

			return

		endif

		if (allocated(cg2) .and. (size(cg2(:,1,1)) /= lmax+1 .or. size(cg2(1,:,1)) /= lwin+1 .or. &
			size(cg2(1,1,:)) /= lmax+lwin+1) ) deallocate(cg2)

		if (.not.allocated(cg2)) then
			allocate(cg2(lmax+1, lwin+1, lmax+lwin+1), stat = astat)
			if (astat /= 0) then
				print*, "Error --- SHBias"
				print*, "Problem allocating internal array CG2"
				stop
			endif

			cg2 = 0.0d0

			do l=0, lmax
				do j=0, lwin
					call Wigner3j(wig, imin, imax, j, l, 0, 0, 0)
					cg2(l+1,j+1,1:imax-imin+1) = (2.0d0*l+1.0d0) * wig(1:imax-imin+1)**2
				enddo
			enddo

		endif

		do l=0, min(lmax, size(outcspectra)-1)
			do j=0, lwin
				imin = abs(j-l)
				imax = j+l
				do i=imin, min(imax, ldata), 2
					outcspectra(l+1) = outcspectra(l+1) + Shh(j+1) * &
						incspectra(i+1) * cg2(l+1,j+1,i-imin+1)
				enddo
			enddo
		enddo

	else

		do l=0, min(lmax, size(outcspectra)-1)
			do j=0, lwin
				call Wigner3j(wig, imin, imax, j, l, 0, 0, 0)
				do i=imin, min(imax, ldata), 2
					outcspectra(l+1) = outcspectra(l+1) + Shh(j+1) * &
						incspectra(i+1) * (2.0d0*l+1.0d0) * wig(i-imin+1)**2
				enddo
			enddo
		enddo

	endif

end subroutine SHBias


!########################################################
!     Program  : AHMIPT
!     TYPE     : Main program
!     PURPOSE  : Solve the Attractive Hubbard Model using IPT
!     AUTHORS  : Adriano Amaricci
!########################################################
program hmipt
  USE DMFT_IPT
  USE SQUARE_LATTICE
  implicit none
  integer    :: i,ik,Lk
  logical    :: converged
  complex(8) :: zeta1,zeta2,det
  complex(8),allocatable :: sigma(:,:),fg(:,:),fg0(:,:),calG(:,:)
  real(8),allocatable    :: wr(:),wt(:),epsik(:)

  call read_input("inputIPT.in")
  allocate(fg(2,-L:L),sigma(2,-L:L),fg0(2,-L:L),calG(2,-L:L))

  allocate(wr(-L:L))
  wr = linspace(-wmax,wmax,2*L+1,mesh=fmesh)

  Lk   = square_lattice_dimension(Nx)
  allocate(wt(Lk),epsik(Lk))
  wt   = square_lattice_structure(Lk,Nx)
  epsik= square_lattice_dispersion_array(Lk,ts)

  sigma=zero ; sigma(2,:)=-deltasc ; iloop=0 ; converged=.false.
  do while (.not.converged)
     iloop=iloop+1
     write(*,"(A,i5)",advance="no")"DMFT-loop",iloop

     fg=zero
     do i=-L,L
        zeta1 = cmplx(wr(i),eps) - sigma(1,i)
        zeta2 = cmplx(wr(i),eps) + conjg(sigma(1,-i))
        do ik=1,Lk
           det = (zeta1-epsik(ik))*(zeta2+epsik(ik)) - sigma(2,i)**2
           fg(1,i)=fg(1,i) + wt(ik)*(zeta2+epsik(ik))/det
           fg(2,i)=fg(2,i) - wt(ik)*(sigma(2,i))/det
        enddo
        if(dimag(fg(1,i)) > 0.d0)fg(1,i)=real(fg(1,i),8)+ (0.d0,1.d-9)
        if(i<0.d0 .AND. dimag(fg(2,i))<0.d0)fg(2,i)=real(fg(2,i),8)+ (0.d0,1.d-9)
        if(i>0.d0 .AND. dimag(fg(2,i))>0.d0)fg(2,i)=real(fg(2,i),8)+ (0.d0,1.d-9)
     enddo

     deltasc=u*sum(aimag(fg(2,-L:L))*fermi(wr(-L:L),beta))*fmesh/pi

     do i=-L,L
        det      = fg(1,i)*conjg(fg(1,-i)) + fg(2,i)**2
        calG(1,i)= conjg(fg(1,-i))/det + sigma(1,i)
        calG(2,i)= fg(2,i)/det + sigma(2,i) - deltasc
     end do
     do i=-L,L
        det     =  calG(1,i)*conjg(calG(1,-i)) + calG(2,i)**2
        fg0(1,i)=  conjg(calG(1,-i))/det
        fg0(2,i)=  calG(2,i)/det
        if(dimag(fg0(1,i)) > 0.d0)fg0(1,i)=real(fg0(1,i),8)+ (0.d0,1.d-9)
        if(i<0.d0 .AND. dimag(fg0(2,i))<0.d0)fg0(2,i)=real(fg0(2,i),8)+ (0.d0,1.d-9)
        if(i>0.d0 .AND. dimag(fg0(2,i))>0.d0)fg0(2,i)=real(fg0(2,i),8)+ (0.d0,1.d-9)
     end do
     sigma =  solve_ipt_sc_sopt(fg0,wr,deltasc)
     converged = check_convergence(sigma(1,:)+sigma(2,:),eps_error,nsuccess,nloop)
     call splot("Gloc_realw.ipt",wr,fg(1,:),append=printf)
     call splot("Floc_realw.ipt",wr,fg(2,:),append=printf)
  enddo

end program hmipt


subroutine rpn2(ixy, maxm, num_eqn, num_waves, num_aux, num_ghost, &
                num_cells, ql, qr, auxl, auxr, fwave, s, amdq, apdq)

! Riemann solver for the 2D shallow water equations

! (h)_t + (h*u)_x = 0
! (hu)_t + (h*u^2 + 1/2*grav*h^2)_x + (h*u*v)_y = -grav*h*(b)_x
! (hv)_t + (h*u*v)_x + (h*v^2 + 1/2*grav*h^2)_y = -grav*h*(b)_y

! using the f-wave algorithm and Roe's approximate Riemann solver.

! waves:     3
! equations: 3

! Conserved quantities:
!       1 depth
!       2 x_momentum
!       3 y_momentum

! Auxiliary fields:
!       1 bathymetry

! The gravitational constant grav should be in the common block cparam.
!
! See http://www.clawpack.org/riemann.html for a detailed explanation
! of the Riemann solver API.

    implicit none

    integer, intent(in) :: ixy, maxm, num_eqn, num_waves, num_ghost, num_aux, num_cells
    real(kind=8), intent(in) :: ql(num_eqn, 1-num_ghost:maxm+num_ghost)
    real(kind=8), intent(in) :: qr(num_eqn, 1-num_ghost:maxm+num_ghost)
    real(kind=8), intent(in) :: auxl(num_aux, 1-num_ghost:maxm+num_ghost)
    real(kind=8), intent(in) :: auxr(num_aux, 1-num_ghost:maxm+num_ghost)
    real(kind=8), intent(out) :: s(num_waves, 1-num_ghost:maxm+num_ghost)
    real(kind=8), intent(out) :: fwave(num_eqn, num_waves, 1-num_ghost:maxm+num_ghost)
    real(kind=8), intent(out) :: amdq(num_eqn,1-num_ghost:maxm+num_ghost)
    real(kind=8), intent(out) :: apdq(num_eqn,1-num_ghost:maxm+num_ghost)

    real(kind=8) :: grav, dry_tolerance, sea_level
    common /cparam/ grav, dry_tolerance, sea_level

    real(kind=8) :: hl, ul, vl, bl, hr, ur, vr, br, hbar, uhat, chat
    real(kind=8) :: phil, phir, dry_state_l, dry_state_r
    real(kind=8) :: R(3,3)
    real(kind=8) :: fluxdiff(3), beta(3)

    integer :: i, k, normal_index, transverse_index

    ! Determine normal and tangential directions
    if (ixy == 1) then
        normal_index = 2
        transverse_index = 3
    else
        normal_index = 3
        transverse_index = 2
    end if

    amdq = 0.d0
    apdq = 0.d0

    ! Primary loop over each cell
    do i = 2 - num_ghost, num_cells + num_ghost

        ! Check for dry states - need merge here to convert to float
        dry_state_l = merge(0.d0, 1.d0, qr(1, i - 1) < dry_tolerance)
        dry_state_r = merge(0.d0, 1.d0, ql(1, i) < dry_tolerance)

        ! Note that for the states below u is always the normal velocity and
        ! v is always the tangential velocity

        ! Left states
        hl = qr(1, i - 1) * dry_state_l
        ul = qr(normal_index, i - 1) / qr(1, i - 1) * dry_state_l
        vl = qr(transverse_index, i - 1) / qr(1, i - 1) * dry_state_l
        phil = (0.5d0 * grav * hl**2 + hl * ul**2) * dry_state_l

        bl = auxr(1, i - 1)

        ! Right states
        hr = ql(1, i) * dry_state_r
        ur = ql(normal_index, i) / ql(1, i) * dry_state_r
        vr = ql(transverse_index, i) / ql(1, i) * dry_state_r
        phir = (0.5d0 * grav * hr**2 + hr * ur**2) * dry_state_r

        br = auxl(1, i)

        ! Roe average states (Roe's linearization)
        hbar = 0.5d0 * (hr + hl)
        uhat = (sqrt(hr) * ur + sqrt(hl) * ul) / (sqrt(hr) + sqrt(hl))
        chat = sqrt(grav * hbar)

        ! Flux differences
        fluxdiff(1) = hr * ur - hl * ul
        fluxdiff(2) = phir - phil + grav * hbar * (br - bl)
        fluxdiff(3) = hr * ur * vr - hl * ul * vl

        ! Wave speeds
        s(1, i) = min(uhat - chat, ul - sqrt(grav * hl))
        s(3, i) = max(uhat + chat, ur + sqrt(grav * hr))
        s(2, i) = 0.5d0 * (s(1, i) + s(3, i))

        ! Right eigenvectors (columns)
        ! could possibly use vhat instead of vl and vr
        R(1, 1) = 1.d0
        R(normal_index, 1) = s(1, i)
        R(transverse_index, 1) = vl

        R(1, 2) = 0.d0
        R(normal_index, 2) = 0.0
        R(transverse_index, 2) = 1.0

        R(1, 3) = 1.d0
        R(normal_index, 3) = s(3, i)
        R(transverse_index, 3) = vr

        ! Wave strengths
        beta(1) = (s(3, i) * fluxdiff(1) - fluxdiff(2)) / (s(3, i) - s(1, i))
        beta(3) = (fluxdiff(2) - s(1, i) * fluxdiff(1)) / (s(3, i) - s(1, i))
        beta(2) = fluxdiff(3) - beta(1) * vl - beta(3) * vr

        ! f-waves
        do k = 1, num_waves
            fwave(:, k, i) = beta(k) * R(:, k)
        enddo

        ! Fluctuations - could probably rewrite this to be a masking operation
        ! instead...
        do k=1, num_waves
            if (s(k, i) < 1.0e-14) then
                amdq(:, i) = amdq(:, i) + fwave(:, k, i)
            elseif (s(k, i) > 1.0e-14) then
                apdq(:, i) = apdq(:, i) + fwave(:, k, i)
            else
                amdq(:, i) = amdq(:, i) + 0.5d0 * fwave(:, k, i)
                apdq(:, i) = apdq(:, i) + 0.5d0 * fwave(:, k, i)
            endif
        enddo

    enddo ! End of main loop

end subroutine rpn2


Real Function pp2(srt)
  Save
  pmass = 0.9383
  scheck = ((srt**2-2.*pmass**2)/(2.*pmass))**2 - pmass**2
  If (scheck<0) Then
     Write (99, *) 'scheck33: ', scheck
     scheck = 0.
  End If
  plab = sqrt(scheck)
  pmin = 2.
  pmax = 2050
  If (plab>pmax) Then
     pp2 = 8.
     Return
  End If
  If (plab<pmin) Then
     pp2 = 25.
     Return
  End If
  a = 11.2
  b = 25.5
  c = 0.151
  d = -1.62
  an = -1.12
  pp2 = a + b*(plab**an) + c*(alog(plab))**2 + d*alog(plab)
  If (pp2<=0) pp2 = 0
  Return
End Function pp2


      subroutine intp_coef_norm(nfilter,xintp)

      implicit none
      integer*4     i,j,k,nfilter
      real*4        x,y,pi, sum
      real*4        xintp(0:65544)

      pi = 4.*atan(1.)
c     compute the interpolation factors
      do i=0,nfilter
         j = i*8
         x = real(i)/real(nfilter)
         y = sin(pi*x)/pi
         if(x.ne.0.0  .and. x.ne.1.0) then

            xintp(j  ) = -y/(3.0+x)
            xintp(j+1) =  y/(2.0+x)
            xintp(j+2) = -y/(1.0+x)
            xintp(j+3) =  y/x
            xintp(j+4) =  y/(1.0-x)
            xintp(j+5) = -y/(2.0-x)
            xintp(j+6) =  y/(3.0-x)
            xintp(j+7) = -y/(4.0-x)

c     normalize by the sum of the squares

            sum = 0.
            do k = 0 , 7
               sum = sum + xintp(j+k)**2
            end do
c            sum = sqrt(sum)
            do k = 0 , 7
               xintp(j+k) = xintp(j+k) / sum
            end do

         else if( x.eq.0.0) then
            xintp(j  ) = 0.0
            xintp(j+1) = 0.0
            xintp(j+2) = 0.0
            xintp(j+3) = 1.0
            xintp(j+4) = 0.0
            xintp(j+5) = 0.0
            xintp(j+6) = 0.0
            xintp(j+7) = 0.0
         else if( x.eq.1.0) then
            xintp(j  ) = 0.0
            xintp(j+1) = 0.0
            xintp(j+2) = 0.0
            xintp(j+3) = 0.0
            xintp(j+4) = 1.0
            xintp(j+5) = 0.0
            xintp(j+6) = 0.0
            xintp(j+7) = 0.0
         end if
      end do

      return
      end


#include "Config.fpp"

module mod_rectw_signal

  !===================================================================================85
 !---------------------------- DESCRIPTION ------------------------------------------85
 !
 !
 !
 !          Module  name:
 !                         'mod_rectw_signal'
 !
 !          Purpose:
 !                  Rect-Wave Signal representation
 !                  approximated by Fourier series.
 !
 !
 !          History:
 !                        Date: 28-08-2017
 !                        Time: 14:23 GMT+2
 !          Modified:
 !                    Bernard Gingold on: 07-03-2018, 18:33 GMT+2
 !                   1) Refactoring to Fortran 2003 standard.
 !                   2) Removing unnecessary type-bound members
 !                   3) Adding computational subroutines (additive noise)
 !                   4) Removing unnecessary destructor,copy and initialization subroutines.
 !
 !          Version:
 !
 !                      Major: 1
 !                      Minor: 0
 !                      Micro: 0
 !
 !          Author:  Bernard Gingold
 !
 !
 !
 !
 !
 !          E-mail:
 !
 !                      beniekg@gmail.com
 !==================================================================================85

 ! Tab:5 col - Type and etc.. definitions
 ! Tab:10,11 col - Type , function and subroutine code blocks.
    use module_kinds,        only : I32P, R64P

    use mod_code_timing
    use mod_complex_arithm , only : vcmag
    use mod_jonesvec
    implicit none
    private

    !=====================================================59
    !  File and module information:
    !  version,creation and build date, author,description
    !=====================================================59

    ! Major version
    integer(I32P), parameter, public :: MOD_RECTW_SIGNAL_MAJOR = 1

    ! Minor version
    integer(I32P), parameter, public :: MOD_RECTW_SIGNAL_MINOR = 0

    ! Micro version
    integer(I32P), parameter, public :: MOD_RECTW_SIGNAL_MICRO = 0

    ! Module full version
    integer(I32P), parameter, public :: MOD_RECTW_SIGNAL_FULLVER = 1000*MOD_RECTW_SIGNAL_MAJOR+100*MOD_RECTW_SIGNAL_MINOR+ &
                                                                   10*MOD_RECTW_SIGNAL_MICRO

    ! Module/file creation date
    character(*),  parameter, public :: MOD_RECTW_SIGNAL_CREATE_DATE = "28-08-2017 14:59 +00200 (MON 28 AUG 2017 GMT+2)"

    ! Module build date (should be set after successful compilation)
    character(*),  parameter, public :: MOD_RECTW_SIGNAL_BUILD_DATE = " "

    ! Module author info
    character(*),  parameter, public :: MOD_RECTW_SIGNAL_AUTHOR = "Programmer: Bernard Gingold e-mail: beniekg@gmail.com"

    ! Module short description
    character(*),  parameter, public :: MOD_RECTW_SIGNAL_DESCRIPT = "Rect-wave signal approximated by Fourier series."

    !======================================================60
    !  Type: RectWSignal_t
    !======================================================60

    type, public  :: RectWSignal_t

         private

         ! Signal name
         character(len=64) :: m_name

         ! Signal ID
         integer(I32P)     :: m_sid

         ! Number of samples
         integer(I32P)     :: m_nsamp

         ! Number of Fourier sinusoids
         integer(I32P)     :: maxk

         ! Signal duration i.e. T
         real(R64P)        :: m_dur

         ! Rect Wave initial time-point
         real(R64P)        :: m_sinit

         ! Rect wave time-step increment
         real(R64P)        :: m_stsinc

         ! Jones vector field
         type(JonesVector_t), allocatable, dimension(:), public :: m_jvec

          ! Sine components of k sinusoids
         real(R64P), allocatable, dimension(:,:),        public :: m_scomp
!DIR$    ATTRIBUTES ALIGN : 64 :: m_scomp

         ! Cosine components of k cosinusoids
         real(R64P), allocatable, dimension(:,:),        public :: m_ccomp
!DIR$    ATTRIBUTES ALIGN : 64 :: m_ccomp

         ! Time argument
         real(R64P), allocatable, dimension(:),          public   :: m_wt
!DIR$    ATTRIBUTES ALIGN : 64 :: m_wct

         ! Signal natural envelope
         real(R64P), allocatable, dimension(:),          public   :: m_nenvp
!DIR$    ATTRIBUTES ALIGN : 64 :: m_nenvp

         ! Signal squarewave approximated by k sinusoids
         real(R64P), allocatable, dimension(:),          public   :: m_rectw
!DIR$    ATTRIBUTES ALIGN : 64 :: m_squarewave

         ! SquareWave complex representation
         real(R64P), allocatable, dimension(:),          public   :: m_cform
!DIR$    ATTRIBUTES ALIGN : 64 :: m_cform

         ! Electric field
        complex(R64P), allocatable, dimension(:),        public   :: m_E
!DIR$   ATTRIBUTES ALIGN : 64 :: m_E

         ! Signal amplitude  A(phi,theta)/r used for calculation electric field
         ! far from emmiter(antenna)
         real(R64P), allocatable, dimension(:),         public   :: m_amp
!DIR$   ATTRIBUTES ALIGN : 64 :: m_amp

 ! Time-averaged power density

         complex(R64P), allocatable, dimension(:),      public :: m_S
!DIR$   ATTRIBUTES ALIGN : 64 :: m_S

         contains

        ! Construct SquareWave signal approximated by its
        ! Fourier series
         procedure, pass(this), public :: rectwave_signal

        ! Creates signal with noise modulated phase
        ! coupled with background additive noise.
        procedure, pass(this), public :: noisy_rectwave_signal

        !==========================================52
        !   Getter pure functions
        !==========================================52

         procedure, pass(this), public :: get_name

         procedure, pass(this), public :: get_sid

         procedure, pass(this), public :: get_nsamp

         procedure, pass(this), public :: get_maxk

         procedure, pass(this), public :: get_dur

         procedure, pass(this), public :: get_sinit

         procedure, pass(this), public :: get_stsinc

        !==================================================60
        ! Computational subroutines
        !==================================================60

        procedure, pass(this), public :: dphi_dt

        !==============================================56
        ! write/read subroutines
        !==============================================56

        procedure, nopass,     public :: read_state

        procedure, nopass,     public :: write_state

        !===============================================
        !  Class helper procedures
        !===============================================
        procedure, pass(this), public :: dbg_info
        !===============================================
        !   Generic operators
        !===============================================
        procedure, public :: copy_assign

        generic :: assignment (=) => copy_assign

    end type RectWSignal_t

   interface RectWSignal_t
         procedure :: constructor
   end interface RectWSignal_t

   contains

    !======================================================60
    ! @function:  constructor
    !             Memory allocation and
    !             default initialization of array and scalar
    !             member variables.
    !======================================================60
    type(RectWSignal_t) function constructor(name,sid,nsamp,maxk, verbose,  &
                                            logging,filename,append)
          use mod_print_error,  only : handle_fatal_memory_error
          use mod_constants,    only : LAM_PINF, LAM_MINSAMP,  &
                                       LAM_MINK
          character(len=*),     intent(in)       :: name
          integer(I32P),        intent(in)       :: sid
          integer(I32P),        intent(inout)    :: nsamp,maxk
          logical(I32P),        intent(in)       :: logging , verbose
          character(len=*),     intent(in)       :: filename
          logical(I32P),        intent(in)       :: append
          ! Locals

          character(len=256) :: emsg
          integer(I32P)      :: aerr
          ! Start of executable statements
          ! Allow this for error correction.
          if(nsamp < LAM_MINSAMP) then
              nsamp = LAM_MINSAMP
          end if
          if(maxk < LAM_MINK) then
              maxk = LAM_MINK
          end if
          ! Begin construction
          constructor%m_name   = name
          constructor%m_sid    = sid
          constructor%m_nsamp  = nsamp
          constructor%m_maxk   = maxk
          constructor%m_dur    = LAM_PINF
          constructor%m_sinit  = LAM_PINF
          constructor%m_stsinc = LAM_PINF

          associate(k=>constructor%m_maxk,       &
                    n=>constructor%m_nsamp)
              allocate(constructor%m_jvec(n),    &
                       constructor%m_scomp(k,n), &
                       constructor%m_ccomp(k,n), &
                       constructor%m_wt(n),      &
                       constructor%m_nenvp(n),   &
                       constructor%m_rectw(n),   &
                       constructor%m_cform(n),   &
                       constructor%m_E(n),       &
                       constructor%m_amp(n),     &
                       constructor%m_S(n),       &
                       STAT=aerr,         &
                       ERRMSG=emsg)
          end associate
          if(aerr /= 0) then

              call handle_fatal_memory_error(logging,verbose,append,filename,  &
                                             "logger:311 --> mod_rectwave_signal/constructor: Memory Allocation Failure!!"  , &
                                             "mod_rectwave_signal/constructor:311 --  Memory Allocation Failure!!" , &
                                             emsg,__LINE__ )
          end if
          constructor%m_jvec  = JonesVector()
          constructor%m_scomp = LAM_PINF
          constructor%m_ccomp = LAM_PINF
          constructor%m_wt    = LAM_PINF
          constructor%m_nenvp = LAM_PINF
          constructor%m_rectw = LAM_PINF
          constructor%m_cform = CMPLX(LAM_PINF,LAM_PINF,R64P)
          constructor%m_E     = CMPLX(LAM_PINF,LAM_PINF,R64P)
          constructor%m_amp   = LAM_PINF
          constructor%m_S     = CMPLX(LAM_PINF,LAM_PINF,R64P)

    end function constructor

    !======================================================60
    !  subroutine: create_signal
    !              Physical representation of Rect wave
    !              approximated by K sinusoids (Fourier-
    !              series)
    !======================================================60
    subroutine rectwave_signal(this,ierr,dur,dc,sinit,stsinc,r,h,v, &
                             logging,verbose,append,fname,profiling,qpctimer )
           use mod_print_error,  only : handle_fatal_memory_error ,  &
                                        stderr
           use mod_constants,    only : LAM_ZR8
           class(RectWSignal_t),        intent(inout) :: this
           integer(I32P),               intent(inout) :: ierr
           real(R64P),                  intent(in)    :: dur,dc,sinit,stsinc
           real(R64P), dimension(:),    intent(in)    :: r
!DIR$     ASSUME_ALIGNED r:64
           complex(R64P), dimension(:), intent(in)    :: h,v
!DIR$     ASSUME_ALIGNED h:64,v:64
           logical(I32P),               intent(in)    :: profiling,logging, &
                                                         verbose,append
           character(len=*),            intent(in)    :: fname
           type(QPCTimer_t),            intent(inout) :: qpctimer
          ! Locals
           integer(I32P)      :: k,j,aerr
           character(len=256) :: emsg
           integer(BOOL)      :: ifail
           logical(I32P)      :: bfail
           real(R64P)         :: insamp,t,t2,delta,sa,ca,idur,ratio
           real(R64P), allocatable, dimension(:) :: tcos,ts,tc
!DIR$     ATTRIBUTES ALIGN : 64 :: tcos
!DIR$     ATTRIBUTES ALIGN : 64 :: ts
!DIR$     ATTRIBUTES ALIGN : 64 :: tc
          if(ierr < 0_I32P) ierr = 0_I32P
          if(dur  < LAM_ZR8) then
              ierr = -1_I32P
              return
          end if
          this%m_dur    = dur
          this%m_sinit  = sinit
          this%m_stsinc = stsinc
          associate(n=>this%m_nsamp)
              allocate(
                       tcos(n),           &
                       tc(n),             &
                       ts(n),             &
                       STAT=aerr,         &
                       ERRMSG=emsg )
          end associate
          if(aerr /= 0) then

              call handle_fatal_memory_error( logging,verbose,append,fname,   &
                                              "logger:391,--> mod_rectwave_signal/rectwave_signal: Memory Allocation Failure !!", &
                                              "mod_rectwave_signal/rectwave_signal:391 -- Memory Allocation Failure!" ,           &
                                              emsg,__LINE__ )
          end if
          if(profiling) then
              call qpctimer_start(qpctimer,ifail)
              if(ifail == 0) then
                  write(stderr,*) "mod_rectwave_signal/rectwave_signal: qpctimer_start failed to query performance frequency counter!"
              end if
          end if
          ! Create Jones vector field
          do j = 1_I32P, this%m_nsamp
              this%m_jvec(j) = JonesVector_t(h(j),v(j))
          end do
           ! Create sine and cosine Fourier series components
          insamp = 1._R64P/DBLE(this%m_nsamp)
          idur = 1._R64P/this%m_dur
          do k = 1, this%m_maxk
              do j = 1_I32P, this%m_nsamp
                  this%m_sinit = this%m_sinit+this%m_stsinc
                  delta = DBLE(j)*insamp
                  t = this%m_sinit*delta
                  sa = LAM_PI*k*dc*idur
                  ca = LAM_2PI*k*idur
                  this%m_scomp(k,j) = (2._R64P/k*LAM_PI)*DSIN(sa)*DCOS(ca*t)
                  this%m_ccomp(k,j) = (2._R64P/k*LAM_PI)*DCOS(sa)*DSIN(ca*t)
              end do
          end do
          ! Do summation over rows
          this%m_rectw = SUM(this%m_scomp,dim=2)
          tcos = SUM(this%m_ccomp,dim=2)
          ! Create Rect wave signal (final approximation) and
          ! create signal complex representation
          ratio = dc/dur
          do j = 1_I32P, this%m_nsamp
              this%m_sinit = this%m_sinit+this%m_stsinc
              delta = DBLE(j)*insamp
              t = this%m_sinit*delta
              this%m_wt(j) = t
              this%m_rectw(j) = ratio+this%m_rectw(j)
              tcos(j) = ratio+tcos(j)
              this%m_cform(j) = DCMPLX(tcos(j),this%m_rectw(j))
          end do
           ! Compute natural envelope
          call vcmag(this%m_cform,this%m_nenvp)
           ! Create electrical field far from the emitter.
          do k = 1, this%m_maxk
              do j = 1, this%m_nsamp
                  t2 = this%m_wt(j)-r(j)/LAM_c
                  sa = LAM_PI*k*dc*idur
                  ca = LAM_2PI*k*idur
                  this%m_scomp(k,j) = (2._R64P/k*LAM_PI)*DSIN(sa)*DCOS(ca*t2)
                  this%m_ccomp(k,j) = (2._R64P/k*LAM_PI)*DCOS(sa)*DSIN(ca*t2)
              end do
          end do
            ! Do summation over the rows
          tc = SUM(this%m_ccomp,dim=2)
          ts = SUM(this%m_scomp,dim=2)
          do j = 1, this%m_nsamp
              tc(j) = ratio+tc(j)
              ts(j) = ratio+ts(j)
              this%m_E(j) = DCMPLX(tc(j),ts(j))
          end do
          ! Compute A(phi,theta)/r - magnitude of electric field E
          call vcmag(this%m_E,this%m_amp)
            ! Compute time-average power density i.e. 0.5xExE*/n
          do j = 1, this%m_nsamp
              this%m_S(j) =  LAM_HR64P*this%m_E(j)*DCONJG(this%m_E(j))*0.0026525198938992_R64P
          end do
          if(profiling) then
                if(ifail == 0) then
                    call qpctimer_stop(qpctimer,ifail)
                    call qpctimer_delta(qpctimer,bfail)
                    if(bfail == .false.) then
                         call qpctimer_print(qpctimer)
                    else
                         write(stderr,*) "mod_rectw_signal/rectwave_signal: qpctimer_delta: failed to compute delta measurement!!"
                    end if
                else
                    write(stderr,*) "mod_rectw_signal/rectwave_signal: Unable to read performance counter -- fatal!!"
                end if
          end if
    end subroutine  rectwave_signal

    !======================================================60
    !  subroutine: noisy_rectwave_signal
    !              Physical representation of Rect wave
    !              approximated by K sinusoids (Fourier-
    !              series)
    !              This signal is corrupted by background
    !              additive noise.
    !======================================================60
    subroutine noisy_rectwave_signal(this,ierr, dur,dc, &
                                     sinit,stsinc,r,bnoise,h,v,logging, &
                                     filename,append,dbg,profiling,qpctimer )
          use mod_print_error,   only : handle_fatal_memory_error,  &
                                        stderr
          use mod_constants,     only : LAM_ZR8
          class(RectWSignal_t),        intent(inout) :: this
          integer(I32P),               intent(inout) :: ierr
          real(R64P),                  intent(in)    :: dur,dc,sinit,stsinc
          real(R64P), dimension(:),    intent(in)    :: r,bnoise
!DIR$     ASSUME_ALIGNED r:64,bnoise:32
          complex(R64P), dimension(:), intent(in)    :: h,v
!DIR$     ASSUME_ALIGNED h:64,v:32
          logical(I32P),               intent(in)    :: logging
          character(len=*),            intent(in)    :: filename
          logical(I32P),               intent(in)    :: append,dbg,profiling
          type(QPCTimer_t),            intent(inout) :: qpctimer
          ! Locals

          character(len=256) :: emsg
          integer(I32P)      :: k,j,aerr
          integer(BOOL)      :: ifail
          logical(I32P)      :: bfail
          real(R64P)         :: insamp,t,t2,delta,sa,ca,idur,ratio
          real(R64P), allocatable, dimension(:) :: tcos,ts,tc
!DIR$     ATTRIBUTES ALIGN : 64 :: tcos
!DIR$     ATTRIBUTES ALIGN : 64 :: ts
!DIR$     ATTRIBUTES ALIGN : 64 :: tc
          ! Start of executable statements
          if(ierr < 0_I32P) ierr = 0_I32P
          if(dur.LT.LAM_ZR8) then
              ierr = -1_I32P
              return
          end if
          ! Begin construction

          this%m_dur    = dur
          this%m_sinit  = sinit
          this%m_stsinc = stsinc

          associate(n=>this%m_nsamp)
              allocate(
                       tcos(n),           &
                       tc(n),             &
                       ts(n),             &
                       STAT=aerr,         &
                       ERRMSG=emsg )
          end associate
          if(aerr /= 0) then

              call  handle_fatal_memory_error(logging,verbose,append,filename,   &
                                              "logger:532 --> mod_rectw_signal/noisy_rectwave_signal: Memory allocation failure!" , &
                                              "mod_rectw_signal/noisy_rectwave_signal:532 --  Memory allocation failure!"  , &
                                              emsg,__LINE__ )
          end if
          if(profiling) then
              call qpctimer_start(qpctimer,ifail)
              if(ifail == 0) then
                  write(stderr,*) "mod_rectw_signal/noisy_rectwave_signal: qpctimer_start failed to query performance frequency counter!"
              end if
          end if
           ! Create Jones vector field
          do j = 1, this%m_nsamp
              this%m_jvec(j) = JonesVector_t(h(j),v(j))
          end do
           ! Create sine and cosine Fourier series components
          insamp = 1._R64P/DBLE(this%m_nsamp)
          idur = 1._R64P/this%m_dur
          do k = 1, this%m_maxk
              do j = 1, this%m_nsamp
                  this%m_sinit = this%m_sinit+this%m_stsinc
                  delta = DBLE(j)*insamp
                  t = this%m_sinit*delta
                  sa = LAM_PI*k*dc*idur
                  ca = LAM_2PI*k*idur
                  this%m_scomp(k,j) = (2._R64P/k*LAM_PI)*DSIN(sa)*DCOS(ca*t)
                  this%m_scomp(k,j) = bnoise(j)+this%m_scomp(k,j)
                  this%m_ccomp(k,j) = (2._R64P/k*LAM_PI)*DCOS(sa)*DSIN(ca*t)
                  this%m_ccomp(k,j) = bnoise(j)+this%m_ccomp(k,j)
              end do
          end do
          ! Do summation over rows
          this%m_rectw = SUM(this%m_scomp,dim=2)
          tcos = SUM(this%m_ccomp,dim=2)
          ! Create Rect wave signal (final approximation) and
          ! create signal complex representation
          ratio = dc/dur
          do j = 1, this%m_nsamp
              this%m_sinit = this%m_sinit+this%m_stsinc
              delta = DBLE(j)*insamp
              t = this%m_sinit*delta
              this%m_wt(j) = t
              this%m_rectw(j) = ratio+this%m_rectw(j)
              tcos(j) = ratio+tcos(j)
              this%m_cform(j) = DCMPLX(tcos(j),this%m_rectw(j))
          end do
          ! Compute natural envelope
          call vcmag(this%m_cform,this%m_nenvp)
           ! Create electrical field far from the emitter.
          do k = 1, this%m_maxk
              do j = 1, this%m_nsamp
                  t2 = this%m_wt(j)-r(j)/LAM_c
                  sa = LAM_PI*k*dc*idur
                  ca = LAM_2PI*k*idur
                  this%m_scomp(k,j) = (2._R64P/k*LAM_PI)*DSIN(sa)*DCOS(ca*t2)
                  this%m_scomp(k,j) = bnoise(j)+this%m_scomp(k,j)
                  this%m_ccomp(k,j) = (2._R64P/k*LAM_PI)*DCOS(sa)*DSIN(ca*t2)
                  this%m_ccomp(k,j) = bnoise(j)+this%m_ccomp(k,j)
              end do
          end do
          ! Do summation over the rows
          tc = SUM(this%m_ccomp,dim=2)
          ts = SUM(this%m_scomp,dim=2)
          do j = 1, this%m_nsamp
              tc(j) = ratio+tc(j)
              ts(j) = ratio+ts(j)
              this%m_E(j) = DCMPLX(tc(j),ts(j))
          end do
          ! Compute A(phi,theta)/r - magnitude of electric field E
          call vcmag(this%m_E,this%m_amp)
            ! Compute time-average power density i.e. 0.5xExE*/n
          do j = 1, this%m_nsamp
              this%m_S(j) =  LAM_HR64P*this%m_E(j)*DCONJG(this%m_E(j))*0.0026525198938992_R64P
          end do
          this%m_isbuilt = .true.
          if(profiling) then
                if(ifail == 0) then
                    call qpctimer_stop(qpctimer,ifail)
                    call qpctimer_delta(qpctimer,bfail)
                    if(bfail == .false.) then
                         call qpctimer_print(qpctimer)
                    else
                         write(stderr,*) "mod_rectw_signal/noisy_rectwave_signal: qpctimer_delta: failed to compute delta measurement!!"
                    end if
                else
                    write(stderr,*) "mod_rectw_signal/noisy_rectwave_signal: Unable to read performance counter -- fatal!!"
                end if
          end if
    end subroutine noisy_rectwave_signal

    !======================================================60
    ! Getter pure functions
    !======================================================60

    pure function get_name(this) result(name)
          implicit none
          class(RectWSignal_t), intent(in) :: this
          ! Locals
          character(len=64) :: name
          ! Start of executable statements
          name = this%m_name
    end function

    pure function get_sid(this) result(sid)
          implicit none
          class(RectWSignal_t), intent(in) :: this
          ! LOCALS
          integer(I32P) :: sid
          ! Start of executable statements
          sid = this%m_sid
    end function

    pure function get_nsamp(this) result(nsamp)
          implicit none
          class(RectWSignal_t), intent(in) :: this
          ! Locals
          integer(I32P) :: nsamp
          ! Start of executable statements
          nsamp = this%m_nsamp
    end function

    pure function get_maxk(this) result(maxk)
          implicit none
          class(RectWSignal_t), intent(in) :: this
          ! Locals
          integer(I32P) :: maxk
          ! Start of executable statements
          maxk = this%m_maxk
    end function

    pure function get_dur(this) result(dur)
          implicit none
          class(RectWSignal_t), intent(in) :: this
          ! Locals
          real(R64P) :: dur
          ! Start of executable statements
          dur = this%m_dur
    end function

    pure function get_sinit(this) result(sinit)
          implicit none
          class(RectWSignal_t), intent(in) :: this
          ! Locals
          real(R64P) :: sinit
          ! Start of executable statements
          sinit = this%m_sinit
    end function

    pure function get_stsinc(this) result(stsinc)
          implicit none
          class(RectWSignal_t), intent(in) :: this
          ! Locals
          real(R64P) :: stsinc
          ! Start of executable statements
          stsinc = this%m_stsinc
    end function

    !======================================================60
    !    Computational procedures
    !======================================================60
    ! TODO:
    !        ! Consider using CADNA to test for cancellation errors
    subroutine dphi_dt(this,dphi,sfac)

          class(RectWSignal_t),     intent(in)    :: this
          real(R64P), dimension(:), intent(out)   :: dphi
          integer(I64P),            intent(inout) :: sfac
          ! Locals
          integer(I32P) :: i
          real(R64P)    :: eps,isfac,tmp
          ! Start of executable statements
          if(sfac.LE.LAM_IZER8) then
              sfac =  1000000000000000_I64P
          end if
          isfac = 1._R64P/DBLE(sfac)
          eps = LAM_MEPS8**0.3333333333333333333333333333_R64P
          do i = 2, this%m_nsamp-1
              tmp = this%m_wt(i+1)-this%m_wt(i-1)
              dphi(i) = this%m_wt(i+1)-this%m_wt(i-1) / &
                           (2._R64P*eps*DMAX1(DABS(tmp),isfac)*DSIGN(tmp,tmp))
          end do
    end subroutine

    !============================================
    !   Read/write procedures
    !============================================
       subroutine read_state(this,form,unit,ioerr)

          class(RectWSignal_t), intent(in) :: this
          character(len=*),     intent(in) :: form
          integer(I32P),        intent(in) :: unit
          integer(I32P),        intent(inout) :: ioerr
          ! Start of executable statements
          select case(adjustl(trim(form)))
          case ("*")
              READ(unit,*,iostat=ioerr) this
          case default
              READ(unit,adjustl(trim(form)),iostat=ioerr) this
          end select
    end subroutine read_state

    subroutine write_state(this,form,unit,ioerr)

          class(RectWSignal_t), intent(in) :: this
          character(len=*),     intent(in) :: form
          integer(I32P),        intent(in) :: unit
          integer(I32P),        intent(inout) :: ioerr
          ! Start of executable statements
          select case(adjustl(trim(form)))
          case ("*")
              WRITE(unit,*,iostat=ioerr) this
          case default
              WRITE(unit,adjustl(trim(form)),iostat=ioerr) this
          end select
    end subroutine write_state

    !======================================================60
    !  subroutine: dgb_info
    !======================================================60
    subroutine dbg_info(this,verbose)
          implicit none
          class(RectWSignal_t),    intent(in) :: this
          logical(I32P),           intent(in) :: verbose
          ! Locals
          ! Start of executable statements
          call DATE_AND_TIME(date=dstr,time=tstr)
          print*, "======================================================"
          print*, "   ***Printing components of RectWSignal_t***"
          print*, "   printing subroutine called at: " , &
                     sdate(1:4),"-",sdate(5:6),"-",sdate(7:8), " ", &
                     stime(1:2),":",stime(3:4),":",stime(5:6)
          print*, "           Dumping scalar components "
          print*, "======================================================"
          print*, "Name:               ", this%m_name
          print*, "Signal ID:          ", this%m_pid
          print*, "Number of samples:  ", this%m_nsamp
          print*, "Maximum 'k':        ", this%m_maxk
          print*, "Signal duration:    ", this%m_dur

          print*, "Initial time-point: ", this%m_sinit
          print*, "Time-step increment:", this%m_stsinc

          print*, "           Dumping array components  "
          print*, "======================================================"
          print*, "******************************************************"

          if(verbose) then
              print*, "Sine series components:  ", this%m_scomp
              print*, "Cosine series components:", this%m_ccomp
          end if
          print*, "Signal polarization:  ",   this%m_jvec
          print*, "Time (t):             ",   this%m_wt
          print*, "Natural Envelope:     ",   this%m_nenvp
          print*, "Rect-wave(t):         ",   this%m_rectw
          print*, "Complex form:         ",   this%m_cform
          print*, "Electric field:       ",   this%m_E
          print*, "Amplitude:            ",   this%m_amp
          print*, "Time-average power:   ",   this%m_S
    end subroutine

    !======================================================60
    !  subroutine: copy_assign
    !              Overloaded assignment (=)
    !======================================================60
    subroutine copy_assign(this,other)

          class(RectWSignal_t), intent(inout) :: this
          class(RectWSignal_t), intent(in)    :: other
          ! Start of executable statements
          this%m_name     = other%m_name
          this%m_sid      = other%m_sid
          this%m_nsamp    = other%m_nsamp
          this%m_maxk     = other%m_maxk
          this%m_dur      = other%m_dur
          this%m_sinit    = other%m_sinit
          this%m_stsinc   = other%m_stsinc
          this%m_jvec     = other%m_jvec
          this%m_scomp    = other%m_scomp
          this%m_ccomp    = other%m_ccomp
          this%m_wt       = other%m_wt
          this%m_nenvp    = other%m_nenvp
          this%m_rectw    = other%m_rectw
          this%m_cform    = other%m_cform
          this%m_E        = other%m_E
          this%m_amp      = other%m_amp
          this%m_S        = other%m_S
   end subroutine copy_assign

end module mod_rectw_signal


program timing

    use iso_fortran_env
    use sobseq

    type(sobol_state) :: rng

    real(real64), dimension(:), allocatable :: tmp

    integer, parameter :: s=1, a=0, m(1) = (/1/)
    integer, parameter :: N_samples = 1000000
    real(real64) :: t0, t1

    integer :: i

    allocate(tmp(N_samples))

    write(*,"(A,i10,A)", advance="no") "Testing time skip_ahead (", N_samples, "): "

    rng = sobol_state(s,a,m)

    call cpu_time(t0)
    do i=1,N_samples
        tmp(i) = rng%skip_ahead(i)
    end do
    call cpu_time(t1)

    write(*,*) (t1-t0)/N_samples, sum(tmp)/N_samples

    write(*,"(A,i10,A)",advance="no") "Testing time next (", N_samples, "): "

    rng = sobol_state(s,a,m)

    call cpu_time(t0)
    do i=1,N_samples
        tmp(i) = rng%next()
    end do
    call cpu_time(t1)

    write(*,*) (t1-t0)/N_samples, sum(tmp)/N_samples

end program timing


c
c
c ... file rgrd4u.f
c
c     this file contains documentation for subroutine rgrd4u followed by
c     fortran code for rgrid4u and additional subroutines.
c
c ... author
c
c     John C. Adams (NCAR 1999)
c
c ... subroutine rgrd4u(nx,ny,nz,nt,p,mx,my,mz,mt,q,intpol,w,lw,iw,liw,ier)
c
c ... purpose
c
c     subroutine rgrd4u interpolates the nx by ny by nz by nt array p onto
c     the mx by my by mz by mt array q.  it is assumed that p and q are
c     values on uniform nx by ny by nz by nt and mx by my by mz by mt grids
c     which are superimposed on the same box region (INCLUDING BOUNDARIES).
c     if p and q are values on nonuniform orthogonal grids and/or if the grid
c     on which q is defined lies within the p grid then subroutine rgrd4
c     (see file rgrd4.f) should be used.
c
c ... language
c
c     coded in portable FORTRAN77 and FORTRAN90
c
c ... test program
c
c     file trgrd4u.f on regridpack includes a test program for subroutine rgrd4u
c
c ... method
c
c     linear or cubic interpolation (see intpol) is used in each
c     direction for which the q grid is not a subgrid of the p grid.
c     [the mx (my,mz,mt) uniform grid is a subgrid of the nx (ny,nz,nt)
c     uniform grid if and only if mx-1 (my-1,nz-1,nt-1) divides nx-1
c     (ny-1,nz-1,nt-1)].  Values are set directly without (the need for)
c     interpolation in subgrid directions.
c
c ... required files
c
c     files rgrd3u.f,rgrd2u.f and rgrd1u.f must be loaded with rgrd4u.f.  they
c     include subroutines called by the routines in rgrd4u.f
c
c ... efficiency
c
c     inner most loops in regridpack software vectorize.  If the
c     integer arguments mx,my,mz,mt (see below) have different values,
c     optimal vectorization will be achieved if they are arranged so that
c     mx > my > mz > mt.
c
c *** input arguments ***
c
c
c ... nx
c
c     the integer first dimension of p.  nx > 1 if intpol(1) = 1 or
c     nx > 3 if intpol(1) = 3 is required (see ier = 2).
c
c ... ny
c
c     the integer second dimension of p.  ny > 1 if intpol(2) = 1 or
c     ny > 3 if intpol(2) = 3 is required (see ier = 2).
c
c
c ... nz
c
c     the integer third dimension of p.  nz > 1 if intpol(3) = 1 or
c     nz > 3 if intpol(3) = 3 is required (see ier = 2)
c
c ... nt
c
c     the integer fourth dimension of p.  nt > 1 if intpol(4) = 1 or
c     nt > 3 if intpol(4) = 3 is required (see ier=2)
c
c ... p
c
c     a real nx by ny by nz by nt array of given values
c
c ... mx
c
c     the integer first dimension of q.  mx > 1 is required (see ier = 1)
c
c ... my
c
c     the integer second dimension of q. my > 1 is required (see ier = 1)
c
c ... mz
c
c     the integer third dimension of q. mz > 1 is required (see ier = 1)

c ... mt
c
c     the integer fourth dimension of q. mt > 1 is required (see ier = 1)
c
c ... intpol
c
c     an integer vector of dimension 4 which sets linear or cubic
c     interpolation in each of the x,y,z,t directions as follows:
c
c        intpol(1) = 1 sets linear interpolation in the x direction
c        intpol(1) = 3 sets cubic interpolation in the x direction.
c
c        intpol(2) = 1 sets linear interpolation in the y direction
c        intpol(2) = 3 sets cubic interpolation in the y direction.
c
c        intpol(3) = 1 sets linear interpolation in the z direction
c        intpol(3) = 3 sets cubic interpolation in the z direction.
c
c        intpol(4) = 1 sets linear interpolation in the t direction
c        intpol(4) = 3 sets cubic interpolation in the t direction.
c
c     values other than 1 or 3 in intpol are not allowed (ier = 3).
c
c ... w
c
c     a real work space of length at least lw which must be provided in the
c     routine calling rgrd4u
c
c ... lw
c
c     the integer length of the work space w.
c
c          let lwx = 1 if mx-1 divides nx-1; otherwise
c          let lwx = mx if intpol(1) = 1 or
c          let lwx = 4*mx if intpol(1) = 3
c
c          let lwy = 0 if my-1 divides ny-1; otherwise
c          let lwy = my+2*mx if intpol(2) = 1 or
c          let lwy = 4*(mx+my) if intpol(2) = 3
c
c          let lwz = 0 if mz-1 divides nz-1; otherwise
c          let lwz = 2*mx*my+mz if intpol(3) = 1 or
c          let lwz = 4*(mx*my+mz) if intpol(3) = 3
c
c          let lwt = 0 if mt-1 divides nt-1; otherwise
c          let lwt = 2*mx*my*mz+mt if intpol(4) = 1 or
c          let lwt = 4*(mx*my*mz+mt) if intpol(4) = 3
c
c     then lw must be greater than or equal to lwx+lwy+lwz+lwt
c
c ... iw
c
c     an integer work space of length at least liw which must be provided in the
c     routine calling rgrd4u
c
c ... liw
c
c     the integer length of the integer work space iw.  liw must be at least
c     mx+my+mz+mt
c
c
c *** output arguments ***
c
c
c ... q
c
c     a real mx by my by mz by mt array of values which are interpolated
c     from p.
c
c ... ier
c
c     an integer error flag set as follows:
c
c     ier = 0 if no errors in input arguments are detected
c
c     ier = 1 if  min0(mx,my,mz,mt) < 2
c
c     ier = 2 if nx < 2 when intpol(1)=1 or nx < 4 when intpol(1)=3 (or)
c                ny < 2 when intpol(2)=1 or ny < 4 when intpol(2)=3 (or)
c                nz < 2 when intpol(3)=1 or nz < 4 when intpol(3)=3 (or)
c                nt < 2 when intpol(4)=1 or nt < 4 when intpol(4)=3.
c
c     ier = 3 if any of intpol(1),intpol(2),intpol(3),intpol(4)  is not
c             equal to 1 or 3.
c
c     ier = 4 if lw or liw is too small (insufficient work space)
c
c ************************************************************************
c
c     end of rgrd4u documentation, fortran code follows:
c
c ************************************************************************
c
      subroutine rgrd4u(nx,ny,nz,nt,p,mx,my,mz,mt,q,intpol,
     +                  w,lw,iw,liw,ier)
      implicit none
      integer nx,ny,nz,nt,mx,my,mz,mt,intpol(4),liw,iw(liw),lw,ier
      real p(nx,ny,nz,nt),q(mx,my,mz,mt),w(lw)
      integer inmx,jnmy,knmz,lnmt,isubx,jsuby,ksubz,lsubt
      integer mxmy,mxmymz,lwx,lwy,lwz,lwt,jy,kz,lt
      integer i2,i3,i4,i5
      integer j2,j3,j4,j5,j6,j7,j8,j9
      integer k2,k3,k4,k5,k6,k7,k8,k9
      integer l2,l3,l4,l5,l6,l7,l8,l9
c
c
c     check input arguments
c
      ier = 1
c
c     check mx,my,mz,mt
c
      if (min0(mx,my,mz,mt) .lt. 1) return
c
c     check intpol
c
      ier = 3
      if (intpol(1).ne.1 .and. intpol(1).ne.3) return
      if (intpol(2).ne.1 .and. intpol(2).ne.3) return
      if (intpol(3).ne.1 .and. intpol(3).ne.3) return
      if (intpol(4).ne.1 .and. intpol(4).ne.3) return
c
c     check nx,ny,nz,nt
c
      ier = 2
      if (intpol(1).eq.1 .and. nx.lt.2) return
      if (intpol(1).eq.3 .and. nx.lt.4) return
      if (intpol(2).eq.1 .and. ny.lt.2) return
      if (intpol(2).eq.3 .and. ny.lt.4) return
      if (intpol(3).eq.1 .and. nz.lt.2) return
      if (intpol(3).eq.3 .and. nz.lt.4) return
      if (intpol(4).eq.1 .and. nt.lt.2) return
      if (intpol(4).eq.3 .and. nt.lt.4) return
c
c     set subgrid indicators
c
      inmx = (nx-1)/(mx-1)
      jnmy = (ny-1)/(my-1)
      knmz = (nz-1)/(mz-1)
      lnmt = (nt-1)/(mt-1)
      isubx = nx - inmx*(mx-1)
      jsuby = ny - jnmy*(my-1)
      ksubz = nz - knmz*(mz-1)
      lsubt = nt - lnmt*(mt-1)
c
c     check work space length input
c
      ier = 4
      mxmy = mx*my
      mxmymz = mxmy*mz
      lwx = 1
      if (isubx.ne.1) then
	if (intpol(1).eq.1) then
	  lwx = mx
	else
	  lwx = 4*mx
	end if
      end if
      lwy = 0
      if (jsuby.ne.1) then
	if (intpol(2).eq.1) then
	  lwy = (2*mx+my)
	else
	  lwy = 4*my+4*mx
	end if
      end if
      lwz = 0
      if (ksubz.ne.1) then
	if (intpol(3).eq.1) then
	  lwz = (2*mxmy+mz)
	else
	  lwz = 4*mxmy+4*mz
	end if
      end if
      lwt = 0
      if (lsubt.ne.1) then
	if (intpol(4).eq.1) then
	  lwt = (2*mxmymz+mt)
	else
	  lwt = 4*mxmymz+4*mt
	end if
      end if

      if (lw .lt. lwx+lwy+lwz+lwt) return
      if (liw .lt. mx+my+mz+mt) return
c
c     arguments o.k.
c
      ier = 0
      jy = mx+1
      kz = mx+my+1
      lt = mx+my+mz+1

      if (intpol(4).eq.1) then
c
c     linearly interpolate in nt, set work space pointers and scales
c

	l2 = 1
	l3 = l2
	l4 = l3+mt
	l5 = l4
	l6 = l5
	l7 = l6
	l8 = l7+mxmymz
	l9 = l8+mxmymz
	call linmxu(nt,mt,iw(lt),w(l3))
	k2 = l9
	if (intpol(3).eq.1) then
c     linear in z
	  k3 = k2
	  k4 = k3+mz
	  k5 = k4
	  k6 = k5
	  k7 = k6
	  k8 = k7+mxmy
	  k9 = k8+mxmy
	  call linmxu(nz,mz,iw(kz),w(k3))
	  j2 = k9
	else
c     cubic in z
	  k3 = k2+mz
	  k4 = k3+mz
	  k5 = k4+mz
	  k6 = k5+mz
	  k7 = k6+mxmy
	  k8 = k7+mxmy
	  k9 = k8+mxmy
	  call cubnmxu(nz,mz,iw(kz),w(k2),w(k3),w(k4),w(k5))
	  j2 = k9+mxmy
	end if

	if (intpol(2) .eq. 1) then
c     linear in y
	  j3 = j2
	  j4 = j3+my
	  j5 = j4
	  j6 = j5
	  j7 = j6
	  j8 = j7+mx
	  j9 = j8+mx
	  call linmxu(ny,my,iw(jy),w(j3))
	  i2 = j9
	else
c     cubic in y
	  j3 = j2+my
	  j4 = j3+my
	  j5 = j4+my
	  j6 = j5+my
	  j7 = j6+mx
	  j8 = j7+mx
	  j9 = j8+mx
	  call cubnmxu(ny,my,iw(jy),w(j2),w(j3),w(j4),w(j5))
	  i2 = j9+mx
	end if

	if (intpol(1) .eq. 1) then
c     linear in x
	  i3 = i2
	  i4 = i3
	  i5 = i4
	  call linmxu(nx,mx,iw,w(i3))
	else
c     cubic in x
	  i3 = i2+mx
	  i4 = i3+mx
	  i5 = i4+mx
	  call cubnmxu(nx,mx,iw,w(i2),w(i3),w(i4),w(i5))
	end if
c
c     linearly interpolate in t
c
	call lint4u(nx,ny,nz,nt,p,mx,my,mz,mt,mxmy,mxmymz,q,intpol,
     +  iw(lt),w(l3),w(l7),w(l8),
     +  iw(kz),w(k2),w(k3),w(k4),w(k5),w(k6),w(k7),w(k8),w(k9),
     +  iw(jy),w(j2),w(j3),w(j4),w(j5),w(j6),w(j7),w(j8),w(j9),
     +  iw,w(i2),w(i3),w(i4),w(i5),
     +  inmx,jnmy,knmz,lnmt,isubx,jsuby,ksubz,lsubt)
	return

      else
c
c     cubically interpolate in t
c
	l2 = 1
	l3 = l2+mt
	l4 = l3+mt
	l5 = l4+mt
	l6 = l5+mt
	l7 = l6+mxmymz
	l8 = l7+mxmymz
	l9 = l8+mxmymz
	call cubnmxu(nt,mt,iw(lt),w(l2),w(l3),w(l4),w(l5))
	k2 = l9+mxmymz

	if (intpol(3).eq.1) then
c     linear in z
	  k3 = k2
	  k4 = k3+mz
	  k5 = k4
	  k6 = k5
	  k7 = k6
	  k8 = k7+mxmy
	  k9 = k8+mxmy
	  call linmxu(nz,mz,iw(kz),w(k3))
	  j2 = k9
	else
c     cubic in z
	  k3 = k2+mz
	  k4 = k3+mz
	  k5 = k4+mz
	  k6 = k5+mz
	  k7 = k6+mxmy
	  k8 = k7+mxmy
	  k9 = k8+mxmy
	  call cubnmxu(nz,mz,iw(kz),w(k2),w(k3),w(k4),w(k5))
	  j2 = k9+mxmy
	end if

	if (intpol(2) .eq. 1) then
	  j3 = j2
	  j4 = j3+my
	  j5 = j4
	  j6 = j5
	  j7 = j6
	  j8 = j7+mx
	  j9 = j8+mx
	  call linmxu(ny,my,iw(jy),w(j3))
	  i2 = j9
	else
	  j3 = j2+my
	  j4 = j3+my
	  j5 = j4+my
	  j6 = j5+my
	  j7 = j6+mx
	  j8 = j7+mx
	  j9 = j8+mx
	  call cubnmxu(ny,my,iw(jy),w(j2),w(j3),w(j4),w(j5))
	  i2 = j9+mx
	end if
c
c     set work space portion and indices which depend on x interpolation
c
	if (intpol(1) .eq. 1) then
	  i3 = i2
	  i4 = i3
	  i5 = i4
	  call linmxu(nx,mx,iw,w(i3))
	else
	  i3 = i2+mx
	  i4 = i3+mx
	  i5 = i4+mx
	  call cubnmxu(nx,mx,iw,w(i2),w(i3),w(i4),w(i5))
	end if
c
c     cubically interpolate in t
c
	call cubt4u(nx,ny,nz,nt,p,mx,my,mz,mt,mxmy,mxmymz,q,intpol,
     +  iw(lt),w(l2),w(l3),w(l4),w(l5),w(l6),w(l7),w(l8),w(l9),
     +  iw(kz),w(k2),w(k3),w(k4),w(k5),w(k6),w(k7),w(k8),w(k9),
     +  iw(jy),w(j2),w(j3),w(j4),w(j5),w(j6),w(j7),w(j8),w(j9),
     +  iw,w(i2),w(i3),w(i4),w(i5),
     +  inmx,jnmy,knmz,lnmt,isubx,jsuby,ksubz,lsubt)
	return
      end if
      end

      subroutine lint4u(nx,ny,nz,nt,p,mx,my,mz,mt,mxmy,mxmymz,q,intpol,
     +lt,dt,pt,ptp,kz,dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,
     +jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     +inmx,jnmy,knmz,lnmt,isubx,jsuby,ksubz,lsubt)
c
c     linearly interpolate in t direction
c
      implicit none
      integer nx,ny,nz,nt,mx,my,mz,mt
      integer mxmy,mxmymz
      real p(nx,ny,nz,nt),q(mxmymz,mt)
      integer inmx,jnmy,knmz,lnmt,isubx,jsuby,ksubz,lsubt
      real dt(mt),pt(mxmymz),ptp(mxmymz)
      real dzm(mz),dz(mz),dzp(mz),dzpp(mz)
      real pkm(mxmy),pk(mxmy),pkp(mxmy),pkpp(mxmy)
      real dym(my),dy(my),dyp(my),dypp(my)
      real pjm(mx),pj(mx),pjp(mx),pjpp(mx)
      real dxm(mx),dx(mx),dxp(mx),dxpp(mx)
      integer lt(mt),kz(mz),jy(my),ix(mx),intpol(4)
      integer l,ll,lsave,iijjkk
      if (intpol(3) .eq. 1) then
c
c     linear in z
c
      if (lsubt .eq. 1) then
c
c     mt grid is subset of nt grid
c
       do ll=1,mt
	l = lnmt*(ll-1)+1
	call lint3u(nx,ny,nz,p(1,1,1,l),mx,my,mxmy,mz,q(1,ll),intpol,kz,
     +  dz,pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     +  inmx,jnmy,knmz,isubx,jsuby,ksubz)
       end do
       return
       end if

       lsave = -1
       do ll=1,mt
	l = lt(ll)
	if (l.eq.lsave) then
c
c     l pointer has not moved since last pass (no updates or interpolation)
c
	else if (l.eq.lsave+1) then
c
c     update l and interpolate l+1
c
	 do iijjkk=1,mxmymz
	  pt(iijjkk) = ptp(iijjkk)
	 end do
	 call lint3u(nx,ny,nz,p(1,1,1,l+1),mx,my,mxmy,mz,ptp,intpol,kz,
     +   dz,pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp
     +   ,inmx,jnmy,knmz,isubx,jsuby,ksubz)
	else
c
c     interpolate l,l+1 in pt,ptp on xx,yy,zz mesh
c
	 call lint3u(nx,ny,nz,p(1,1,1,l),mx,my,mxmy,mz,pt,intpol,kz,dz,
     +   pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     +   inmx,jnmy,knmz,isubx,jsuby,ksubz)
	 call lint3u(nx,ny,nz,p(1,1,1,l+1),mx,my,mxmy,mz,ptp,intpol,kz,
     +   dz,pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp
     +   ,inmx,jnmy,knmz,isubx,jsuby,ksubz)
	end if
c
c     save l pointer for next pass
c
	lsave = l
c
c     linearly interpolate q(ii,jj,,kk,ll) from pt,ptp in t direction
c
	do iijjkk=1,mxmymz
	 q(iijjkk,ll) = pt(iijjkk)+dt(ll)*(ptp(iijjkk)-pt(iijjkk))
	end do
       end do
       return

      else
c
c     cubic in z
c
       if (lsubt .eq. 1) then
c
c     mt grid is subset of nt grid
c
	do ll=1,mt
	 l = lnmt*(ll-1)+1
	 call cubt3u(nx,ny,nz,p(1,1,1,l),mx,my,mxmy,mz,q(1,ll),intpol,
     +   kz,dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,
     +   pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     +   inmx,jnmy,knmz,isubx,jsuby,ksubz)
	end do
	return
       end if
       lsave = -1
       do ll=1,mt
       l = lt(ll)
       if (l.eq.lsave) then
c
c     l pointer has not moved since last pass (no updates or interpolation)
c
       else if (l.eq.lsave+1) then
c
c     update l and interpolate l+1
c
       do iijjkk=1,mxmymz
	pt(iijjkk) = ptp(iijjkk)
       end do
       call cubt3u(nx,ny,nt,p(1,1,1,l+1),mx,my,mxmy,mz,ptp,intpol,
     + kz,dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,
     + jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     + inmx,jnmy,knmz,isubx,jsuby,ksubz)
       else
c
c     interpolate l,l+1 in pt,ptp on xx,yy,zz mesh
c
       call cubt3u(nx,ny,nt,p(1,1,1,l),mx,my,mxmy,mz,pt,intpol,
     + kz,dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,
     + jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     + inmx,jnmy,knmz,isubx,jsuby,ksubz)
       call cubt3u(nx,ny,nt,p(1,1,1,l+1),mx,my,mxmy,mz,ptp,intpol,
     + kz,dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,
     + jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     + inmx,jnmy,knmz,isubx,jsuby,ksubz)
       end if
c
c     save l pointer for next pass
c
       lsave = l
c
c     linearly interpolate q(ii,jj,kk,ll) from pt,ptp in t direction
c
       do iijjkk=1,mxmymz
	q(iijjkk,ll) = pt(iijjkk)+dt(ll)*(ptp(iijjkk)-pt(iijjkk))
       end do

      end do
      return

      end if
      end

      subroutine cubt4u(nx,ny,nz,nt,p,mx,my,mz,mt,mxmy,mxmymz,q,intpol,
     +lt,dtm,dt,dtp,dtpp,ptm,pt,ptp,ptpp,
     +kz,dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,
     +jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,
     +ix,dxm,dx,dxp,dxpp,
     +inmx,jnmy,knmz,lnmt,isubx,jsuby,ksubz,lsubt)
c
c
c     cubically interpolate in t
c
      implicit none
      integer nx,ny,nz,nt,mx,my,mz,mt
      integer inmx,jnmy,knmz,lnmt,isubx,jsuby,ksubz,lsubt
      integer mxmy,mxmymz
      real p(nx,ny,nz,nt),q(mxmymz,mt)
      real ptm(mxmymz),pt(mxmymz),ptp(mxmymz),ptpp(mxmymz)
      real dtm(mt),dt(mt),dtp(mt),dtpp(mt)
      real dzm(mz),dz(mz),dzp(mz),dzpp(mz)
      real pkm(mxmy),pk(mxmy),pkp(mxmy),pkpp(mxmy)
      real dym(my),dy(my),dyp(my),dypp(my)
      real pjm(mx),pj(mx),pjp(mx),pjpp(mx)
      real dxm(mx),dx(mx),dxp(mx),dxpp(mx)
      integer lt(mt),kz(mz),jy(my),ix(mx),intpol(4)
      integer l,ll,iijjkk,lsave
      if (intpol(3) .eq. 1) then
c
c     linear in z
c
      if (lsubt .eq. 1) then
c
c     mt grid is subset of nt grid
c
       do ll=1,mt
	l = lnmt*(ll-1)+1
	call lint3u(nx,ny,nz,p(1,1,1,l),mx,my,mxmy,mz,q(1,ll),intpol,kz,
     +  dz,pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     +  inmx,jnmy,knmz,isubx,jsuby,ksubz)
       end do
       return
      end if
      lsave = -3
      do ll=1,mt
       l = lt(ll)
       if (l.eq.lsave) then
c
c     l pointer has not moved since last pass (no updates or interpolation)
c
       else if (l.eq.lsave+1) then
c
c     update l-1,l,l+1 and interpolate l+2
c
	do iijjkk=1,mxmymz
	 ptm(iijjkk) = pt(iijjkk)
	 pt(iijjkk) = ptp(iijjkk)
	 ptp(iijjkk) = ptpp(iijjkk)
	end do
	call lint3u(nx,ny,nz,p(1,1,1,l+2),mx,my,mxmy,mz,ptpp,intpol,kz,
     +  dz,pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     +  inmx,jnmy,knmz,isubx,jsuby,ksubz)
       else if (l.eq.lsave+2) then
c
c     update l-1,l and interpolate l+1,l+2
c
	do iijjkk=1,mxmymz
	 ptm(iijjkk) = ptp(iijjkk)
	 pt(iijjkk) = ptpp(iijjkk)
	end do
	call lint3u(nx,ny,nz,p(1,1,1,l+1),mx,my,mxmy,mz,ptp,intpol,kz,
     +  dz,pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     +  inmx,jnmy,knmz,isubx,jsuby,ksubz)
	call lint3u(nx,ny,nz,p(1,1,1,l+2),mx,my,mxmy,mz,ptpp,intpol,kz,
     +  dz,pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     +  inmx,jnmy,knmz,isubx,jsuby,ksubz)
       else if (l.eq.lsave+3) then
c
c     update l-1 and interpolate l,l+1,l+2
c
	do iijjkk=1,mxmymz
	 ptm(iijjkk) = ptpp(iijjkk)
	end do
	call lint3u(nx,ny,nz,p(1,1,1,l),mx,my,mxmy,mz,pt,intpol,kz,dz,
     +  pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     +  inmx,jnmy,knmz,isubx,jsuby,ksubz)
	call lint3u(nx,ny,nz,p(1,1,1,l+1),mx,my,mxmy,mz,ptp,intpol,kz,
     +  dz,pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     +  inmx,jnmy,knmz,isubx,jsuby,ksubz)
	call lint3u(nx,ny,nz,p(1,1,1,l+2),mx,my,mxmy,mz,ptpp,intpol,kz,
     +  dz,pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     +  inmx,jnmy,knmz,isubx,jsuby,ksubz)
       else
c
c     interpolate all four l-1,l,l+1,l+2
c
	call lint3u(nx,ny,nz,p(1,1,1,l-1),mx,my,mxmy,mz,ptm,intpol,kz,
     +  dz,pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     +  inmx,jnmy,knmz,isubx,jsuby,ksubz)
	call lint3u(nx,ny,nz,p(1,1,1,l),mx,my,mxmy,mz,pt,intpol,kz,
     +  dz,pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     +  inmx,jnmy,knmz,isubx,jsuby,ksubz)
	call lint3u(nx,ny,nz,p(1,1,1,l+1),mx,my,mxmy,mz,ptp,intpol,kz,
     +  dz,pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     +  inmx,jnmy,knmz,isubx,jsuby,ksubz)
	call lint3u(nx,ny,nz,p(1,1,1,l+2),mx,my,mxmy,mz,ptpp,intpol,kz,
     +  dz,pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     +  inmx,jnmy,knmz,isubx,jsuby,ksubz)
       end if
c
c     save l pointer for next pass
c
       lsave = l
c
c     cubically interpolate q(ii,jj,kk,ll) from ptm,pt,ptp,ptpp in t direction
c
       do iijjkk=1,mxmymz
	q(iijjkk,ll) = dtm(ll)*ptm(iijjkk) + dt(ll)*pt(iijjkk) +
     +                 dtp(ll)*ptp(iijjkk) + dtpp(ll)*ptpp(iijjkk)
       end do
      end do
      return

      else
c
c     cubic in z
c
      if (lsubt .eq. 1) then
c
c     mt grid is subset of nt grid
c
       do ll=1,mt
	l = lnmt*(ll-1)+1
	call cubt3u(nx,ny,nz,p(1,1,1,l),mx,my,mxmy,mz,q(1,ll),intpol,
     +  kz,dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,
     +  pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,
     +  inmx,jnmy,knmz,isubx,jsuby,ksubz)
       end do
       return
      end if
      lsave = -3
      do ll=1,mt
       l = lt(ll)
       if (l.eq.lsave) then
c
c     l pointer has not moved since last pass (no updates or interpolation)
c
       else if (l.eq.lsave+1) then
c
c     update l-1,l,l+1 and interpolate l+2
c
	do iijjkk=1,mxmymz
	 ptm(iijjkk) = pt(iijjkk)
	 pt(iijjkk) = ptp(iijjkk)
	 ptp(iijjkk) = ptpp(iijjkk)
	end do
	call cubt3u(nx,ny,nz,p(1,1,1,l+2),mx,my,mxmy,mz,ptpp,intpol,kz,
     +dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp
     +,ix,dxm,dx,dxp,dxpp,
     +inmx,jnmy,knmz,isubx,jsuby,ksubz)
       else if (l.eq.lsave+2) then
c
c     update l-1,l and interpolate l+1,l+2
c
	do iijjkk=1,mxmymz
	 ptm(iijjkk) = ptp(iijjkk)
	 pt(iijjkk) = ptpp(iijjkk)
	end do
	call cubt3u(nx,ny,nz,p(1,1,1,l+1),mx,my,mxmy,mz,ptp,intpol,kz,
     +dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp
     +,ix,dxm,dx,dxp,dxpp,
     +inmx,jnmy,knmz,isubx,jsuby,ksubz)
	call cubt3u(nx,ny,nz,p(1,1,1,l+2),mx,my,mxmy,mz,ptpp,intpol,kz,
     +dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp
     +,ix,dxm,dx,dxp,dxpp,
     +inmx,jnmy,knmz,isubx,jsuby,ksubz)
       else if (l.eq.lsave+3) then
c
c     update l-1 and interpolate l,l+1,l+2
c
	do iijjkk=1,mxmymz
	 ptm(iijjkk) = ptpp(iijjkk)
	end do
	call cubt3u(nx,ny,nz,p(1,1,1,l),mx,my,mxmy,mz,pt,intpol,kz,
     +dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp
     +,ix,dxm,dx,dxp,dxpp,
     +inmx,jnmy,knmz,isubx,jsuby,ksubz)
	call cubt3u(nx,ny,nz,p(1,1,1,l+1),mx,my,mxmy,mz,ptp,intpol,kz,
     +dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp
     +,ix,dxm,dx,dxp,dxpp,
     +inmx,jnmy,knmz,isubx,jsuby,ksubz)
	call cubt3u(nx,ny,nz,p(1,1,1,l+2),mx,my,mxmy,mz,ptpp,intpol,kz,
     +dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp
     +,ix,dxm,dx,dxp,dxpp,
     +inmx,jnmy,knmz,isubx,jsuby,ksubz)
       else
c
c     interpolate all four l-1,l,l+1,l+2
c
	call cubt3u(nx,ny,nz,p(1,1,1,l-1),mx,my,mxmy,mz,ptm,intpol,kz,
     +dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp
     +,ix,dxm,dx,dxp,dxpp,
     +inmx,jnmy,knmz,isubx,jsuby,ksubz)
	call cubt3u(nx,ny,nz,p(1,1,1,l),mx,my,mxmy,mz,pt,intpol,kz,
     +dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp
     +,ix,dxm,dx,dxp,dxpp,
     +inmx,jnmy,knmz,isubx,jsuby,ksubz)
	call cubt3u(nx,ny,nz,p(1,1,1,l+1),mx,my,mxmy,mz,ptp,intpol,kz,
     +dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp
     +,ix,dxm,dx,dxp,dxpp,
     +inmx,jnmy,knmz,isubx,jsuby,ksubz)
	call cubt3u(nx,ny,nz,p(1,1,1,l+2),mx,my,mxmy,mz,ptpp,intpol,kz,
     +dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp
     +,ix,dxm,dx,dxp,dxpp,
     +inmx,jnmy,knmz,isubx,jsuby,ksubz)
       end if
c
c     save l pointer for next pass
c
       lsave = l
c
c     cubically interpolate q(ii,jj,kk,ll) from ptm,pt,ptp,ptpp in t direction
c
       do iijjkk=1,mxmymz
	q(iijjkk,ll) = dtm(ll)*ptm(iijjkk) + dt(ll)*pt(iijjkk) +
     +                 dtp(ll)*ptp(iijjkk) + dtpp(ll)*ptpp(iijjkk)
       end do
      end do
      return
      end if

      end