!=======================================================================
! This is part of the 2DECOMP&FFT library
!
! 2DECOMP&FFT is a software framework for general-purpose 2D (pencil)
! decomposition. It also implements a highly scalable distributed
! three-dimensional Fast Fourier Transform (FFT).
!
! Copyright (C) 2009-2012 Ning Li, the Numerical Algorithms Group (NAG)
!
!=======================================================================

! This file contains 3D c2c/r2c/c2r transform subroutines which are
! identical for several FFT engines

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! 3D FFT - complex to complex
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine fft_3d_c2c(in, out, isign)

    implicit none

    complex(mytype), dimension(:,:,:), intent(INOUT) :: in
    complex(mytype), dimension(:,:,:), intent(OUT) :: out
    integer, intent(IN) :: isign

#ifndef OVERWRITE
    complex(mytype), allocatable, dimension(:,:,:) :: wk1
#endif

    if (format==PHYSICAL_IN_X .AND. isign==DECOMP_2D_FFT_FORWARD .OR.  &
         format==PHYSICAL_IN_Z .AND. isign==DECOMP_2D_FFT_BACKWARD) then

       ! ===== 1D FFTs in X =====
#ifdef OVERWRITE
       call c2c_1m_x(in,isign,ph)
#else
       allocate (wk1(ph%xsz(1),ph%xsz(2),ph%xsz(3)))
       wk1 = in
       call c2c_1m_x(wk1,isign,ph)
#endif

       ! ===== Swap X --> Y; 1D FFTs in Y =====

       if (dims(1)>1) then
#ifdef OVERWRITE
          call transpose_x_to_y(in,wk2_c2c,ph)
#else
          call transpose_x_to_y(wk1,wk2_c2c,ph)
#endif
          call c2c_1m_y(wk2_c2c,isign,ph)
       else
#ifdef OVERWRITE
          call c2c_1m_y(in,isign,ph)
#else
          call c2c_1m_y(wk1,isign,ph)
#endif
       end if

       ! ===== Swap Y --> Z; 1D FFTs in Z =====
       if (dims(1)>1) then
          call transpose_y_to_z(wk2_c2c,out,ph)
       else
#ifdef OVERWRITE
          call transpose_y_to_z(in,out,ph)
#else
          call transpose_y_to_z(wk1,out,ph)
#endif
       end if
       call c2c_1m_z(out,isign,ph)

    else if (format==PHYSICAL_IN_X .AND. isign==DECOMP_2D_FFT_BACKWARD &
         .OR. &
         format==PHYSICAL_IN_Z .AND. isign==DECOMP_2D_FFT_FORWARD) then

       ! ===== 1D FFTs in Z =====
#ifdef OVERWRITE
       call c2c_1m_z(in,isign,ph)
#else
       allocate (wk1(ph%zsz(1),ph%zsz(2),ph%zsz(3)))
       wk1 = in
       call c2c_1m_z(wk1,isign,ph)
#endif

       ! ===== Swap Z --> Y; 1D FFTs in Y =====
       if (dims(1)>1) then
#ifdef OVERWRITE
          call transpose_z_to_y(in,wk2_c2c,ph)
#else
          call transpose_z_to_y(wk1,wk2_c2c,ph)
#endif
          call c2c_1m_y(wk2_c2c,isign,ph)
       else  ! out==wk2_c2c if 1D decomposition
#ifdef OVERWRITE
          call transpose_z_to_y(in,out,ph)
#else
          call transpose_z_to_y(wk1,out,ph)
#endif
          call c2c_1m_y(out,isign,ph)
       end if

       ! ===== Swap Y --> X; 1D FFTs in X =====
       if (dims(1)>1) then
          call transpose_y_to_x(wk2_c2c,out,ph)
       end if
       call c2c_1m_x(out,isign,ph)

    end if

    return
  end subroutine fft_3d_c2c

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! 3D forward FFT - real to complex
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine fft_3d_r2c(in_r, out_c)

    implicit none

    real(mytype), dimension(:,:,:), intent(IN) :: in_r
    complex(mytype), dimension(:,:,:), intent(OUT) :: out_c

    if (format==PHYSICAL_IN_X) then

       ! ===== 1D FFTs in X =====
       call r2c_1m_x(in_r,wk13)

       ! ===== Swap X --> Y; 1D FFTs in Y =====
       if (dims(1)>1) then
          call transpose_x_to_y(wk13,wk2_r2c,sp)
          call c2c_1m_y(wk2_r2c,-1,sp)
       else
          call c2c_1m_y(wk13,-1,sp)
       end if

       ! ===== Swap Y --> Z; 1D FFTs in Z =====
       if (dims(1)>1) then
          call transpose_y_to_z(wk2_r2c,out_c,sp)
       else
          call transpose_y_to_z(wk13,out_c,sp)
       end if
       call c2c_1m_z(out_c,-1,sp)

    else if (format==PHYSICAL_IN_Z) then

       ! ===== 1D FFTs in Z =====
       call r2c_1m_z(in_r,wk13)

       ! ===== Swap Z --> Y; 1D FFTs in Y =====
       if (dims(1)>1) then
          call transpose_z_to_y(wk13,wk2_r2c,sp)
          call c2c_1m_y(wk2_r2c,-1,sp)
       else  ! out_c==wk2_r2c if 1D decomposition
          call transpose_z_to_y(wk13,out_c,sp)
          call c2c_1m_y(out_c,-1,sp)
       end if

       ! ===== Swap Y --> X; 1D FFTs in X =====
       if (dims(1)>1) then
          call transpose_y_to_x(wk2_r2c,out_c,sp)
       end if
       call c2c_1m_x(out_c,-1,sp)

    end if

    return
  end subroutine fft_3d_r2c

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! 3D inverse FFT - complex to real
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine fft_3d_c2r(in_c, out_r)

    implicit none

    complex(mytype), dimension(:,:,:), intent(INOUT) :: in_c
    real(mytype), dimension(:,:,:), intent(OUT) :: out_r

#ifndef OVERWRITE
    complex(mytype), allocatable, dimension(:,:,:) :: wk1
#endif

    if (format==PHYSICAL_IN_X) then

       ! ===== 1D FFTs in Z =====
#ifdef OVERWRITE
       call c2c_1m_z(in_c,1,sp)
#else
       allocate(wk1(sp%zsz(1),sp%zsz(2),sp%zsz(3)))
       wk1 = in_c
       call c2c_1m_z(wk1,1,sp)
#endif

       ! ===== Swap Z --> Y; 1D FFTs in Y =====
#ifdef OVERWRITE
       call transpose_z_to_y(in_c,wk2_r2c,sp)
#else
       call transpose_z_to_y(wk1,wk2_r2c,sp)
#endif
       call c2c_1m_y(wk2_r2c,1,sp)

       ! ===== Swap Y --> X; 1D FFTs in X =====
       if (dims(1)>1) then
          call transpose_y_to_x(wk2_r2c,wk13,sp)
          call c2r_1m_x(wk13,out_r)
       else
          call c2r_1m_x(wk2_r2c,out_r)
       end if

    else if (format==PHYSICAL_IN_Z) then

       ! ===== 1D FFTs in X =====
#ifdef OVERWRITE
       call c2c_1m_x(in_c,1,sp)
#else
       allocate(wk1(sp%xsz(1),sp%xsz(2),sp%xsz(3)))
       wk1 = in_c
       call c2c_1m_x(wk1,1,sp)
#endif

       ! ===== Swap X --> Y; 1D FFTs in Y =====
       if (dims(1)>1) then
#ifdef OVERWRITE
          call transpose_x_to_y(in_c,wk2_r2c,sp)
#else
          call transpose_x_to_y(wk1,wk2_r2c,sp)
#endif
          call c2c_1m_y(wk2_r2c,1,sp)
       else  ! in_c==wk2_r2c if 1D decomposition
#ifdef OVERWRITE
          call c2c_1m_y(in_c,1,sp)
#else
          call c2c_1m_y(wk1,1,sp)
#endif
       end if

       ! ===== Swap Y --> Z; 1D FFTs in Z =====
       if (dims(1)>1) then
          call transpose_y_to_z(wk2_r2c,wk13,sp)
       else
#ifdef OVERWRITE
          call transpose_y_to_z(in_c,wk13,sp)
#else
          call transpose_y_to_z(wk1,wk13,sp)
#endif
       end if
       call c2r_1m_z(wk13,out_r)

    end if

    return
  end subroutine fft_3d_c2r


      SUBROUTINE MB03LD( COMPQ, ORTH, N, A, LDA, DE, LDDE, B, LDB, FG,
     $                   LDFG, NEIG, Q, LDQ, ALPHAR, ALPHAI, BETA,
     $                   IWORK, LIWORK, DWORK, LDWORK, BWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the relevant eigenvalues of a real N-by-N skew-
C     Hamiltonian/Hamiltonian pencil aS - bH, with
C
C           (  A  D  )         (  B  F  )
C       S = (        ) and H = (        ),                           (1)
C           (  E  A' )         (  G -B' )
C
C     where the notation M' denotes the transpose of the matrix M.
C     Optionally, if COMPQ = 'C', an orthogonal basis of the right
C     deflating subspace of aS - bH corresponding to the eigenvalues
C     with strictly negative real part is computed.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     COMPQ   CHARACTER*1
C             Specifies whether to compute the right deflating subspace
C             corresponding to the eigenvalues of aS - bH with strictly
C             negative real part.
C             = 'N':  do not compute the deflating subspace;
C             = 'C':  compute the deflating subspace and store it in the
C                     leading subarray of Q.
C
C     ORTH    CHARACTER*1
C             If COMPQ = 'C', specifies the technique for computing an
C             orthogonal basis of the deflating subspace, as follows:
C             = 'P':  QR factorization with column pivoting;
C             = 'S':  singular value decomposition.
C             If COMPQ = 'N', the ORTH value is not used.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the pencil aS - bH.  N >= 0, even.
C
C     A       (input/output) DOUBLE PRECISION array, dimension
C                            (LDA, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the matrix A.
C             On exit, if COMPQ = 'C', the leading N/2-by-N/2 part of
C             this array contains the upper triangular matrix Aout
C             (see METHOD); otherwise, it contains the upper triangular
C             matrix A obtained just before the application of the
C             periodic QZ algorithm (see SLICOT Library routine MB04BD).
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1, N/2).
C
C     DE      (input/output) DOUBLE PRECISION array, dimension
C                            (LDDE, N/2+1)
C             On entry, the leading N/2-by-N/2 lower triangular part of
C             this array must contain the lower triangular part of the
C             skew-symmetric matrix E, and the N/2-by-N/2 upper
C             triangular part of the submatrix in the columns 2 to N/2+1
C             of this array must contain the upper triangular part of the
C             skew-symmetric matrix D.
C             The entries on the diagonal and the first superdiagonal of
C             this array need not be set, but are assumed to be zero.
C             On exit, if COMPQ = 'C', the leading N/2-by-N/2 lower
C             triangular part and the first superdiagonal contain the
C             transpose of the upper quasi-triangular matrix C2out (see
C             METHOD), and the (N/2-1)-by-(N/2-1) upper triangular part
C             of the submatrix in the columns 3 to N/2+1 of this array
C             contains the strictly upper triangular part of the
C             skew-symmetric matrix Dout (see METHOD), without the main
C             diagonal, which is zero.
C             On exit, if COMPQ = 'N', the leading N/2-by-N/2 lower
C             triangular part and the first superdiagonal contain the
C             transpose of the upper Hessenberg matrix C2, and the
C             (N/2-1)-by-(N/2-1) upper triangular part of the submatrix
C             in the columns 3 to N/2+1 of this array contains the
C             strictly upper triangular part of the skew-symmetric
C             matrix D (without the main diagonal) just before the
C             application of the periodic QZ algorithm.
C
C     LDDE    INTEGER
C             The leading dimension of the array DE.
C             LDDE >= MAX(1, N/2).
C
C     B       (input/output) DOUBLE PRECISION array, dimension
C                            (LDB, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the matrix B.
C             On exit, if COMPQ = 'C', the leading N/2-by-N/2 part of
C             this array contains the upper triangular matrix C1out
C             (see METHOD); otherwise, it contains the upper triangular
C             matrix C1 obtained just before the application of the
C             periodic QZ algorithm.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1, N/2).
C
C     FG      (input/output) DOUBLE PRECISION array, dimension
C                            (LDFG, N/2+1)
C             On entry, the leading N/2-by-N/2 lower triangular part of
C             this array must contain the lower triangular part of the
C             symmetric matrix G, and the N/2-by-N/2 upper triangular
C             part of the submatrix in the columns 2 to N/2+1 of this
C             array must contain the upper triangular part of the
C             symmetric matrix F.
C             On exit, if COMPQ = 'C', the leading N/2-by-N/2 part of
C             the submatrix in the columns 2 to N/2+1 of this array
C             contains the matrix Vout (see METHOD); otherwise, it
C             contains the matrix V obtained just before the application
C             of the periodic QZ algorithm.
C
C     LDFG    INTEGER
C             The leading dimension of the array FG.
C             LDFG >= MAX(1, N/2).
C
C     NEIG    (output) INTEGER
C             If COMPQ = 'C', the number of eigenvalues in aS - bH with
C             strictly negative real part.
C
C     Q       (output) DOUBLE PRECISION array, dimension (LDQ, 2*N)
C             On exit, if COMPQ = 'C', the leading N-by-NEIG part of
C             this array contains an orthogonal basis of the right
C             deflating subspace corresponding to the eigenvalues of
C             aA - bB with strictly negative real part. The remaining
C             part of this array is used as workspace.
C             If COMPQ = 'N', this array is not referenced.
C
C     LDQ     INTEGER
C             The leading dimension of the array Q.
C             LDQ >= 1,           if COMPQ = 'N';
C             LDQ >= MAX(1, 2*N), if COMPQ = 'C'.
C
C     ALPHAR  (output) DOUBLE PRECISION array, dimension (N/2)
C             The real parts of each scalar alpha defining an eigenvalue
C             of the pencil aS - bH.
C
C     ALPHAI  (output) DOUBLE PRECISION array, dimension (N/2)
C             The imaginary parts of each scalar alpha defining an
C             eigenvalue of the pencil aS - bH.
C             If ALPHAI(j) is zero, then the j-th eigenvalue is real.
C
C     BETA    (output) DOUBLE PRECISION array, dimension (N/2)
C             The scalars beta that define the eigenvalues of the pencil
C             aS - bH.
C             Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
C             beta = BETA(j) represent the j-th eigenvalue of the pencil
C             aS - bH, in the form lambda = alpha/beta. Since lambda may
C             overflow, the ratios should not, in general, be computed.
C             Due to the skew-Hamiltonian/Hamiltonian structure of the
C             pencil, for every eigenvalue lambda, -lambda is also an
C             eigenvalue, and thus it has only to be saved once in
C             ALPHAR, ALPHAI and BETA.
C             Specifically, only eigenvalues with imaginary parts
C             greater than or equal to zero are stored; their conjugate
C             eigenvalues are not stored. If imaginary parts are zero
C             (i.e., for real eigenvalues), only positive eigenvalues
C             are stored. The remaining eigenvalues have opposite signs.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (LIWORK)
C             On exit, if INFO = -19, IWORK(1) returns the minimum value
C             of LIWORK.
C
C     LIWORK  INTEGER
C             The dimension of the array IWORK.  LIWORK = 1, if N = 0,
C             LIWORK >= MAX( N + 12, 2*N + 3 ),     if COMPQ = 'N',
C             LIWORK >= MAX( 32, 2*N + 3 ),         if COMPQ = 'C'.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK.
C             On exit, if INFO = -21, DWORK(1) returns the minimum value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.  LDWORK = 1, if N = 0,
C             LDWORK >= 3*(N/2)**2 + N**2 + MAX( L, 36 ),
C                                                        if COMPQ = 'N',
C             where     L = 4*N + 4, if N/2 is even, and
C                       L = 4*N    , if N/2 is odd;
C             LDWORK >= 8*N**2 + MAX( 8*N + 32, 272 ),   if COMPQ = 'C'.
C             For good performance LDWORK should be generally larger.
C
C             If LDWORK = -1  a workspace query is assumed; the
C             routine only calculates the optimal size of the DWORK
C             array, returns this value as the first entry of the DWORK
C             array, and no error message is issued by XERBLA.
C
C     BWORK   LOGICAL array, dimension (N/2)
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0: succesful exit;
C             < 0: if INFO = -i, the i-th argument had an illegal value;
C             = 1: periodic QZ iteration failed in the SLICOT Library
C                  routines MB04BD or MB04HD (QZ iteration did not
C                  converge or computation of the shifts failed);
C             = 2: standard QZ iteration failed in the SLICOT Library
C                  routines MB04HD or MB03DD (called by MB03JD);
C             = 3: a numerically singular matrix was found in the SLICOT
C                  Library routine MB03HD (called by MB03JD);
C             = 4: the singular value decomposition failed in the LAPACK
C                  routine DGESVD (for ORTH = 'S');
C             = 5: some eigenvalues might be inaccurate. This is a
C                  warning.
C
C     METHOD
C
C     First, the decompositions of S and H are computed via orthogonal
C     transformations Q1 and Q2 as follows:
C
C                       (  Aout  Dout  )
C       Q1' S J Q1 J' = (              ),
C                       (   0    Aout' )
C
C                       (  Bout  Fout  )
C       J' Q2' J S Q2 = (              ) =: T,                       (2)
C                       (   0    Bout' )
C
C                  (  C1out  Vout  )            (  0  I  )
C       Q1' H Q2 = (               ), where J = (        ),
C                  (  0     C2out' )            ( -I  0  )
C
C     and Aout, Bout, C1out are upper triangular, C2out is upper quasi-
C     triangular and Dout and Fout are skew-symmetric.
C
C     Then, orthogonal matrices Q3 and Q4 are found, for the extended
C     matrices
C
C            (  Aout   0  )          (    0   C1out )
C       Se = (            ) and He = (              ),
C            (   0   Bout )          ( -C2out   0   )
C
C     such that S11 := Q4' Se Q3 is upper triangular and
C     H11 := Q4' He Q3 is upper quasi-triangular. The following matrices
C     are computed:
C
C                  (  Dout   0  )                   (   0   Vout )
C       S12 := Q4' (            ) Q4 and H12 := Q4' (            ) Q4.
C                  (   0   Fout )                   ( Vout'   0  )
C
C     Then, an orthogonal matrix Q is found such that the eigenvalues
C     with strictly negative real parts of the pencil
C
C         (  S11  S12  )     (  H11  H12  )
C       a (            ) - b (            )
C         (   0   S11' )     (   0  -H11' )
C
C     are moved to the top of this pencil.
C
C     Finally, an orthogonal basis of the right deflating subspace
C     corresponding to the eigenvalues with strictly negative real part
C     is computed. See also page 12 in [1] for more details.
C
C     REFERENCES
C
C     [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H.
C         Numerical Solution of Real Skew-Hamiltonian/Hamiltonian
C         Eigenproblems.
C         Tech. Rep., Technical University Chemnitz, Germany,
C         Nov. 2007.
C
C     NUMERICAL ASPECTS
C                                                               3
C     The algorithm is numerically backward stable and needs O(N )
C     floating point operations.
C
C     FURTHER COMMENTS
C
C     This routine does not perform any scaling of the matrices. Scaling
C     might sometimes be useful, and it should be done externally.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     Oct. 2010.
C
C     REVISIONS
C
C     V. Sima, Nov. 2010, Dec. 2010, Mar. 2011, Aug. 2011, Nov. 2011,
C     Oct. 2012, July 2013, July 2014, Jan. 2017, May 2020.
C     M. Voigt, Jan. 2012.
C
C     KEYWORDS
C
C     Deflating subspace, embedded pencil, skew-Hamiltonian/Hamiltonian
C     pencil, structured Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
C
C     .. Scalar Arguments ..
      CHARACTER          COMPQ, ORTH
      INTEGER            INFO, LDA, LDB, LDDE, LDFG, LDQ, LDWORK,
     $                   LIWORK, N, NEIG
C
C     .. Array Arguments ..
      LOGICAL            BWORK( * )
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
     $                   B( LDB, * ), BETA( * ), DE( LDDE, * ),
     $                   DWORK( * ), FG( LDFG, * ), Q( LDQ, * )
C
C     .. Local Scalars ..
      LOGICAL            LINIQ, LQUERY, QR, QRP, SVD
      CHARACTER*14       CMPQ
      INTEGER            IB, IC2, IFO, IH11, IH12, IQ1, IQ2, IQ3, IQ4,
     $                   IRT, IS11, IS12, IW, IWRK, J, M, MINDW, MINIW,
     $                   MM, N2, NM, NMM, NN, OPTDW
C
C     .. Local Arrays ..
      DOUBLE PRECISION   DUM( 4 )
C
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C
C     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DGEMM, DGEQP3, DGEQRF, DGESVD,
     $                   DLACPY, DORGQR, DSCAL, DSYR2K, DTRMM, MA02AD,
     $                   MB01KD, MB01LD, MB03JD, MB04BD, MB04HD, XERBLA
C
C     .. Intrinsic Functions ..
      INTRINSIC          INT, MAX, MOD, SQRT
C
C     .. Executable Statements ..
C
C     Decode the input arguments.
C     Using ORTH = 'Q' is not safe, but sometimes gives better results.
C
      M   = N/2
      N2  = N*2
      NN  = N*N
      MM  = M*M
      NEIG  = 0
      LINIQ = LSAME( COMPQ, 'C' )
      IF( LINIQ ) THEN
         QR  = LSAME( ORTH, 'Q' )
         QRP = LSAME( ORTH, 'P' )
         SVD = LSAME( ORTH, 'S' )
      END IF
      IF( N.EQ.0 ) THEN
         MINIW = 1
         MINDW = 1
      ELSE IF( LINIQ ) THEN
         MINIW = MAX( 32, N2 + 3 )
         MINDW = 8*NN + MAX( 8*N + 32, 272 )
      ELSE
         IF( MOD( M, 2 ).EQ.0 ) THEN
            J = MAX( 4*N, 32 ) + 4
         ELSE
            J = MAX( 4*N, 36 )
         END IF
         MINIW = MAX( N + 12, N2 + 3 )
         MINDW = 3*M**2 + NN + J
      END IF
      LQUERY = LDWORK.EQ.-1
C
C     Test the input arguments.
C
      INFO = 0
      IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LINIQ ) ) THEN
         INFO = -1
      ELSE IF( LINIQ ) THEN
         IF( .NOT.( QR .OR. QRP .OR. SVD ) )
     $      INFO = -2
      ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN
         INFO = -3
      ELSE IF(  LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      ELSE IF( LDDE.LT.MAX( 1, M ) ) THEN
         INFO = -7
      ELSE IF(  LDB.LT.MAX( 1, M ) ) THEN
         INFO = -9
      ELSE IF( LDFG.LT.MAX( 1, M ) ) THEN
         INFO = -11
      ELSE IF( LDQ.LT.1 .OR. ( LINIQ .AND. LDQ.LT.N2 ) ) THEN
         INFO = -14
      ELSE IF( LIWORK.LT.MINIW ) THEN
         IWORK( 1 ) = MINIW
         INFO = -19
      ELSE IF( .NOT. LQUERY .AND. LDWORK.LT.MINDW ) THEN
         DWORK( 1 ) = MINDW
         INFO = -21
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB03LD', -INFO )
         RETURN
      ELSE IF( N.GT.0 ) THEN
C
C        Compute optimal workspace.
C
         IF( LQUERY ) THEN
            IF( LINIQ ) THEN
               CALL MB04HD( 'I', 'I', N, DWORK, N, DWORK, N, DWORK, N,
     $                      DWORK, N, IWORK, LIWORK, DUM, -1, BWORK,
     $                      INFO )
               IF( SVD ) THEN
                  CALL DGESVD( 'O', 'N', N, N, Q, LDQ, DWORK, DWORK,
     $                         LDQ, DWORK, 1, DUM( 2 ), -1, INFO )
                  J = N + INT( DUM( 2 ) )
               ELSE
                  IF( QR ) THEN
                     CALL DGEQRF( N, M, Q, LDQ, DWORK, DUM( 2 ), -1,
     $                            INFO )
                     J = M
                  ELSE
                     CALL DGEQP3( N, N, Q, LDQ, IWORK, DWORK, DUM( 2 ),
     $                            -1, INFO )
                     J = N
                  END IF
                  CALL DORGQR( N, J, J, Q, LDQ, DWORK, DUM( 3 ), -1,
     $                         INFO )
                  J = J + MAX( INT( DUM( 2 ) ), INT( DUM( 3 ) ) )
               END IF
               OPTDW = MAX( MINDW, 6*NN + INT( DUM( 1 ) ), J )
            ELSE
               OPTDW = MINDW
            END IF
            DWORK( 1 ) = OPTDW
            RETURN
         END IF
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         DWORK( 1 ) = ONE
         RETURN
      END IF
C
      IFO = 1
C
C     STEP 1: Apply MB04BD to transform the pencil to real
C             skew-Hamiltonian/Hamiltonian Schur form.
C
C     Set the computation option and pointers for the inputs and outputs
C     of MB04BD. If possible, array Q is used as vectorized workspace.
C
C     Real workspace:     need   w1 + w0 + MAX( L, 36 ),  where
C                                w1 = 2*N**2, w0 = 2*N**2, if COMPQ = 'C';
C                                w1 = 3*M**2, w0 =   N**2, if COMPQ = 'N';
C                                L  = 4*N + 4, if N/2 is even, and
C                                L  = 4*N    , if N/2 is odd.
C     Integer workspace:  need   MAX(N+12,2*N+3).
C
      IF( LINIQ ) THEN
         CMPQ = 'Initialize'
         IQ1  = 1
         IQ2  = IQ1 + NN
         IWRK = IQ2 + NN
         IF( MOD( M, 4 ).EQ.0 ) THEN
            IC2 = M/4
         ELSE
            IC2 = INT( M/4 ) + 1
         END IF
         IB   = 2*IC2 + 1
         IC2  =   IC2 + 1
         CALL MB04BD( 'Triangularize', CMPQ, CMPQ, N, A, LDA, DE, LDDE,
     $                B, LDB, FG, LDFG, DWORK( IQ1 ), N, DWORK( IQ2 ),
     $                N, Q( 1, IB ), M, Q( 1, IFO ), M, Q( 1, IC2 ), M,
     $                ALPHAR, ALPHAI, BETA, IWORK, LIWORK,
     $                DWORK( IWRK ), LDWORK-IWRK+1, INFO )
      ELSE
         CMPQ = 'No Computation'
         IB   = IFO + MM
         IC2  = IB  + MM
         IWRK = IC2 + MM
         CALL MB04BD( 'Eigenvalues', CMPQ, CMPQ, N, A, LDA, DE, LDDE, B,
     $                LDB, FG, LDFG, DWORK, N, DWORK, N, DWORK( IB ), M,
     $                DWORK( IFO ), M, DWORK( IC2 ), M, ALPHAR, ALPHAI,
     $                BETA, IWORK, LIWORK, DWORK( IWRK ), LDWORK-IWRK+1,
     $                INFO )
      END IF
      OPTDW = MAX( MINDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
C
      IF( INFO.GT.0 .AND. INFO.LT.3 ) THEN
         INFO = 1
         RETURN
      ELSE IF( INFO.EQ.3 ) THEN
         IW = 5
      ELSE
         IW = 0
      END IF
C
      IF( .NOT.LINIQ ) THEN
         CALL MA02AD( 'Upper', M, M, DWORK( IC2 ), M, DE, LDDE )
         CALL DCOPY(  M-1, DWORK( IC2+1 ), M+1, DE( 1, 2 ), LDDE+1 )
         DWORK( 1 ) = OPTDW
         INFO = IW
         RETURN
      END IF
C
C     STEP 2: Build the needed parts of the extended matrices Se and He,
C     and compute the transformed matrices and the orthogonal matrices
C     Q3 and Q4.
C
C     Real workspace:     need   w1 + w2 + 2*N**2 + MAX(M+168,272), with
C                                w2 = 4*N**2 (COMPQ = 'C');
C                         prefer larger.
C     Integer workspace:  need   MAX(M+1,32).
C
      NM   = N*M
      NMM  = NM + M
      IQ3  = IWRK
      IQ4  = IQ3  + NN
      IS11 = IQ4  + NN
      IH11 = IS11 + NN
      IWRK = IH11 + NN
C
      CALL DLACPY( 'Full', M, M, A, LDA, DWORK( IS11 ), N )
      CALL DLACPY( 'Full', M, M, Q( 1, IB ), M, DWORK( IS11+NMM ), N )
      CALL DSCAL(  MM, -ONE, Q( 1, IC2 ), 1 )
      CALL DLACPY( 'Full', M, M, Q( 1, IC2 ), M, DWORK( IH11+M ), N )
      CALL DLACPY( 'Full', M, M, B, LDB, DWORK( IH11+NM ), N )
C
      CALL MB04HD( CMPQ, CMPQ, N, DWORK( IS11 ), N, DWORK( IH11 ), N,
     $             DWORK( IQ3 ), N, DWORK( IQ4 ), N, IWORK, LIWORK,
     $             DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO )
      IF( INFO.GT.0 ) THEN
         IF( INFO.GT.2 )
     $      INFO = 2
         RETURN
      END IF
      OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
C
C     STEP 3: Update S12 and H12, building the upper triangular parts,
C     and exploiting the structure. Note that S12 is skew-symmetric and
C     H12 is symmetric.
C
C     Real workspace:     need   w1 + w2 + w3, where
C                                w3 = N**2 + M**2.
C
      IS12 = IWRK
      IH12 = IS12 + NN
      IWRK = IH12
C
      IF( M.GT.1 ) THEN
C
C                                                   [ Qa  Qc ]
C        Compute Qa'*Do*Qc + Qb'*Fo*Qd, where Q4 =: [        ],
C                                                   [ Qb  Qd ]
C        with Do := Dout, etc.
C        Compute also Qc'*Do*Qc + Qd'*Fo*Qd, using MB01KD.
C        Part of the array Q and DWORK(IS12) are used as workspace.
C
         CALL DLACPY( 'Full', M-1, M, DWORK( IQ4+NM+1 ), N,
     $                DWORK( IS12 ), M )
         CALL DLACPY( 'Full', M-1, M, DWORK( IQ4+NM ), N, Q( 2, IB ),
     $                M )
         CALL DTRMM(  'Left', 'Upper', 'No Transpose', 'Non-Unit', M-1,
     $                M, ONE, DE( 1, 3 ), LDDE, DWORK( IS12 ), M )
C
         CALL MB01KD( 'Upper', 'Transpose', M, M-1, ONE,
     $                DWORK( IQ4+NM ), N, DWORK( IS12 ), M, ZERO,
     $                DWORK( IS12+NMM ), N, INFO )
C
         CALL DTRMM(  'Left', 'Upper', 'Transpose', 'Non-Unit', M-1, M,
     $                -ONE, DE( 1, 3 ), LDDE, Q( 2, IB ), M )
         DUM( 1 ) = ZERO
         CALL DCOPY( M, DUM, 0, DWORK( IS12+M-1 ), M )
         CALL DCOPY( M, DUM, 0, Q( 1, IB ), M )
         CALL DAXPY( MM, ONE, Q( 1, IB ), 1, DWORK( IS12 ), 1 )
C
         CALL DLACPY( 'Full', M-1, M, DWORK( IQ4+NMM+1 ), N,
     $                DWORK( IWRK ), M )
         CALL DLACPY( 'Full', M-1, M, DWORK( IQ4+NMM ), N, Q( 2, IB ),
     $                M )
         CALL DTRMM(  'Left', 'Upper', 'No Transpose', 'Non-Unit', M-1,
     $                M, ONE, Q( M+1, IFO ), M, DWORK( IWRK ), M )
C
         CALL MB01KD( 'Upper', 'Transpose', M, M-1, ONE,
     $                DWORK(  IQ4+NMM ), N, DWORK( IWRK ), M, ONE,
     $                DWORK( IS12+NMM ), N, INFO )
C
         CALL DTRMM(  'Left', 'Upper', 'Transpose', 'Non-Unit', M-1,
     $                M, -ONE, Q( M+1, IFO ), M, Q( 2, IB ), M )
         CALL DCOPY( M, DUM, 0, DWORK( IWRK+M-1 ), M )
         CALL DAXPY( MM, ONE, Q( 1, IB ), 1, DWORK( IWRK ), 1 )
C
         CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE,
     $               DWORK( IQ4 ), N, DWORK( IS12 ), M, ZERO,
     $               DWORK( IS12+NM ), N )
         CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE,
     $               DWORK( IQ4+M ), N, DWORK( IWRK ), M, ONE,
     $               DWORK( IS12+NM ), N )
C
C        Compute Qa'*Do*Qa + Qb'*Fo*Qb.
C
         CALL MB01LD( 'Upper', 'Transpose', M, M, ZERO, ONE,
     $                DWORK( IS12 ), N, DWORK( IQ4 ), N, DE( 1, 2 ),
     $                LDDE, DWORK( IWRK ), LDWORK-IWRK+1, INFO )
         CALL MB01LD( 'Upper', 'Transpose', M, M, ONE, ONE,
     $                DWORK( IS12 ), N, DWORK( IQ4+M ), N, Q( 1, IFO ),
     $                M, DWORK( IWRK ), LDWORK-IWRK+1, INFO )
      END IF
C
C     Compute Qb'*Vo'*Qc + Qa'*Vo*Qd.
C     Real workspace:     need   w1 + w2 + w3, where
C                                w3 = 2*N**2.
C
      CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE,
     $            FG( 1, 2 ), LDFG, DWORK( IQ4+NM ), N, ZERO,
     $            Q( 1, IFO ), M )
      CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE,
     $            FG( 1, 2 ), LDFG, DWORK( IQ4 ), N, ZERO,
     $            DWORK( IH12+NMM ), N )
      CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE,
     $            DWORK( IQ4+M ), N, Q( 1, IFO ), M, ZERO,
     $            DWORK( IH12+NM ), N )
      CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE,
     $            DWORK( IH12+NMM ), N, DWORK( IQ4+NMM ), N, ONE,
     $            DWORK( IH12+NM ), N )
C
C     Compute the upper triangle of Qa'*Vo*Qb + (Qa'*Vo*Qb)'.
C
      CALL DSYR2K( 'Upper', 'Transpose', M, M, ONE, DWORK( IH12+NMM ),
     $             N, DWORK( IQ4+M ), N, ZERO, DWORK( IH12 ), N )
C
C     Compute the upper triangle of Qc'*Vo*Qd + (Qc'*Vo*Qd)'.
C
      CALL DSYR2K( 'Upper', 'Transpose', M, M, ONE, Q( 1, IFO ), M,
     $             DWORK( IQ4+NMM ), N, ZERO, DWORK( IH12+NMM ), N )
C
C     Return C2out.
C
      CALL DSCAL(  MM, -ONE, Q( 1, IC2 ), 1 )
      CALL MA02AD( 'Upper', M, M, Q( 1, IC2 ), M, DE, LDDE )
      CALL DCOPY(  M-1, Q( 2, IC2 ), M+1, DE( 1, 2 ), LDDE+1 )
C
C     STEP 4: Apply MB03JD to reorder the eigenvalues with strictly
C             negative real part to the top.
C
C     Real workspace:     need   w1 + w2 + w3 + MAX(8*N+32,108),
C                                w3 = 2*N**2.
C     Integer workspace:  need   2*N + 1.
C
      IWRK = IH12 + NN
C
      CALL MB03JD( CMPQ, N2, DWORK( IS11 ), N, DWORK( IS12 ), N,
     $             DWORK( IH11 ), N, DWORK( IH12 ), N, Q, LDQ, NEIG,
     $             IWORK, LIWORK, DWORK( IWRK ), LDWORK-IWRK+1, INFO )
      IF( INFO.GT.0 ) THEN
         INFO = INFO + 1
         RETURN
      END IF
C
C     STEP 5: Compute the deflating subspace corresponding to the
C             eigenvalues with strictly negative real part.
C
C     Real workspace:     need   w2 + 3*N**2, if ORTH = 'QR';
C                                w2 + 4*N**2, otherwise.
C
      IWRK = IS11
      IF( QR )
     $   NEIG = NEIG/2
C
C     Compute [ J*Q1*J' Q2 ].
C
      CALL DLACPY( 'Full', M, M, DWORK( IQ1+NMM ), N, DWORK( IWRK ), N )
      CALL DLACPY( 'Full', M, M, DWORK( IQ1+NM ), N, DWORK( IWRK+M ),
     $             N )
      DO 10 J = 1, M
         CALL DSCAL( M, -ONE, DWORK( IWRK+M+(J-1)*N ), 1 )
   10 CONTINUE
      CALL DLACPY( 'Full', M, M, DWORK( IQ1+M ), N, DWORK( IWRK+NM ),
     $             N )
      DO 20 J = 1, M
         CALL DSCAL( M, -ONE, DWORK( IWRK+NM+(J-1)*N ), 1 )
   20 CONTINUE
      CALL DLACPY( 'Full', M, M, DWORK( IQ1 ), N, DWORK( IWRK+NMM ), N )
C
      CALL DLACPY( 'Full', N, N, DWORK( IQ2 ), N, DWORK( IWRK+NN ), N )
C
C     Compute the first NEIG columns of P*[ Q3  0; 0 Q4 ]*Q.
C
      IRT = IWRK + N*N2
      CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, ONE,
     $            DWORK( IQ3 ), N, Q, LDQ, ZERO, DWORK( IRT ), N2 )
      CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, ONE,
     $            DWORK( IQ4 ), N, Q( N+1, 1 ), LDQ, ZERO,
     $            DWORK( IRT+M ), N2 )
      CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, ONE,
     $            DWORK( IQ3+M ), N, Q, LDQ, ZERO, DWORK( IRT+N ), N2 )
      CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, ONE,
     $            DWORK( IQ4+M ), N, Q( N+1, 1 ), LDQ, ZERO,
     $            DWORK( IRT+N+M ), N2 )
C
C     Compute the deflating subspace.
C
      CALL DGEMM( 'No Transpose', 'No Transpose', N, NEIG, N2,
     $            SQRT( TWO )/TWO, DWORK( IWRK ), N, DWORK( IRT ), N2,
     $            ZERO, Q, LDQ )
C
C     Orthogonalize the basis given in Q(1:n,1:neig).
C
      IWRK = NEIG + 1
      IF( SVD ) THEN
C
C        Real workspace:     need   N + MAX(1,5*N);
C                            prefer larger.
C
         CALL DGESVD( 'Overwrite', 'No V', N, NEIG, Q, LDQ, DWORK,
     $                DWORK, 1,  DWORK, 1, DWORK( IWRK ), LDWORK-IWRK+1,
     $                INFO )
         IF( INFO.GT.0 ) THEN
            INFO = 4
            RETURN
         END IF
         OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
         NEIG = NEIG/2
C
      ELSE
         IF( QR ) THEN
C
C           Real workspace:     need   N;
C                               prefer M+M*NB, where NB is the optimal
C                                              blocksize.
C
            CALL DGEQRF( N, NEIG, Q, LDQ, DWORK, DWORK( IWRK ),
     $                   LDWORK-IWRK+1, INFO )
         ELSE
C
C           Real workspace:     need   4*N+1;
C                               prefer 3*N+(N+1)*NB.
C
            DO 30 J = 1, NEIG
               IWORK( J ) = 0
   30       CONTINUE
            CALL DGEQP3( N, NEIG, Q, LDQ, IWORK, DWORK, DWORK( IWRK ),
     $                   LDWORK-IWRK+1, INFO )
         END IF
         OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
C
C        Real workspace:     need   2*NEIG;
C                            prefer NEIG + NEIG*NB.
C
         CALL DORGQR( N, NEIG, NEIG, Q, LDQ, DWORK, DWORK( IWRK ),
     $                LDWORK-IWRK+1, INFO )
         OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
         IF( QRP )
     $      NEIG = NEIG/2
      END IF
C
      DWORK( 1 ) = OPTDW
      INFO = IW
      RETURN
C *** Last line of MB03LD ***
      END


      PROGRAM CSEX04
C
C  Do a 2D approximation and find mixed second order partial derivatives.
C
C
C  The dimensionality of the problem.
C
      PARAMETER (NDIM=2)
C
C  The number of input data points.
C
      PARAMETER (NDATA=1000)
C
C  The number of output data points in the X coordinate direction.
C
      PARAMETER (NX=29)
C
C  The number of output data points in the Y coordinate direction.
C
      PARAMETER (NY=25)
C
C  Specifty the number of knots in the X direction.
C
      PARAMETER (N1=4)
C
C  Specifty the number of knots in the Y direction.
C
      PARAMETER (N2=4)
C
C  The size of the workspace.
C
      PARAMETER (NCF=N1*N2, NWRK=NCF*(NCF+3))
C
C Define the error file, the Fortran unit number, the workstation type,
C and the workstation ID to be used in calls to GKS routines.
C
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)   ! NCGM
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=8,  IWKID=1)   ! X Windows
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=11, IWKID=1)   ! PDF
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=20, IWKID=1)   ! PostScript
C
      PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)
C
C  Dimension the arrays.
C
      DIMENSION XDATA(NDIM,NDATA),YDATA(NDATA),KNOTS(NDIM),WORK(NWRK),
     +          NDERIV(2)
      DATA XMIN,YMIN,XMAX,YMAX / -1.0, -1.0, 1.0, 1.0/
      DATA NDERIV(1),NDERIV(2) / 0, 0/
      REAL XO(NX), YO(NY), FUNC(NX,NY),FUNCD(NX,NY)
C
C  Generate input data using the functiuon f(x,y) = y**2 - 0.5*y*x**2
C
      INDX = NDATA
      DO 10 I=1,INDX
        XDATA(1,I) = XMIN+(XMAX-XMIN)*DSRND1()
        XDATA(2,I) = YMIN+(YMAX-YMIN)*DSRND1()
        XX = XDATA(1,I)
        YY = XDATA(2,I)
        YDATA(I) = YY*YY - 0.5*YY*XX*XX
   10 CONTINUE
C
C  Create the output grid.
C
      DO 102 I=1,NX
        XO(I) = XMIN+(REAL(I-1)/REAL(NX-1))*(XMAX-XMIN)
  102 CONTINUE
      DO 103 J =1,NY
        YO(J)= YMIN+(REAL(J-1)/REAL(NY-1))*(YMAX-YMIN)
  103 CONTINUE
C
C  Specify the numbers of knots in each coordinate direction.
C
      KNOTS(1) = N1
      KNOTS(2) = N2
C
C  Calculate the approximated functuion values.
C
      CALL CSA2S (INDX,XDATA,YDATA,KNOTS,NX,NY,XO,YO,FUNC,NWRK,WORK,IER)
C
C  Calculate the second order mixed partial derivative.
C
      NDERIV(1) = 1
      NDERIV(2) = 1
      CALL CSA2XS (INDX,XDATA,YDATA,-1.,KNOTS,0.,NDERIV,NX,NY,
     +                  XO,YO,FUNCD,NWRK,WORK,IER)
C
C  Plot a surface.
C
C  Open GKS and define the foreground and background color.
C
      CALL GOPKS (IERRF, ISZDM)
      CALL GOPWK (IWKID, LUNIT, IWTYPE)
      CALL GACWK (IWKID)
C
C  Approximated function.
C
      CALL TDEZ2D(NX, NY, XO, YO, FUNC, 2.7, 45., 78., 6)
      CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
      CALL PLCHHQ(0.5,0.85,
     +   ':F25:z = f(x,y) = y:S:2:E:  - -:H-10::S:1:E::B::V-6:2:E:  y:V-
     +6:*:V+6:x:S:2:E:',0.04,0.,0.)
      CALL FRAME()
C
C  Mixed partial.
C
      CALL TDEZ2D(NX, NY, XO, YO, FUNCD, 2.7, 45., 78., 6)
      CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
      CALL PLCHHQ(0.5,0.88,
     + ':F25:z =  :F34::S::H8:6:F25::S:2:E::E::F34:>:B::F34::H-35::V-6:6
     +:F25:x:F34:6:F25:y:E:  f(x,y) = - x',0.04,0.,0.)
      CALL FRAME()
C
C Close GKS.
C
      CALL GDAWK (IWKID)
      CALL GCLWK (IWKID)
      CALL GCLKS
C
      STOP
      END
      REAL FUNCTION DSRND1()
C
C  Portable random number generator.
C
      PARAMETER (MPLIER=16807,MODLUS=2147483647,MOBYMP=127773,
     +           MOMDMP=2836)
C
      INTEGER HVLUE, LVLUE, TESTV, NEXTN
      SAVE    NEXTN
      DATA JSEED,IFRST/123456789,0/
C
      IF (IFRST .EQ. 0) THEN
        NEXTN = JSEED
        IFRST = 1
      ENDIF
C
      HVLUE = NEXTN / MOBYMP
      LVLUE = MOD(NEXTN, MOBYMP)
      TESTV = MPLIER*LVLUE - MOMDMP*HVLUE
      IF (TESTV .GT. 0) THEN
        NEXTN = TESTV
      ELSE
        NEXTN = TESTV + MODLUS
      ENDIF
      DSRND1 = REAL(NEXTN)/REAL(MODLUS)
C
      RETURN
      END


          subroutine filtro_per_y(yk)

! ------------------------------------------------------ !
!             filtro periodico                           !
!             F. Califano, Marzo 2001                    !
! ------------------------------------------------------ !

!**************************************************
!  MPI PARALLEL VERSION: VALENTINI-FAGANELLO 2009
!**************************************************

use parameter_mod
use box_mod
use filtro_per_mod
use deriv_mod, only: savey

IMPLICIT NONE

  integer :: m, m1, m2
  REAL(dp), dimension(ny)  :: yk

!  filtro

! **    y Filtering

        call drfftf(ny, yk, savey)

        m = 1

          do m1 = 2, ny - 1, 2

          m2 = m1 + 1

          yk(m1) = yk(m1) * work4y(m)
          yk(m2) = yk(m2) * work4y(m)

        m = m + 1

!write(*,898) m, work4y(m)

        enddo

!898     format(1x, 1i3, 1x, 1e12.5)
!stop

          yk = yk * ninvy

! **    Filtered function

        call drfftb(ny, yk, savey)

       return
       end


c****************************************************************

	subroutine lincomb(r_k1,r_u,r_k2,r_v,r_w)

c****************************************************************
c**
c**	FILE NAME: lincomb.f
c**
c**     DATE WRITTEN: 8/3/90
c**
c**     PROGRAMMER:Scott Hensley
c**
c** 	FUNCTIONAL DESCRIPTION: The subroutine forms the linear combination
c**	of two vectors.
c**
c**     ROUTINES CALLED:none
c**
c**     NOTES: none
c**
c**     UPDATE LOG:
c**
c*****************************************************************

       	implicit none

c	INPUT VARIABLES:
        real*8 r_u(3)                              !3x1 vector
        real*8 r_v(3)                              !3x1 vector
        real*8 r_k1				 !scalar
        real*8 r_k2				 !scalar

c   	OUTPUT VARIABLES:
        real*8 r_w(3)                              !3x1 vector

c	LOCAL VARIABLES:none

c  	PROCESSING STEPS:

c       compute linear combination

	r_w(1) = r_k1*r_u(1) + r_k2*r_v(1)
	r_w(2) = r_k1*r_u(2) + r_k2*r_v(2)
	r_w(3) = r_k1*r_u(3) + r_k2*r_v(3)

        end


      program m1

      include 'p4f.h'

*-----
*  file:-  norm_master.f
*  related files:-
*    norm_slave.f         (slave program)
*    norm_<hostname>.pg   (process group file)
*
*  Test program for new p4 library.
*    Generate matrix,
*    distribute columns to slaves,
*    get sum norm of columns, verify and display result.
*
*  features:-
*    max vector length <= `NMAX'.  If you increase this value,
*            be sure to increase the same value in slave program, too.
*    4 data byte per integer (controlled by `LENINT')
*    4 data byte per item    (real; controlled by `LENREAL')
*
*  Debug code disabled by `c$$$'.
*  status:- plain vanilla, no error control
*  Volker Kurz, ANL & U Frankfurt, 04-Oct-91
*-----
*     .. p4 routines ..
      external   p4init, p4crpg, p4ntotids, p4send, p4recv, p4cleanup,
     $     p4clock
*
*     .. constants ..
      integer    NMAX,      LENINT,   LENREAL,   OFF
      parameter (NMAX=200 , LENINT=4, LENREAL=4, OFF=-1)
      integer    TAGCNT,    TAGDAT,    TAGNEW,    TAGEND
      parameter (TAGCNT=10, TAGDAT=20, TAGNEW=30, TAGEND=40)
*
*     .. variables and arrays ..
      integer    nslaves, i, k, mnsl, time1, time2,
     $     iretcd, ireclen, ip, msglen, itype
      real       a(NMAX, NMAX), r(NMAX), rnorm
      logical    errors
*-----
*
      write (*,*) 'setting up parallel environment...'
*
      call p4init ()
      call p4crpg ()
      nslaves = p4ntotids() - 1
*
      write (*,*) 'initializing matrix...'
*
      do 1 k=1,NMAX
         a(1,k) = float (k+1)
         do 11 i=2,NMAX
            a(i,k) = 1.0
 11      continue
 1    continue
*-----------------------------------------------------------------------
*  Beginning of main loop
*  ~~~~~~~~~~~~~~~~~~~~~~
 2    continue
*
*  Ask for number of rows and columns.
*  Provide a condition to end the program.
*  Watch out, if they want to fool us by entering too big numbers.
*  Calculate message length for slave data.
*  Broadcast vector length to slaves.
*
      write (*,9993) NMAX
      read (*,*) m
      if (m.lt.1) then
         goto 7
      elseif (m.gt.NMAX) then
         m = NMAX
         write (*,*) 'value truncated to m = ',m
      endif
      write (*,9995) NMAX
      read (*,*) n
      if (n.lt.1) then
         goto 7
      elseif (n.gt.NMAX) then
         n = NMAX
         write (*,*) 'value truncated to n = ',n
      endif
*
      msglen = m * LENREAL
      time1 = p4clock()
*
      do 3 i=1,nslaves
         call p4send (TAGCNT, i, m, LENINT, iretcd)
 3    continue
*
*  Compute norms of columns
*  ~~~~~~~~~~~~~~~~~~~~~~~~
*  Process columns by strips of length 'nslaves'.
*  'mnsl' ensures that only 'n' columns are processed.
*  1st sweep dials out columns,
*  2nd sweep collects results.
*
      do 4 i=1,n,nslaves
*        .. distribute columns to slaves ..
         mnsl = min ( n-i+1, nslaves )
         do 41 k=1,mnsl
*           .. send column i+k-1 to slave k ..
            call p4send (TAGDAT, k, a(1,i+k-1), msglen, iretcd)
 41      continue
         do 42 k=1,mnsl
*           .. receive norm from slave ..
            itype = TAGDAT
            ip = OFF
            call p4recv (itype, ip, rnorm, LENREAL, ireclen, iretcd)
*           .. result is for column i+ip-1 ..
            r(i+ip-1) = rnorm
 42      continue
 4    continue
      time2 = p4clock()
*
*  Check results and report any errors.
*  Norm of column k is:  #rows + k
*  Note: There should be no rounding errors!
*
      errors = .FALSE.
      do 5 k=1,n
         if (r(k).ne.m+k) then
            write (*,9999) k, m+k, r(k)
            errors = .TRUE.
         endif
c$$$         write (*,*) 'norm of col', k,' is:', r(k)
 5    continue
      if (errors) then
         write (*,*) 'mission completed, error(s) detected.'
      else
         write (*,*) 'mission completed, no errors detected.'
      endif
      write (*,9997) float (time2-time1) / 1000.0
*
*  Tell slaves to get ready for a new session.
*  Data is ignored, when slave detects data type TAGNEW.
*
      do 6 i=1,nslaves
         call p4send (TAGNEW, i, m, LENINT, iretcd)
 6    continue
*
*  End of main loop
*  ~~~~~~~~~~~~~~~~
      goto 2
 7    continue
*------------------------------------------------------------------------------
*
*  Terminate parallel session
*  ~~~~~~~~~~~~~~~~~~~~~~~~~~
*  Broadcast TAGEND signal to all slaves.
*  A slave will terminate, when TAGEND is detected,
*  the contents of the message will be ignored.
*
      do 8 i=1,nslaves
         call p4send (TAGEND, i, n, LENINT, iretcd)
 8    continue
      call p4cleanup
*-----
      stop
 9993 format(1x,'-----'/
     $     ' input number of rows (1 <= m <=',i7,')'/
     $     ' (any value <= 0 terminates program)')
 9995 format(1x,
     $     ' input number of columns (1 <= n <=',i7,')'/
     $     ' (any value <= 0 terminates program)')
 9997 format(1x,'time :',f12.3,' s')
 9999 format(1x,'Error in column ',i7/
     $     '   norm should be       :',i10/
     $     '   but computed value is:',e14.4)
      end


      SUBROUTINE MATMUL(A,B,L,M,N,C)
      DOUBLE PRECISION A(L,M),B(M,N),C(L,N)
      DO 10 I=1,L
      DO 10 J=1,N
      C(I,J)=0.D0
      DO 10 K=1,M
   10 C(I,J)=C(I,J)+A(I,K)*B(K,J)
      RETURN
      END


!> This module defines several functions for random number generation.
!> @version 1.0
!> @author O. Desjardins and several others
module random
   implicit none
   private

   ! Function and subroutines
   public :: random_uniform,random_normal,random_lognormal
   public :: random_initialize

contains

   !> Initialization of the RNG: seeding is based on /dev/urandom
   !> or if not available on a naive RNG seeded with time and pid.
   !>
   !> This comes from the GFortran website.
   subroutine random_initialize
      use precision, only: I4,I8
      implicit none
      integer(kind=I4), allocatable, dimension(:) :: seed
      integer(kind=I4) :: i,n,un,istat,dt(8),pid
      integer(kind=I8) :: t
      ! Get seed size
      call random_seed(size=n)
      allocate(seed(n))
      ! First try if the OS provides a random number generator
      open(newunit=un,file="/dev/urandom",access="stream",form="unformatted",action="read",status="old",iostat=istat)
      if (istat.eq.0) then
         read(un) seed
         close(un)
      else
         ! Fallback to XOR:ing the current time and pid. The PID is useful in
         ! case one launches multiple instances of the same program in parallel
         call system_clock(t)
         if (t.eq.0) then
            call date_and_time(values=dt)
            t=(dt(1)-1970)*365_I8*24*60*60*1000 &
            & +dt(2)*31_I8*24*60*60*1000+dt(3)*24_I8*60*60*1000 &
            & +dt(5)*60*60*1000+dt(6)*60*1000+dt(7)*1000+dt(8)
         end if
         pid=getpid()
         t=ieor(t,int(pid,kind(t)))
         do i=1,n
            seed(i)=lcg(t)
         end do
      end if
      ! Place the seed
      call random_seed(put=seed)
   contains
      !> Simple RNG, sufficient for seeding a better RNG
      function lcg(s) result(v)
         integer(kind=I8) :: s
         integer(kind=I4) :: v
         if (s.eq.0) then
            s=104729
         else
            s=mod(s,4294967296_I8)
         end if
         s=mod(s*279470273_I8,4294967291_I8)
         v=int(mod(s,int(huge(0),I8)),kind(0))
      end function lcg
   end subroutine random_initialize

   !> Sampling of a WP real from a uniform distribution in [lo,hi]
   function random_uniform(lo,hi) result(res)
      use precision, only: WP
      implicit none
      !> Lower and upper bounds of the distribution
      real(kind=WP), intent(in) :: lo,hi
      real(kind=WP) :: res
      ! Generate random_uniform in [0,1]
      call random_number(res)
      ! Modify to give correct bounds
      res=lo+(hi-lo)*res
   end function random_uniform

   !> Sampling of a WP real from a normal distribution
   !> Adapted from the following Fortran 77 code:
   !> ALGORITHM 712, COLLECTED ALGORITHMS FROM ACM,
   !> IN TRANSACTIONS ON MATHEMATICAL SOFTWARE,
   !> VOL. 18, NO. 4, DECEMBER, 1992, PP. 434-435.
   !>
   !> The function random_normal() returns a normally distributed
   !> pseudo-random number with zero mean and unit variance.
   !> The algorithm uses the ratio of uniforms method of A.J. Kinderman
   !> and J.F. Monahan augmented with quadratic bounding curves.
   function random_normal(m,sd) result(res)
      use precision, only: WP
      implicit none
      !> Mean and standard deviation of the distribution
      real(kind=WP), intent(in), optional :: m,sd
      real(kind=WP) :: res
      real(kind=WP), parameter :: s =+0.449871_WP
      real(kind=WP), parameter :: t =-0.386595_WP
      real(kind=WP), parameter :: a =+0.19600_WP
      real(kind=WP), parameter :: b =+0.25472_WP
      real(kind=WP), parameter :: r1=+0.27597_WP
      real(kind=WP), parameter :: r2=+0.27846_WP
      real(kind=WP) :: u,v,x,y,q
      ! Generate P=(u,v) uniform in rectangle enclosing acceptance region
      try: do
         call random_number(u)
         call random_number(v)
         v=1.7156_WP*(v-0.5_WP)
         ! Evaluate the quadratic form
         x=u-s
         y=abs(v)-t
         q=x**2+y*(a*y-b*x)
         ! Accept P if inside inner ellipse
         if (q.lt.r1) exit try
         ! Reject P if outside outer ellipse
         if (q.gt.r2) cycle try
         ! Accept P if inside acceptance region
         if (v**2.lt.-4.0_WP*log(u)*u**2) exit try
      end do try
      ! Return ratio of P's coordinates as the normal deviate
      res=v/u
      ! Modify to give correct mean and standard deviation
      if (present(sd)) res=res*sd
      if (present(m))  res=res+m
   end function random_normal

   !> Sampling of a WP real from a log-normal distribution:
   !> If X has a lognormal distribution, then log(X) is normally distributed.
   !> Here the logarithm is the natural logarithm, that is to base e, sometimes
   !> denoted as ln.  To generate random variates from this distribution, generate
   !> a random deviate from the normal distribution with mean and variance equal
   !> to the mean and variance of the logarithms of X, then take its exponential.
   !>
   !> Relationship between the mean & variance of log(X) and the mean & variance
   !> of X, when X has a lognormal distribution.
   !>
   !> Let:
   !> @verbatim
   !> m = mean of log(X)
   !> s^2 = variance of log(X)
   !> @endverbatim
   !>
   !> Then:
   !> @verbatim
   !> mean of X     = exp(m + 0.5s^2)
   !> variance of X = (mean(X))^2.[exp(s^2) - 1]
   !> @endverbatim
   !>
   !> In the reverse direction:
   !> @verbatim
   !> variance of log(X) = log[1 + var(X)/(mean(X))^2]
   !> mean of log(X)     = log(mean(X) - 0.5var(log(X))
   !> @endverbatim
   function random_lognormal(m,sd) result(res)
      use precision, only: WP
      implicit none
      !> Mean and standard deviation of the log-normal distribution
      real(kind=WP), intent(in) :: m,sd
      real(kind=WP) :: res
      real(kind=WP) :: x,mlog,sdlog
      sdlog=sqrt(log(1.0_WP+(sd/m)**2))
      mlog =log(m)-0.5_WP*sdlog**2
      x    =random_normal(mlog,sdlog)
      res=exp(x)
   end function random_lognormal

end module random


      PROGRAM CSSEX01
C
C  Example of Delaunay triangulation and Voronoi diagram
C  on the surface of a sphere.
C
C Define the error file, the Fortran unit number, the workstation type,
C and the workstation ID to be used in calls to GKS routines.
C
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)   ! NCGM
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=8,  IWKID=1)   ! X Windows
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=11, IWKID=1)   ! PDF
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=20, IWKID=1)   ! PostScript
C
      PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)
C
C  Input dataset on the globe (latitudes and longitudes in degrees).
C  These data points do not cover the globe, but rather are confined
C  to the nothern hemisphere and are enclosed by a boundary.
C
      PARAMETER (NMAX=7)
      DIMENSION RLAT(NMAX),RLON(NMAX)
      DATA RLAT/  70.,  70., 70., 85., 60., 60., 65./
      DATA RLON/-160., -70.,  0., 20., 50., 80.,140./
C
C  Dimension the arrays for holding the points for drawing
C  circular arcs.
C
      PARAMETER (NARC=50)
      DIMENSION ARCLAT(NARC),ARCLON(NARC)
      DIMENSION ARCUAR(NARC),ARCVAR(NARC)
C
C  Storage for the triangulation, work space, and Voronoi vertices.
C
      PARAMETER (NTMX=2*NMAX, NT6=6*NMAX, LWK=27*NMAX)
      INTEGER LTRI(3,NTMX), IWK(LWK), NV(NMAX)
C
C  Real workspace.
C
      DOUBLE PRECISION    RWK(13*NMAX)
C
C  Storage for circumcenters and circum radii.
C
      REAL    PLAT(NTMX),    PLON(NTMX),   RC(NTMX)
C
      N = NMAX
C
C  Create the triangulation, storing the vertices in LTRI.
C
      CALL CSSTRI (N,RLAT,RLON, NT,LTRI, IWK,RWK,IER)
C
C  Plot the Delaunay triangulation, the circumcircles, and
C  the Voronoi polygons on a sphere.
C
C  Open GKS.
C
      CALL GOPKS (IERRF, ISZDM)
      CALL GOPWK (IWKID, LUNIT, IWTYPE)
      CALL GACWK (IWKID)
C
C  Color table.
C
      CALL GSCR(IWKID,0,0.,0.,0.)
      CALL GSCR(IWKID,1,1.,1.,1.)
      CALL GSCR(IWKID,2,0.,1.,1.)
      CALL GSCR(IWKID,3,1.,1.,0.)
      CALL GSCR(IWKID,4,1.,0.,0.)
      CALL GSCR(IWKID,5,0.,1.,0.)
      CALL GSCR(IWKID,6,0.,.8,0.)
C
C Draw a map of the North Atlantic, as seen by a satellite.
C
      CALL GSPLCI(6)
      CALL MAPSTR ('SA',4.)
      CALL MAPPOS(0.175, 0.975, 0.025, 0.825)
      CALL SUPMAP (7,72.5,127.5,0.,0.,0.,0.,0.,1,-1000,5,0,IERR)
C
C  Get the circumcenters of the Delaunay triangles.
C
      CALL CSVORO(N,RLAT,RLON,1,1,IWK,RWK,NTMX,PLAT,PLON,RC,
     +            NCA,NUMV,NV,IER)
C
C  Plot the circumcircles whose circumcenters lie in one of
C  the Delaunay triangles composed of original data points
C  (exclude the pseudo points added to complete the
C  triangulation on the whole sphere).
C
      CALL GSLWSC(2.0)
      CALL GSPLCI(4)
      DO 940 I=5,10
C
        CALL NGGCOG(PLAT(I),PLON(I),RC(I),ARCLAT,ARCLON,NARC)
        CALL MAPIT(ARCLAT(1),ARCLON(1),0)
        DO 930 J=2,NARC-1
          CALL MAPIT(ARCLAT(J),ARCLON(J),1)
  930   CONTINUE
        CALL MAPIT(ARCLAT(NARC),ARCLON(NARC),1)
        CALL MAPIQ
  940 CONTINUE
C
C  Draw the Voronoi polygons.
C
      DO 150 I=1,N
C
C  Get the polygon containing the original data point
C  (X(I),Y(I),Z(I)).
C
        CALL CSVORO(N,RLAT,RLON,I,0,IWK,RWK,NTMX,PLAT,PLON,RC,
     +              NCA,NUMV,NV,IER)
        DO 855 NN=2,NUMV
C
C  Get a polygonal segment.
C
          RLAT1 = PLAT(NV(NN-1))
          RLON1 = PLON(NV(NN-1))
          RLAT2 = PLAT(NV(NN))
          RLON2 = PLON(NV(NN))
C
C  Plot it.
C
          CALL GSPLCI(3)
          CALL MAPGCI(RLAT1,RLON1,RLAT2,RLON2,NARC,ARCLAT,ARCLON)
          CALL MAPIT(RLAT1,RLON1,0)
          DO 920 J=1,NARC
            CALL MAPIT(ARCLAT(J),ARCLON(J),1)
  920     CONTINUE
          CALL MAPIT(RLAT2,RLON2,1)
          CALL MAPIQ
  855   CONTINUE
  150 CONTINUE
C
C  Draw the Delaunay triangles.
C
      CALL GSPLCI(2)
      DO 130 NP=1,NT
        DO 140 NS=1,3
          CALL MAPGCI(RLAT(LTRI(NS,NP)),RLON(LTRI(NS,NP)),
     +                RLAT(LTRI(MOD(NS,3)+1,NP)),
     +                RLON(LTRI(MOD(NS,3)+1,NP)),
     +                NARC,ARCLAT,ARCLON)
          CALL MAPIT(RLAT(LTRI(NS,NP)),RLON(LTRI(NS,NP)),0)
          DO 120 I=1,NARC
            CALL MAPIT(ARCLAT(I),ARCLON(I),1)
  120     CONTINUE
          CALL MAPIT(RLAT(LTRI(MOD(NS,3)+1,NP)),
     +               RLON(LTRI(MOD(NS,3)+1,NP)),1)
  140   CONTINUE
  130 CONTINUE
      CALL MAPIQ
C
C  Mark the original data points.
C
      CALL GSFACI(3)
      DO 400 I=1,N
        CALL NGGCOG(RLAT(I),RLON(I),1.2,ARCLAT,ARCLON,NARC)
        DO 410 L=1,NARC
          CALL MAPTRN(ARCLAT(L),ARCLON(L),ARCUAR(L),ARCVAR(L))
  410   CONTINUE
        CALL GFA(NARC,ARCUAR,ARCVAR)
  400 CONTINUE
C
C  Mark the circumcenters.
C
      CALL GSFACI(5)
      DO 440 I=5,10
        CALL NGGCOG(PLAT(I),PLON(I),0.6,ARCLAT,ARCLON,NARC)
        DO 420 L=1,NARC
          CALL MAPTRN(ARCLAT(L),ARCLON(L),ARCUAR(L),ARCVAR(L))
  420   CONTINUE
        CALL GFA(NARC,ARCUAR,ARCVAR)
  440 CONTINUE
C
C  Put out a legend.
C
      CALL SET(0.0, 1.0, 0.0, 1.0, 0.0, 1.0, 0.0, 1.0, 1)
C
      CALL CSDRBX(0.02, 0.945, 0.12, 0.955, 2)
      CALL PCSETI('CC',1)
      CALL PLCHHQ(0.14, 0.95, ':F22:Delaunay triangles',
     +            0.025, 0.0, -1.0)
C
      CALL CSDRBX(0.02, 0.895, 0.12, 0.905, 3)
      CALL PLCHHQ(0.14, 0.90, ':F22:Voronoi polygons', 0.025, 0.0, -1.0)
C
      CALL CSDRBX(0.02, 0.845, 0.12, 0.855, 4)
      CALL PLCHHQ(0.14, 0.85, ':F22:Circumcircles', 0.025, 0.0, -1.0)
C
      CALL FRAME
C
C  Close GKS.
C
      CALL GDAWK (IWKID)
      CALL GCLWK (IWKID)
      CALL GCLKS
C
      STOP
      END
      SUBROUTINE CSDRBX(XLL,YLL,XUR,YUR,ICNDX)
C
C  Draw a filled rectangle with the specified corner points
C  using color index ICNDX.
C
      DIMENSION X(5),Y(5)
C
      CALL GQFACI(IER,ICOLD)
C
      X(1) = XLL
      Y(1) = YLL
      X(2) = XUR
      Y(2) = YLL
      X(3) = XUR
      Y(3) = YUR
      X(4) = XLL
      Y(4) = YUR
      X(5) = XLL
      Y(5) = YLL
C
      CALL GSFACI(ICNDX)
      CALL GFA(5,X,Y)
      CALL GSFACI(ICOLD)
C
      RETURN
      END


module mod_rgrd4
    use mod_rgrd3
    implicit none

contains
    !

    ! Code converted using TO_F90 by Alan Miller
    ! Date: 2013-09-18  Time: 12:23:33

    ! ... file rgrd4.f

    !     this file contains documentation for subroutine rgrd4 followed by
    !     fortran code for rgrd4 and additional subroutines.

    ! ... author

    !     John C. Adams (NCAR 1999)

    ! ... subroutine rgrd4(nx,ny,nz,nt,x,y,z,t,p,mx,my,mz,mt,xx,yy,zz,tt,q,
    !    +                 intpol,w,lw,iw,liw,ier)

    ! ... purpose

    !     subroutine rgrd4 interpolates the values p(i,j,k,l) on the orthogonal
    !     grid

    !       (x(i),y(j),z(k),t(l))

    !       for i=1,...,nx;j=1,...,ny;k=1,...,nz;l=1,...,nt

    !     onto q(ii,jj,kk,ll) on the orthogonal grid

    !       (xx(ii),yy(jj),zz(kk),tt(ll))

    !       for ii=1,...,mx;jj=1,...,my;kk=1,...,mz;ll=1,...,mt

    ! ... language

    !     coded in portable FORTRAN77 and FORTRAN90

    ! ... test program

    !     file trgrd4.f on regridpack includes a test program for subroutine rgrd4

    ! ... method

    !     linear or cubic interpolation is used (independently) in
    !     each direction (see argument intpol).

    ! ... required files

    !     files rgrd3.f,rgrd2.f and rgrd1.f must be loaded with rgrd4.f.  they
    !     include subroutines called by the routines in rgrd4.f

    ! ... requirements

    !     each of the x,y,z,t grids must be strictly montonically increasing
    !     and each of the xx,yy,zz,tt grids must be montonically increasing
    !     (see ier = 4).  in addition the (X,Y,Z,T) region of the q grid

    !      [xx(1),xx(mx)] X [yy(1),yy(my)] X [zz(1),zz(mz)] X [tt(1),tt(my)]

    !     must lie within the (X,Y,Z,T) region of the p grid

    !      [x(1),x(nx)] X [y(1),y(ny)] X [z(1),z(nz)] X [t(1),t(nt)].

    !     extrapolation is not allowed (see ier=3).  if these (X,Y,Z,T)
    !     regions are identical and the orthogonal grids are UNIFORM
    !     in each direction then subroutine rgrd4u (see file rgrd4u.f)
    !     should be used instead of rgrd4.

    ! ... efficiency

    !     inner most loops in regridpack software vectorize. If
    !     the integer arguments mx,my,mz,mt (see below) have different values,
    !     optimal vectorization will be achieved if they are arranged so that
    !     mx > my > mz > mt.

    ! *** input arguments

    ! ... nx

    !     the integer dimension of the grid vector x and the first dimension of p.
    !     nx > 1 if intpol(1) = 1 or nx > 3 if intpol(1) = 3 is required.

    ! ... ny

    !     the integer dimension of the grid vector y and the second dimension of p.
    !     ny > 1 if intpol(2) = 1 or ny > 3 if intpol(2) = 3 is required.

    ! ... nz

    !     the integer dimension of the grid vector z and the third dimension of p.
    !     nz > 1 if intpol(3) = 1 or nz > 3 if intpol(3) = 3 is required.

    ! ... nt

    !     the integer dimension of the grid vector t and the fourth dimension of p.
    !     nt > 1 if intpol(4) = 1 or nt > 3 if intpol(4) = 3 is required.

    ! ... x

    !     a real (kind=8) nx vector of strictly increasing values which defines the x
    !     portion of the orthogonal grid on which p is given

    ! ... y

    !     a real (kind=8) ny vector of strictly increasing values which defines the y
    !     portion of the orthogonal grid on which p is given

    ! ... z

    !     a real (kind=8) nz vector of strictly increasing values which defines the z
    !     portion of the orthogonal grid on which p is given

    ! ... t

    !     a real (kind=8) nt vector of strictly increasing values which defines the t
    !     portion of the orthogonal grid on which p is given

    ! ... p

    !     a real (kind=8) nx by ny by nz by nt array of values given on the (x,y,z,t) grid

    ! ... mx

    !     the integer dimension of the grid vector xx and the first dimension
    !     of q.  mx > 0 is required.

    ! ... my

    !     the integer dimension of the grid vector yy and the second dimension
    !     of q.  my > 0 is required.

    ! ... mz

    !     the integer dimension of the grid vector zz and the third dimension
    !     of q.  mz > 0 is required.

    ! ... mt

    !     the integer dimension of the grid vector tt and the fourth dimension
    !     of q.  mt > 0 is required.

    ! ... xx

    !     a real (kind=8) mx vector of increasing values which defines the x portion of the
    !     orthogonal grid on which q is defined.  xx(1) < x(1) or xx(mx) > x(nx)
    !     is not allowed (see ier = 3)

    ! ... yy

    !     a real (kind=8) my vector of increasing values which defines the y portion of the
    !     orthogonal grid on which q is defined.  yy(1) < y(1) or yy(my) > y(ny)
    !     is not allowed (see ier = 3)

    ! ... zz

    !     a real (kind=8) mz vector of increasing values which defines the z portion of the
    !     orthogonal grid on which q is defined.  zz(1) < z(1) or zz(mz) > z(nz)
    !     is not allowed (see ier = 3)

    ! ... tt

    !     a real (kind=8) mt vector of increasing values which defines the t portion of the
    !     orthogonal grid on which q is defined.  tt(1) < t(1) or tt(mt) > t(nt)
    !     is not allowed (see ier = 3)

    ! ... intpol

    !     an integer vector of dimension 4 which sets linear or cubic
    !     interpolation in each of the x,y,z,t directions as follows:

    !        intpol(1) = 1 sets linear interpolation in the x direction
    !        intpol(1) = 3 sets cubic interpolation in the x direction.

    !        intpol(2) = 1 sets linear interpolation in the y direction
    !        intpol(2) = 3 sets cubic interpolation in the y direction.

    !        intpol(3) = 1 sets linear interpolation in the z direction
    !        intpol(3) = 3 sets cubic interpolation in the z direction.

    !        intpol(4) = 1 sets linear interpolation in the t direction
    !        intpol(4) = 3 sets cubic interpolation in the t direction.

    !     values other than 1 or 3 in intpol are not allowed (ier = 6).

    ! ... w

    !     a real (kind=8) work space of length at least lw which must be provided in the
    !     routine calling rgrd4

    ! ... lw

    !     the integer length of the real (kind=8) work space w.  let

    !          lwx =   mx            if intpol(1) = 1
    !          lwx = 4*mx            if intpol(1) = 3

    !          lwy = my+2*mx         if intpol(2) = 1
    !          lwy = 4*(my+mx)       if intpol(2) = 3

    !          lwz = 2*mx*my+mz      if intpol(3) = 1
    !          lwz = 4*(mx*my+mz)    if intpol(3) = 3

    !          lwt = 2*mx*my*mz+mt   if intpol(4) = 1
    !          lwt = 4*(mx*my*mz+mt) if intpol(4) = 3

    !     then lw must be greater than or equal to lwx+lwy+lwz+lwt

    ! ... iw

    !     an integer work space of length at least liw which must be provided in the
    !     routine calling rgrd4

    ! ... liw

    !     the integer length of the integer work space iw.  liw must be at least mx+my+mz+mt

    ! *** output arguments

    ! ... q

    !     a real (kind=8) mx by my by mz by mt array of values on the (xx,yy,zz,tt) grid
    !     which are interpolated from p on the (x,y,z,t) grid

    ! ... ier

    !     an integer error flag set as follows:

    !     ier = 0 if no errors in input arguments are detected

    !     ier = 1 if  min0(mx,my,mz,mt) < 1

    !     ier = 2 if nx < 2 when intpol(1)=1 or nx < 4 when intpol(1)=3 (or)
    !                ny < 2 when intpol(2)=1 or ny < 4 when intpol(2)=3 (or)
    !                nz < 2 when intpol(3)=1 or nz < 4 when intpol(3)=3 (or)
    !                nt < 2 when intpol(4)=1 or nt < 4 when intpol(4)=3

    !     ier = 3 if xx(1) < x(1) or x(nx) < xx(mx) (or)
    !                yy(1) < y(1) or y(ny) < yy(my) (or)
    !                zz(1) < z(1) or z(nz) < zz(mz) (or)
    !                tt(1) < t(1) or t(nt) < tt(mt)

    ! *** to avoid this flag when end points are intended to be the
    !     same but may differ slightly due to roundoff error, they
    !     should be set exactly in the calling routine (e.g., if both
    !     grids have the same y boundaries then yy(1)=y(1) and yy(my)=y(ny)
    !     should be set before calling rgrd4)

    !     ier = 4 if one of the grids x,y,z,t is not strictly monotonically
    !             increasing or if one of the grids xx,yy,zz,tt is not
    !             montonically increasing.  more precisely if:

    !             x(i+1) <= x(i) for some i such that 1 <= i < nx (or)

    !             y(j+1) <= y(j) for some j such that 1 <= j < ny (or)

    !             z(k+1) <= z(k) for some k such that 1 <= k < nz (or)

    !             t(l+1) <= t(l) for some l such that 1 <= l < nt (or)

    !             xx(ii+1) < xx(ii) for some ii such that 1 <= ii < mx (or)

    !             yy(jj+1) < yy(jj) for some jj such that 1 <= jj < my (or)

    !             zz(kk+1) < zz(k)  for some kk such that 1 <= kk < mz (or)

    !             tt(ll+1) < tt(l)  for some ll such that 1 <= ll < mt

    !     ier = 5 if lw or liw is too small (insufficient work space)

    !     ier = 6 if any of intpol(1),intpol(2),intpol(3),intpol(4)
    !             is not equal to 1 or 3

    ! ************************************************************************

    !     end of rgrd4 documentation, fortran code follows:

    ! ************************************************************************

    SUBROUTINE rgrd4(nx,ny,nz,nt,x,y,z,t,p,mx,my,mz,mt,xx,yy,zz,  &
        tt,q,intpol,w,lw,iw,liw,ier)

    IMPLICIT NONE
    INTEGER, INTENT(IN)                      :: nx
    INTEGER, INTENT(IN)                      :: ny
    INTEGER, INTENT(IN)                      :: nz
    INTEGER, INTENT(IN)                      :: nt
    real (kind=8), INTENT(IN)                :: x(nx)
    real (kind=8), INTENT(IN)                :: y(ny)
    real (kind=8), INTENT(IN)                :: z(nz)
    real (kind=8), INTENT(IN)                :: t(nt)
    real (kind=8), INTENT(IN)                :: p(nx,ny,nz,nt)
    INTEGER, INTENT(IN)                      :: mx
    INTEGER, INTENT(IN)                      :: my
    INTEGER, INTENT(IN)                      :: mz
    INTEGER, INTENT(IN)                      :: mt
    real (kind=8), INTENT(IN)                :: xx(mx)
    real (kind=8), INTENT(IN)                :: yy(my)
    real (kind=8), INTENT(IN)                :: zz(mz)
    real (kind=8), INTENT(IN)                :: tt(mt)
    real (kind=8), INTENT(OUT)               :: q(mx,my,mz,mt)
    INTEGER, INTENT(IN)                      :: intpol(4)
    real (kind=8), INTENT(INOUT)             :: w(lw)
    INTEGER, INTENT(IN)                      :: lw
    INTEGER, INTENT(IN OUT)                  :: iw(liw)
    INTEGER, INTENT(IN)                      :: liw
    INTEGER, INTENT(OUT)                     :: ier

    INTEGER :: l2,l3,l4,l5,l6,l7,l8,l9
    INTEGER :: k2,k3,k4,k5,k6,k7,k8,k9
    INTEGER :: j2,j3,j4,j5,j6,j7,j8,j9
    INTEGER :: i2,i3,i4,i5
    INTEGER :: lwx,lwy,lwz,lwt,mxmy,mxmymz
    INTEGER :: ii,jj,kk,ll,i,j,k,l
    INTEGER :: jy,kz,LT

    !     check input arguments

    ier = 1

    !     check (xx,yy,zz,tt) grid resolution

    IF (MIN0(mx,my,mz,mt) < 1) RETURN

    !     check intpol

    ier = 6
    IF (intpol(1) /= 1 .AND. intpol(1) /= 3) RETURN
    IF (intpol(2) /= 1 .AND. intpol(2) /= 3) RETURN
    IF (intpol(3) /= 1 .AND. intpol(3) /= 3) RETURN
    IF (intpol(4) /= 1 .AND. intpol(4) /= 3) RETURN

    !     check (x,y,z,t) grid resolution

    ier = 2
    IF (intpol(1) == 1 .AND. nx < 2) RETURN
    IF (intpol(1) == 3 .AND. nx < 4) RETURN
    IF (intpol(2) == 1 .AND. ny < 2) RETURN
    IF (intpol(2) == 3 .AND. ny < 4) RETURN
    IF (intpol(3) == 1 .AND. nz < 2) RETURN
    IF (intpol(3) == 3 .AND. nz < 4) RETURN
    IF (intpol(4) == 1 .AND. nt < 2) RETURN
    IF (intpol(4) == 3 .AND. nt < 4) RETURN

    !     check work space length input and set minimum

    ier = 5
    mxmy = mx*my
    mxmymz = mxmy*mz
    IF (intpol(1) == 1) THEN
      lwx = mx
    ELSE
      lwx = 4*mx
    END IF
    IF (intpol(2) == 1) THEN
      lwy = (my+2*mx)
    ELSE
      lwy = 4*(mx+my)
    END IF
    IF (intpol(3) == 1) THEN
      lwz = (2*mxmy+mz)
    ELSE
      lwz = 4*(mxmy+mz)
    END IF
    IF (intpol(4) == 1) THEN
      lwt = (2*mxmymz+mt)
    ELSE
      lwt = 4*(mxmymz+mt)
    END IF
    IF (lw < lwx+lwy+lwz+lwt) RETURN
    IF (liw < mx+my+mz+mt) RETURN

    !     check (xx,yy,zz,tt) grid contained in (x,y,z,t) grid

    ier = 3
    IF (xx(1) < x(1) .OR. xx(mx) > x(nx)) RETURN
    IF (yy(1) < y(1) .OR. yy(my) > y(ny)) RETURN
    IF (zz(1) < z(1) .OR. zz(mz) > z(nz)) RETURN
    IF (tt(1) < t(1) .OR. tt(mt) > t(nt)) RETURN

    !     check montonicity of grids

    ier = 4
    DO i=2,nx
      IF (x(i-1) >= x(i)) RETURN
    END DO
    DO j=2,ny
      IF (y(j-1) >= y(j)) RETURN
    END DO
    DO k=2,nz
      IF (z(k-1) >= z(k)) RETURN
    END DO
    DO l=2,nt
      IF (t(l-1) >= t(l)) RETURN
    END DO
    DO ii=2,mx
      IF (xx(ii-1) > xx(ii)) RETURN
    END DO
    DO jj=2,my
      IF (yy(jj-1) > yy(jj)) RETURN
    END DO
    DO kk=2,mz
      IF (zz(kk-1) > zz(kk)) RETURN
    END DO
    DO ll=2,mt
      IF (tt(ll-1) > tt(ll)) RETURN
    END DO

    !     arguments o.k.

    ier = 0

    !     set pointers for integer work space iw

    jy = mx+1
    kz = mx+my+1
    LT = mx+my+mz+1

    IF (intpol(4) == 1) THEN

    !     linearly interpolate in nt, set work space pointers and scales

      l2 = 1
      l3 = l2
      l4 = l3+mt
      l5 = l4
      l6 = l5
      l7 = l6
      l8 = l7+mxmymz
      l9 = l8+mxmymz
      CALL linmx(nt,t,mt,tt,iw(LT),w(l3))
      k2 = l9

      IF (intpol(3) == 1) THEN
    !     linear in z
        k3 = k2
        k4 = k3+mz
        k5 = k4
        k6 = k5
        k7 = k6
        k8 = k7+mxmy
        k9 = k8+mxmy
        CALL linmx(nz,z,mz,zz,iw(kz),w(k3))
        j2 = k9
      ELSE
    !     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 cubnmx(nz,z,mz,zz,iw(kz),w(k2),w(k3),w(k4),w(k5))
        j2 = k9+mxmy
      END IF

      IF (intpol(2) == 1) THEN
    !     linear in y
        j3 = j2
        j4 = j3+my
        j5 = j4
        j6 = j5
        j7 = j6
        j8 = j7+mx
        j9 = j8+mx
        CALL linmx(ny,y,my,yy,iw(jy),w(j3))
        i2 = j9
      ELSE
    !     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 cubnmx(ny,y,my,yy,iw(jy),w(j2),w(j3),w(j4),w(j5))
        i2 = j9+mx
      END IF

      IF (intpol(1) == 1) THEN
    !     linear in x
        i3 = i2
        i4 = i3
        i5 = i4
        CALL linmx(nx,x,mx,xx,iw,w(i3))
      ELSE
    !     cubic in x
        i3 = i2+mx
        i4 = i3+mx
        i5 = i4+mx
        CALL cubnmx(nx,x,mx,xx,iw,w(i2),w(i3),w(i4),w(i5))
      END IF

    !     linearly interpolate in t

      CALL lint4(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))
      RETURN

    ELSE

    !     cubically interpolate in t

      l2 = 1
      l3 = l2+mt
      l4 = l3+mt
      l5 = l4+mt
      l6 = l5+mt
      l7 = l6+mxmymz
      l8 = l7+mxmymz
      l9 = l8+mxmymz
      CALL cubnmx(nt,t,mt,tt,iw(LT),w(l2),w(l3),w(l4),w(l5))
      k2 = l9+mxmymz

      IF (intpol(3) == 1) THEN
    !     linear in z
        k3 = k2
        k4 = k3+mz
        k5 = k4
        k6 = k5
        k7 = k6
        k8 = k7+mxmy
        k9 = k8+mxmy
        CALL linmx(nz,z,mz,zz,iw(kz),w(k3))
        j2 = k9
      ELSE
    !     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 cubnmx(nz,z,mz,zz,iw(kz),w(k2),w(k3),w(k4),w(k5))
        j2 = k9+mxmy
      END IF

      IF (intpol(2) == 1) THEN
        j3 = j2
        j4 = j3+my
        j5 = j4
        j6 = j5
        j7 = j6
        j8 = j7+mx
        j9 = j8+mx
        CALL linmx(ny,y,my,yy,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 cubnmx(ny,y,my,yy,iw(jy),w(j2),w(j3),w(j4),w(j5))
        i2 = j9+mx
      END IF

    !     set work space portion and indices which depend on x interpolation

      IF (intpol(1) == 1) THEN
        i3 = i2
        i4 = i3
        i5 = i4
        CALL linmx(nx,x,mx,xx,iw,w(i3))
      ELSE
        i3 = i2+mx
        i4 = i3+mx
        i5 = i4+mx
        CALL cubnmx(nx,x,mx,xx,iw,w(i2),w(i3),w(i4),w(i5))
      END IF

    !     cubically interpolate in t

      CALL cubt4(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))
      RETURN

    END IF
    END SUBROUTINE rgrd4

    SUBROUTINE lint4(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)

    !     linearly interpolate in t direction

    IMPLICIT NONE
    INTEGER, INTENT(IN)                      :: nx
    INTEGER, INTENT(IN)                      :: ny
    INTEGER, INTENT(IN)                      :: nz
    INTEGER, INTENT(IN)                      :: nt
    real (kind=8), INTENT(IN)                :: p(nx,ny,nz,nt)
    INTEGER, INTENT(IN)                      :: mx
    INTEGER, INTENT(IN)                      :: my
    INTEGER, INTENT(IN)                      :: mz
    INTEGER, INTENT(IN)                      :: mt
    INTEGER, INTENT(IN OUT)                  :: mxmy
    INTEGER, INTENT(IN)                      :: mxmymz
    real (kind=8), INTENT(OUT)               :: q(mxmymz,mt)
    INTEGER, INTENT(IN)                      :: intpol(4)
    INTEGER, INTENT(IN)                      :: LT(mt)
    real (kind=8), INTENT(IN)                :: dt(mt)
    real (kind=8), INTENT(OUT)               :: pt(mxmymz)
    real (kind=8), INTENT(IN OUT)            :: ptp(mxmymz)
    INTEGER, INTENT(IN OUT)                  :: kz(mz)
    real (kind=8), INTENT(IN OUT)            :: dzm(mz)
    real (kind=8), INTENT(IN OUT)            :: dz(mz)
    real (kind=8), INTENT(IN OUT)            :: dzp(mz)
    real (kind=8), INTENT(IN OUT)            :: dzpp(mz)
    real (kind=8), INTENT(IN OUT)            :: pkm(mxmy)
    real (kind=8), INTENT(IN OUT)            :: pk(mxmy)
    real (kind=8), INTENT(IN OUT)            :: pkp(mxmy)
    real (kind=8), INTENT(IN OUT)            :: pkpp(mxmy)
    INTEGER, INTENT(IN OUT)                  :: jy(my)
    real (kind=8), INTENT(IN OUT)            :: dym(my)
    real (kind=8), INTENT(IN OUT)            :: dy(my)
    real (kind=8), INTENT(IN OUT)            :: dyp(my)
    real (kind=8), INTENT(IN OUT)            :: dypp(my)
    real (kind=8), INTENT(IN OUT)            :: pjm(mx)
    real (kind=8), INTENT(IN OUT)            :: pj(mx)
    real (kind=8), INTENT(IN OUT)            :: pjp(mx)
    real (kind=8), INTENT(IN OUT)            :: pjpp(mx)
    INTEGER, INTENT(IN OUT)                  :: ix(mx)
    real (kind=8), INTENT(IN OUT)            :: dxm(mx)
    real (kind=8), INTENT(IN OUT)            :: dx(mx)
    real (kind=8), INTENT(IN OUT)            :: dxp(mx)
    real (kind=8), INTENT(IN OUT)            :: dxpp(mx)
    INTEGER :: lsave,ll,l,iijjkk

    IF (intpol(3) == 1) THEN

    !     linear in z

      lsave = -1
      DO ll=1,mt
        l = LT(ll)
        IF (l == lsave) THEN

    !     l pointer has not moved since last pass (no updates or interpolation)

        ELSE IF (l == lsave+1) THEN

    !     update l and interpolate l+1

          DO iijjkk=1,mxmymz
            pt(iijjkk) = ptp(iijjkk)
          END DO
          CALL lint3(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)
        ELSE

    !     interpolate l,l+1 in pt,ptp on xx,yy,zz mesh

          CALL lint3(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)
          CALL lint3(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)
        END IF

    !     save l pointer for next pass

        lsave = l

    !     linearly interpolate q(ii,jj,,kk,ll) from pt,ptp in t direction

        DO iijjkk=1,mxmymz
          q(iijjkk,ll) = pt(iijjkk)+dt(ll)*(ptp(iijjkk)-pt(iijjkk))
        END DO
      END DO
      RETURN

    ELSE

    !     cubic in z

      lsave = -1
      DO ll=1,mt
        l = LT(ll)
        IF (l == lsave) THEN

    !     l pointer has not moved since last pass (no updates or interpolation)

        ELSE IF (l == lsave+1) THEN

    !     update l and interpolate l+1

          DO iijjkk=1,mxmymz
            pt(iijjkk) = ptp(iijjkk)
          END DO
          CALL cubt3(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)
        ELSE

    !     interpolate l,l+1 in pt,ptp on xx,yy,zz mesh

          CALL cubt3(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)
          CALL cubt3(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)
        END IF

    !     save l pointer for next pass

        lsave = l

    !     linearly interpolate q(ii,jj,kk,ll) from pt,ptp in t direction

        DO iijjkk=1,mxmymz
          q(iijjkk,ll) = pt(iijjkk)+dt(ll)*(ptp(iijjkk)-pt(iijjkk))
        END DO

      END DO
      RETURN

    END IF
    END SUBROUTINE lint4

    SUBROUTINE cubt4(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)

    !     cubically interpolate in t

    IMPLICIT NONE
    INTEGER, INTENT(IN)                      :: nx
    INTEGER, INTENT(IN)                      :: ny
    INTEGER, INTENT(IN)                      :: nz
    INTEGER, INTENT(IN)                      :: nt
    real (kind=8), INTENT(IN)                :: p(nx,ny,nz,nt)
    INTEGER, INTENT(IN)                      :: mx
    INTEGER, INTENT(IN)                      :: my
    INTEGER, INTENT(IN)                      :: mz
    INTEGER, INTENT(IN)                      :: mt
    INTEGER, INTENT(IN OUT)                  :: mxmy
    INTEGER, INTENT(IN)                      :: mxmymz
    real (kind=8), INTENT(OUT)               :: q(mxmymz,mt)
    INTEGER, INTENT(IN)                      :: intpol(4)
    INTEGER, INTENT(IN)                      :: LT(mt)
    real (kind=8), INTENT(IN)                :: dtm(mt)
    real (kind=8), INTENT(IN)                :: dt(mt)
    real (kind=8), INTENT(IN OUT)            :: dtp(mt)
    real (kind=8), INTENT(IN OUT)            :: dtpp(mt)
    real (kind=8), INTENT(OUT)               :: ptm(mxmymz)
    real (kind=8), INTENT(IN OUT)            :: pt(mxmymz)
    real (kind=8), INTENT(IN OUT)            :: ptp(mxmymz)
    real (kind=8), INTENT(IN OUT)            :: ptpp(mxmymz)
    INTEGER, INTENT(IN OUT)                  :: kz(mz)
    real (kind=8), INTENT(IN OUT)            :: dzm(mz)
    real (kind=8), INTENT(IN OUT)            :: dz(mz)
    real (kind=8), INTENT(IN OUT)            :: dzp(mz)
    real (kind=8), INTENT(IN OUT)            :: dzpp(mz)
    real (kind=8), INTENT(IN OUT)            :: pkm(mxmy)
    real (kind=8), INTENT(IN OUT)            :: pk(mxmy)
    real (kind=8), INTENT(IN OUT)            :: pkp(mxmy)
    real (kind=8), INTENT(IN OUT)            :: pkpp(mxmy)
    INTEGER, INTENT(IN OUT)                  :: jy(my)
    real (kind=8), INTENT(IN OUT)            :: dym(my)
    real (kind=8), INTENT(IN OUT)            :: dy(my)
    real (kind=8), INTENT(IN OUT)            :: dyp(my)
    real (kind=8), INTENT(IN OUT)            :: dypp(my)
    real (kind=8), INTENT(IN OUT)            :: pjm(mx)
    real (kind=8), INTENT(IN OUT)            :: pj(mx)
    real (kind=8), INTENT(IN OUT)            :: pjp(mx)
    real (kind=8), INTENT(IN OUT)            :: pjpp(mx)
    INTEGER, INTENT(IN OUT)                  :: ix(mx)
    real (kind=8), INTENT(IN OUT)            :: dxm(mx)
    real (kind=8), INTENT(IN OUT)            :: dx(mx)
    real (kind=8), INTENT(IN OUT)            :: dxp(mx)
    real (kind=8), INTENT(IN OUT)            :: dxpp(mx)
    INTEGER :: lsave,ll,l,iijjkk

    IF (intpol(3) == 1) THEN

    !     linear in z

      lsave = -3
      DO ll=1,mt
        l = LT(ll)
        IF (l == lsave) THEN

    !     l pointer has not moved since last pass (no updates or interpolation)

        ELSE IF (l == lsave+1) THEN

    !     update l-1,l,l+1 and interpolate l+2

          DO iijjkk=1,mxmymz
            ptm(iijjkk) = pt(iijjkk)
            pt(iijjkk) = ptp(iijjkk)
            ptp(iijjkk) = ptpp(iijjkk)
          END DO
          CALL lint3(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)
        ELSE IF (l == lsave+2) THEN

    !     update l-1,l and interpolate l+1,l+2

          DO iijjkk=1,mxmymz
            ptm(iijjkk) = ptp(iijjkk)
            pt(iijjkk) = ptpp(iijjkk)
          END DO
          CALL lint3(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)
          CALL lint3(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)
        ELSE IF (l == lsave+3) THEN

    !     update l-1 and interpolate l,l+1,l+2

          DO iijjkk=1,mxmymz
            ptm(iijjkk) = ptpp(iijjkk)
          END DO
          CALL lint3(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)
          CALL lint3(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)
          CALL lint3(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)
        ELSE

    !     interpolate all four l-1,l,l+1,l+2

          CALL lint3(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)
          CALL lint3(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)
          CALL lint3(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)
          CALL lint3(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)
        END IF

    !     save l pointer for next pass

        lsave = l

    !     cubically interpolate q(ii,jj,kk,ll) from ptm,pt,ptp,ptpp in t direction

        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

    !     cubic in z

      lsave = -3
      DO ll=1,mt
        l = LT(ll)
        IF (l == lsave) THEN

    !     l pointer has not moved since last pass (no updates or interpolation)

        ELSE IF (l == lsave+1) THEN

    !     update l-1,l,l+1 and interpolate l+2

          DO iijjkk=1,mxmymz
            ptm(iijjkk) = pt(iijjkk)
            pt(iijjkk) = ptp(iijjkk)
            ptp(iijjkk) = ptpp(iijjkk)
          END DO
          CALL cubt3(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)
        ELSE IF (l == lsave+2) THEN

    !     update l-1,l and interpolate l+1,l+2

          DO iijjkk=1,mxmymz
            ptm(iijjkk) = ptp(iijjkk)
            pt(iijjkk) = ptpp(iijjkk)
          END DO
          CALL cubt3(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)
          CALL cubt3(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)
        ELSE IF (l == lsave+3) THEN

    !     update l-1 and interpolate l,l+1,l+2

          DO iijjkk=1,mxmymz
            ptm(iijjkk) = ptpp(iijjkk)
          END DO
          CALL cubt3(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)
          CALL cubt3(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)
          CALL cubt3(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)
        ELSE

    !     interpolate all four l-1,l,l+1,l+2

          CALL cubt3(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)
          CALL cubt3(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)
          CALL cubt3(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)
          CALL cubt3(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)
        END IF

    !     save l pointer for next pass

        lsave = l

    !     cubically interpolate q(ii,jj,kk,ll) from ptm,pt,ptp,ptpp in t direction

        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 SUBROUTINE cubt4
end module