      SUBROUTINE MB01RB( SIDE, UPLO, TRANS, M, N, ALPHA, BETA, R, LDR,
     $                   A, LDA, B, LDB, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute either the upper or lower triangular part of one of the
C     matrix formulas
C        _
C        R = alpha*R + beta*op( A )*B,                               (1)
C        _
C        R = alpha*R + beta*B*op( A ),                               (2)
C                                             _
C     where alpha and beta are scalars, R and R are m-by-m matrices,
C     op( A ) and B are m-by-n and n-by-m matrices for (1), or n-by-m
C     and m-by-n matrices for (2), respectively, and op( A ) is one of
C
C        op( A ) = A   or   op( A ) = A',  the transpose of A.
C
C     The result is overwritten on R.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     SIDE    CHARACTER*1
C             Specifies whether the matrix A appears on the left or
C             right in the matrix product as follows:
C                     _
C             = 'L':  R = alpha*R + beta*op( A )*B;
C                     _
C             = 'R':  R = alpha*R + beta*B*op( A ).
C
C     UPLO    CHARACTER*1                               _
C             Specifies which triangles of the matrices R and R are
C             computed and given, respectively, as follows:
C             = 'U':  the upper triangular part;
C             = 'L':  the lower triangular part.
C
C     TRANS   CHARACTER*1
C             Specifies the form of op( A ) to be used in the matrix
C             multiplication as follows:
C             = 'N':  op( A ) = A;
C             = 'T':  op( A ) = A';
C             = 'C':  op( A ) = A'.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER           _
C             The order of the matrices R and R, the number of rows of
C             the matrix op( A ) and the number of columns of the
C             matrix B, for SIDE = 'L', or the number of rows of the
C             matrix B and the number of columns of the matrix op( A ),
C             for SIDE = 'R'.  M >= 0.
C
C     N       (input) INTEGER
C             The number of rows of the matrix B and the number of
C             columns of the matrix op( A ), for SIDE = 'L', or the
C             number of rows of the matrix op( A ) and the number of
C             columns of the matrix B, for SIDE = 'R'.  N >= 0.
C
C     ALPHA   (input) DOUBLE PRECISION
C             The scalar alpha. When alpha is zero then R need not be
C             set before entry.
C
C     BETA    (input) DOUBLE PRECISION
C             The scalar beta. When beta is zero then A and B are not
C             referenced.
C
C     R       (input/output) DOUBLE PRECISION array, dimension (LDR,M)
C             On entry with UPLO = 'U', the leading M-by-M upper
C             triangular part of this array must contain the upper
C             triangular part of the matrix R; the strictly lower
C             triangular part of the array is not referenced.
C             On entry with UPLO = 'L', the leading M-by-M lower
C             triangular part of this array must contain the lower
C             triangular part of the matrix R; the strictly upper
C             triangular part of the array is not referenced.
C             On exit, the leading M-by-M upper triangular part (if
C             UPLO = 'U'), or lower triangular part (if UPLO = 'L') of
C             this array contains the corresponding triangular part of
C                                 _
C             the computed matrix R.
C
C     LDR     INTEGER
C             The leading dimension of array R.  LDR >= MAX(1,M).
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,k), where
C             k = N  when  SIDE = 'L', and TRANS =  'N', or
C                          SIDE = 'R', and TRANS <> 'T';
C             k = M  when  SIDE = 'R', and TRANS = 'N', or
C                          SIDE = 'L', and TRANS <> 'T'.
C             On entry, if SIDE = 'L', and TRANS =  'N', or
C                          SIDE = 'R', and TRANS <> 'T',
C             the leading M-by-N part of this array must contain the
C             matrix A.
C             On entry, if SIDE = 'R', and TRANS =  'N', or
C                          SIDE = 'L', and TRANS <> 'T',
C             the leading N-by-M part of this array must contain the
C             matrix A.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,l), where
C             l = M  when  SIDE = 'L', and TRANS =  'N', or
C                          SIDE = 'R', and TRANS <> 'T';
C             l = N  when  SIDE = 'R', and TRANS =  'N', or
C                          SIDE = 'L', and TRANS <> 'T'.
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,p), where
C             p = M  when  SIDE = 'L';
C             p = N  when  SIDE = 'R'.
C             On entry, the leading N-by-M part, if SIDE = 'L', or
C             M-by-N part, if SIDE = 'R', of this array must contain the
C             matrix B.
C
C     LDB     INTEGER
C             The leading dimension of array B.
C             LDB >= MAX(1,N), if SIDE = 'L';
C             LDB >= MAX(1,M), if SIDE = 'R'.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The matrix expression is evaluated taking the triangular
C     structure into account. A block algorithm is used.
C
C     FURTHER COMMENTS
C
C     The main application of this routine is when the result should
C     be a symmetric matrix, e.g., when B = X*op( A )', for (1), or
C     B = op( A )'*X, for (2), where B is already available and X = X'.
C     The required triangle only is computed and overwritten, contrary
C     to a general matrix multiplication operation.
C
C     This is a BLAS 3 version of the SLICOT Library routine MB01RX.
C
C     CONTRIBUTORS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2013.
C
C     REVISIONS
C
C     V. Sima, Jul. 2013.
C
C     KEYWORDS
C
C     Elementary matrix operations, matrix algebra, matrix operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C                       NBS is a value used to switch from small to
C                       large block sizes.
C                       N1P is a block size to be used for large
C                       matrices when SIDE = 'L' and TRANS = 'T', and
C                       N1L is a minimum block size N1 in this case.
C                       N2P and N2L are similar block sizes for N2,
C                       used when SIDE and TRANS have other values.
      INTEGER           N1L, N1P, N2L, N2P, NBS
      PARAMETER         ( N1L = 128, N1P = 512, N2L = 40, N2P = 128,
     $                    NBS = 48 )
C     .. Scalar Arguments ..
      CHARACTER         SIDE, TRANS, UPLO
      INTEGER           INFO, LDA, LDB, LDR, M, N
      DOUBLE PRECISION  ALPHA, BETA
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), R(LDR,*)
C     .. Local Scalars ..
      LOGICAL           LSIDE, LTRANS, LUPLO
      INTEGER           I, IB, J, JB, MN, MX, N1, N2, NB, NBMIN, NX
C     .. Local Arrays ..
      DOUBLE PRECISION  D(1)
C     .. External Functions ..
      LOGICAL           LSAME
      INTEGER           ILAENV
      EXTERNAL          ILAENV, LSAME
C     .. External Subroutines ..
      EXTERNAL          DGEMM, DGEQRF, DLASCL, DLASET, MB01RX, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX, MIN
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO   = 0
      LSIDE  = LSAME( SIDE,  'L' )
      LUPLO  = LSAME( UPLO,  'U' )
      LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
C
      IF(      ( .NOT.LSIDE  ).AND.( .NOT.LSAME( SIDE,  'R' ) ) )THEN
         INFO = -1
      ELSE IF( ( .NOT.LUPLO  ).AND.( .NOT.LSAME( UPLO,  'L' ) ) )THEN
         INFO = -2
      ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDR.LT.MAX( 1, M ) ) THEN
         INFO = -9
      ELSE IF( LDA.LT.1 .OR.
     $   ( ( (      LSIDE .AND. .NOT.LTRANS ) .OR.
     $       ( .NOT.LSIDE .AND.      LTRANS ) ) .AND. LDA.LT.M ) .OR.
     $   ( ( (      LSIDE .AND.      LTRANS ) .OR.
     $       ( .NOT.LSIDE .AND. .NOT.LTRANS ) ) .AND. LDA.LT.N ) ) THEN
         INFO = -11
      ELSE IF( LDB.LT.1 .OR.
     $       (      LSIDE .AND. LDB.LT.N ) .OR.
     $       ( .NOT.LSIDE .AND. LDB.LT.M ) ) THEN
         INFO = -13
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB01RB', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( M.EQ.0 )
     $   RETURN
C
      IF ( BETA.EQ.ZERO .OR. N.EQ.0 ) THEN
         IF ( ALPHA.EQ.ZERO ) THEN
C
C           Special case alpha = 0.
C
            CALL DLASET( UPLO, M, M, ZERO, ZERO, R, LDR )
         ELSE
C
C           Special case beta = 0 or N = 0.
C
            IF ( ALPHA.NE.ONE )
     $         CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, M, M, R, LDR, INFO )
         END IF
         RETURN
      END IF
C
C     General case: beta <> 0.
C     Compute the required triangle of (1) or (2) using essentially
C     BLAS 3 operations.
C
C     Find the block size using DGEQRF.
C
      MX = MAX( M, N )
      MN = MIN( M, N )
      CALL DGEQRF( MX, MN, A, MX, D, D, -1, INFO )
      NB = INT( D(1) )/MN/8*8
C
      IF( NB.GT.1 .AND. NB.LT.M ) THEN
C
C        Determine when to cross over from blocked to unblocked code.
C
         NX = MAX( 0, ILAENV( 3, 'DGEQRF', ' ', MX, MN, -1, -1 ) )
         IF( NX.LT.M ) THEN
C
C           Determine the minimum value of NB.
C
            NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', MX, MN, -1, -1 ) )
         END IF
      ELSE
         NX    = 0
         NBMIN = 2
      END IF
C
      IF( NB.GE.NBMIN .AND. NB.LT.M .AND. NX.LT.M ) THEN
C
C        Use blocked code initially.
C
         IF( LTRANS .AND. LSIDE ) THEN
            IF( NB.LE.NBS ) THEN
               N1 = MIN( MAX( N1L, NB ), N )
            ELSE
               N1 = MIN( N1P, N )
            END IF
         ELSE
            IF( NB.LE.NBS ) THEN
               N2 = MIN( MAX( N2L, NB ), N )
            ELSE
               N2 = MIN( N2P, N )
            END IF
         END IF
C
         DO 50 I = 1, M - NX, NB
            IB = I + NB
            JB = MIN( M-I+1, NB )
C
C           Compute the current diagonal block and the needed off-
C           diagonal part of the current block row, if UPLO = 'U',
C           or block column, if UPLO = 'L'.
C
            IF( LTRANS ) THEN
               IF( LSIDE ) THEN
                  CALL MB01RX( SIDE, UPLO, TRANS, JB, N1, ALPHA, BETA,
     $                         R(I,I), LDR, A(1,I), LDA, B(1,I), LDB,
     $                         INFO )
                  DO 10 J = N1+1, N, N1
                     CALL MB01RX( SIDE, UPLO, TRANS, JB, MIN(N1, N-J+1),
     $                            ONE, BETA, R(I,I), LDR, A(J,I), LDA,
     $                            B(J,I), LDB, INFO )
   10             CONTINUE
                  IF( IB.LE.M ) THEN
                     IF( LUPLO ) THEN
                        CALL DGEMM( TRANS, 'No transpose', JB, M-IB+1,
     $                              N, BETA, A(1,I), LDA, B(1,IB), LDB,
     $                              ALPHA, R(I,IB), LDR )
                     ELSE
                        CALL DGEMM( TRANS, 'No transpose', M-IB+1, JB,
     $                              N, BETA, A(1,IB), LDA, B(1,I), LDB,
     $                              ALPHA, R(IB,I), LDR )
                     END IF
                  END IF
               ELSE
                  CALL MB01RX( SIDE, UPLO, TRANS, JB, N2, ALPHA, BETA,
     $                         R(I,I), LDR, A(I,1), LDA, B(I,1), LDB,
     $                         INFO )
                  DO 20 J = N2+1, N, N2
                     CALL MB01RX( SIDE, UPLO, TRANS, JB, MIN(N2, N-J+1),
     $                            ONE, BETA, R(I,I), LDR, A(I,J), LDA,
     $                            B(I,J), LDB, INFO )
   20             CONTINUE
                  IF( IB.LE.M ) THEN
                     IF( LUPLO ) THEN
                        CALL DGEMM( 'No transpose', TRANS, JB, M-IB+1,
     $                              N, BETA, B(I,1), LDB, A(IB,1), LDA,
     $                              ALPHA, R(I,IB), LDR )
                     ELSE
                        CALL DGEMM( 'No transpose', TRANS, M-IB+1, JB,
     $                              N, BETA, B(IB,1), LDB, A(I,1), LDA,
     $                              ALPHA, R(IB,I), LDR )
                     END IF
                  END IF
               END IF
            ELSE
               IF( LSIDE ) THEN
                  CALL MB01RX( SIDE, UPLO, TRANS, JB, N2, ALPHA, BETA,
     $                         R(I,I), LDR, A(I,1), LDA, B(1,I), LDB,
     $                         INFO )
                  DO 30 J = N2+1, N, N2
                     CALL MB01RX( SIDE, UPLO, TRANS, JB, MIN(N2, N-J+1),
     $                            ONE, BETA, R(I,I), LDR, A(I,J), LDA,
     $                            B(J,I), LDB, INFO )
   30             CONTINUE
                  IF( IB.LE.M ) THEN
                     IF( LUPLO ) THEN
                        CALL DGEMM( TRANS, 'No transpose', JB, M-IB+1,
     $                              N, BETA, A(I,1), LDA, B(1,IB), LDB,
     $                              ALPHA, R(I,IB), LDR )
                     ELSE
                        CALL DGEMM( TRANS, 'No transpose', M-IB+1, JB,
     $                              N, BETA, A(IB,1), LDA, B(1,I), LDB,
     $                              ALPHA, R(IB,I), LDR )
                     END IF
                  END IF
               ELSE
                  CALL MB01RX( SIDE, UPLO, TRANS, JB, N2, ALPHA, BETA,
     $                         R(I,I), LDR, A(1,I), LDA, B(I,1), LDB,
     $                         INFO )
                  DO 40 J = N2+1, N, N2
                     CALL MB01RX( SIDE, UPLO, TRANS, JB, MIN(N2, N-J+1),
     $                            ONE, BETA, R(I,I), LDR, A(J,I), LDA,
     $                            B(I,J), LDB, INFO )
   40             CONTINUE
                  IF( IB.LE.M ) THEN
                     IF( LUPLO ) THEN
                        CALL DGEMM( 'No transpose', TRANS, JB, M-IB+1,
     $                              N, BETA, B(I,1), LDB, A(1,IB), LDA,
     $                              ALPHA, R(I,IB), LDR )
                     ELSE
                        CALL DGEMM( 'No transpose', TRANS, M-IB+1, JB,
     $                              N, BETA, B(IB,1), LDB, A(1,I), LDA,
     $                              ALPHA, R(IB,I), LDR )
                     END IF
                  END IF
               END IF
            END IF
C
   50    CONTINUE
      ELSE
         I  = 1
         N1 = N
         N2 = N
      END IF
C
C     Use unblocked code to compute the last or only block.
C
      IF( I.LE.M ) THEN
         IF( LTRANS ) THEN
            IF( LSIDE ) THEN
               CALL MB01RX( SIDE, UPLO, TRANS, M-I+1, N1, ALPHA, BETA,
     $                      R(I,I), LDR, A(1,I), LDA, B(1,I), LDB,
     $                      INFO )
               DO 60 J = N1+1, N, N1
                  CALL MB01RX( SIDE, UPLO, TRANS, M-I+1, MIN(N1, N-J+1),
     $                         ONE, BETA, R(I,I), LDR, A(J,I), LDA,
     $                         B(J,I), LDB, INFO )
   60          CONTINUE
            ELSE
               CALL MB01RX( SIDE, UPLO, TRANS, M-I+1, N2, ALPHA, BETA,
     $                      R(I,I), LDR, A(I,1), LDA, B(I,1), LDB,
     $                      INFO )
               DO 70 J = N2+1, N, N2
                  CALL MB01RX( SIDE, UPLO, TRANS, M-I+1, MIN(N2, N-J+1),
     $                         ONE, BETA, R(I,I), LDR, A(I,J), LDA,
     $                         B(I,J), LDB, INFO )
   70          CONTINUE
            END IF
         ELSE
            IF( LSIDE ) THEN
               CALL MB01RX( SIDE, UPLO, TRANS, M-I+1, N2, ALPHA, BETA,
     $                      R(I,I), LDR, A(I,1), LDA, B(1,I), LDB,
     $                      INFO )
               DO 80 J = N2+1, N, N2
                  CALL MB01RX( SIDE, UPLO, TRANS, M-I+1, MIN(N2, N-J+1),
     $                         ONE, BETA, R(I,I), LDR, A(I,J), LDA,
     $                         B(J,I), LDB, INFO )
   80          CONTINUE
            ELSE
               CALL MB01RX( SIDE, UPLO, TRANS, M-I+1, N2, ALPHA, BETA,
     $                      R(I,I), LDR, A(1,I), LDA, B(I,1), LDB,
     $                      INFO )
               DO 90 J = N2+1, N, N2
                  CALL MB01RX( SIDE, UPLO, TRANS, M-I+1, MIN(N2, N-J+1),
     $                         ONE, BETA, R(I,I), LDR, A(J,I), LDA,
     $                         B(I,J), LDB, INFO )
   90          CONTINUE
            END IF
         END IF
      END IF
C
      RETURN
C *** Last line of MB01RB ***
      END


        subroutine equ_to_altaz_d(dec,ha,phi,alt,az)

        include 'trigd.inc'

        IMPLICIT REAL(A-Z)

        sindec = SIND(dec)
        cosdec = COSD(dec)
        sinphi = SIND(phi)
        cosphi = COSD(phi)
        cosha  = COSD(ha)

        alt=ASIND (sinphi*sindec+cosphi*cosdec*cosha)
        cosarg = (cosphi*sindec-sinphi*cosdec*cosha)/cosd(alt)
        cosarg = min(max(cosarg,-1.),+1.)
        az =ACOSD(cosarg)

        if(ha .gt. 0. .AND. ha .lt. 180.)az = 360.0 - az

        return
        end


      subroutine r8util_bcherm1(fherm,idimx1,
     >     jbcxa,jbcxb,
     >     zbcxa,zbcxb,
     >     x1)

C...  insert BCs as needed for Hermite interpolation setup

      IMPLICIT NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      integer :: idimx1         ! array dimensions
      REAL*8 :: fherm(0:1,idimx1)

      integer :: jbcxa,jbcxb    ! x BC controls
      REAL*8 :: zbcxa            ! x(1) BC data
      REAL*8 :: zbcxb            ! x(idimx1) BC data

      REAL*8 :: x1(idimx1)

C-------------------------------------------------------------
      integer :: ix
      REAL*8 :: zdx
C-------------------------------------------------------------

      if((jbcxa.eq.1).or.(jbcxb.eq.1)) then

         if(jbcxa.eq.1) then
            fherm(1,1)=zbcxa
         else
            zdx = x1(2)-x1(1)
            fherm(1,1)=(fherm(0,2)-fherm(0,1))/zdx
         endif

         if(jbcxb.eq.1) then
            fherm(1,idimx1)=zbcxb
         else
            zdx = x1(idimx1)-x1(idimx1-1)
            fherm(1,idimx1)=(fherm(0,idimx1)-fherm(0,idimx1-1))/zdx
         endif

      endif

      end subroutine r8util_bcherm1


C
C	$Id$
C
      DOUBLE PRECISION FUNCTION CSSIG2 (N1,N2,N,X,Y,Z,H,LIST,
     .                                LPTR,LEND,GRAD,TOL,
     .                                IFLGS, SIGMA, IER)
      INTEGER N1, N2, N, LIST(*), LPTR(*), LEND(N), IFLGS,
     .        IER
      DOUBLE PRECISION X(N), Y(N), Z(N), H(N), GRAD(3,N),
     .                 TOL, SIGMA(*)
C
C***********************************************************
C
C                                              From SSRFPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   07/25/96
C
C   Given a triangulation of a set of nodes on the unit
C sphere, along with data values H and gradients GRAD at the
C nodes, this function determines the smallest tension fac-
C tor CSSIG2 such that the Hermite interpolatory tension
C spline H(A), defined by CSSIG2 and the endpoint values and
C directional derivatives associated with an arc N1-N2,
C preserves convexity (or concavity) of the data:
C
C   HP1 .LE. S .LE. HP2 implies HPP(A) .GE. 0, and
C   HP1 .GE. S .GE. HP2 implies HPP(A) .LE. 0
C
C for all A in the open interval (A1,A2) corresponding to
C the arc, where HP1 and HP2 are the derivative values of H
C at the endpoints, S is the slope of the linear interpolant
C of the endpoint data values, HPP denotes the second deriv-
C ative of H, and A is arc-length.  Note, however, that
C infinite tension is required if HP1 = S or HP2 = S (unless
C HP1 = HP2 = S).
C
C On input:
C
C       N1,N2 = Nodal indexes of the endpoints of an arc for
C               which the tension factor is to be computed.
C               The indexes must be distinct and lie in the
C               range 1 to N, and if IFLGS .GE. 1, they must
C               correspond to adjacent nodes in the triangu-
C               lation.
C
C       N = Number of nodes in the triangulation.  N .GE. 3.
C
C       X,Y,Z = Arrays of length N containing coordinates of
C               the nodes.  X(I)**2 + Y(I)**2 + Z(I)**2 = 1.
C
C       H = Array of length N containing data values at the
C           nodes.  H(I) is associated with (X(I),Y(I),Z(I))
C           for I = 1 to N.
C
C       LIST,LPTR,LEND = Data structure defining the trian-
C                        gulation.  Refer to STRIPACK
C                        Subroutine CSTRMESH.
C
C       GRAD = Array dimensioned 3 by N whose columns con-
C              gradients at the nodes.  GRAD( ,J) must be
C              orthogonal to node J:  GRAD(1,J)*X(J) +
C              GRAD(2,J)*Y(J) + GRAD(3,J)*Z(J) = 0.  Refer
C              to Subroutines CSGRADG, CSGRADL, and CSSMSURF.
C
C       TOL = Tolerance whose magnitude determines how close
C             CSSIG2 is to its optimal value when nonzero
C             finite tension is necessary and sufficient to
C             satisfy convexity or concavity.  In the case
C             convexity, CSSIG2 is chosen so that 0 .LE.
C             HPPMIN .LE. abs(TOL), where HPPMIN is the
C             minimum value of HPP on the arc.  In the case
C             of concavity, the maximum value of HPP satis-
C             fies -abs(TOL) .LE. HPPMAX .LE. 0.  Thus, the
C             constraint is satisfied but possibly with more
C             tension than necessary.
C
C       IFLGS = Tension array option indicator:
C               IFLGS .LE. 0 if SIGMA is not to be used.
C               IFLGS .GE. 1 if SIGMA is to be updated by
C                            storing CSSIG2 in the appropriate
C                            locations.
C
C The above parameters are not altered by this function.
C
C       SIGMA = Dummy parameter (IFLGS .LE. 0) or array
C               containing tension factors associated with
C               arcs in one-to-one correspondence with LIST
C               entries (IFLGS .GE. 1).  Refer to Subroutine
C               CSGETSIG.
C
C On output:
C
C       SIGMA = Tension factor array updated with the new
C               value if and only if IFLGS .GE. 1 and IER
C               .GE. 0.
C
C       IER = Error indicator:
C             IER = 0 if no errors were encountered and fin-
C                     ite tension is sufficient to satisfy
C                     convexity (or concavity).
C             IER = 1 if no errors were encountered but in-
C                     finite tension is required to satisfy
C                     convexity.
C             IER = 2 if the data does not satisfy convexity
C                     or concavity.
C             IER = -1 if N1, N2, or N is outside its valid
C                      range.
C             IER = -2 if nodes N1 and N2 coincide or IFLGS
C                      .GE. 1 and the nodes are not adja-
C                      cent.
C
C       CSSIG2 = Minimum tension factor defined above unless
C              IER < 0, in which case CSSIG2 = -1.  If IER
C              = 1, CSSIG2 is set to 85, resulting in an
C              approximation to the linear interpolant of
C              the endpoint values.  If IER = 2, CSSIG2 = 0,
C              resulting in the Hermite cubic interpolant.
C
C STRIPACK module required by CSSIG2:  CSSTORE
C
C SSRFPACK modules required by CSSIG2:  CSARCLEN, CSSNHCSH
C
C Intrinsic functions called by CSSIG2:  ABS, EXP, MAX, MIN,
C                                        SQRT
C
C***********************************************************
C
      DOUBLE PRECISION CSARCLEN, CSSTORE
      INTEGER LP1, LP2, LPL, LUN, NIT
      DOUBLE PRECISION AL, COSHM, D1, D1D2, D2, DSIG, DUMMY,
     .                 EMS, F, FP, FTOL, P1(3), P2(3), RTOL,
     .                 S, SBIG, SIG, SINHM, SSM, T, T1, TP1,
     .                 UN(3), UNORM
C
      DATA SBIG/85./,  LUN/-1/
C
C Print a heading.
C
      IF (LUN .GE. 0) WRITE (LUN,100) N1, N2
  100 FORMAT (//1X,'CSSIG2 -- N1 =',I4,', N2 =',I4)
C
C Test for errors and set local parameters.
C
      IER = -1
      IF (MIN(N1,N2) .LT. 1  .OR.  N1 .EQ. N2  .OR.
     .    MAX(N1,N2,3) .GT. N) GO TO 11
      IER = -2
      IF (IFLGS .GT. 0) THEN
C
C   Set LP1 and LP2 to the pointers to N2 as a neighbor of
C     N1 and N1 as a neighbor of N2, respectively.
C
        LPL = LEND(N1)
        LP1 = LPTR(LPL)
    1   IF (LIST(LP1) .EQ. N2) GO TO 2
          LP1 = LPTR(LP1)
          IF (LP1 .NE. LPL) GO TO 1
        IF (ABS(LIST(LP1)) .NE. N2) GO TO 11
C
    2   LPL = LEND(N2)
        LP2 = LPTR(LPL)
    3   IF (LIST(LP2) .EQ. N1) GO TO 4
          LP2 = LPTR(LP2)
          IF (LP2 .NE. LPL) GO TO 3
        IF (ABS(LIST(LP2)) .NE. N1) GO TO 11
      ENDIF
C
C Store nodal coordinates P1 and P2, compute arc-length AL
C   and unit normal UN = (P1 X P2)/UNORM, and test for
C   coincident nodes.
C
    4 P1(1) = X(N1)
      P1(2) = Y(N1)
      P1(3) = Z(N1)
      P2(1) = X(N2)
      P2(2) = Y(N2)
      P2(3) = Z(N2)
      AL = CSARCLEN(P1,P2)
      UN(1) = P1(2)*P2(3) - P1(3)*P2(2)
      UN(2) = P1(3)*P2(1) - P1(1)*P2(3)
      UN(3) = P1(1)*P2(2) - P1(2)*P2(1)
      UNORM = SQRT(UN(1)*UN(1) + UN(2)*UN(2) + UN(3)*UN(3))
      IF (UNORM .EQ. 0.  .OR.  AL .EQ. 0.) GO TO 11
C
C Compute first and second differences and test for infinite
C   tension required.
C
      S = H(N2) - H(N1)
      D1 = S - AL*(GRAD(1,N1)*P2(1) + GRAD(2,N1)*P2(2) +
     .             GRAD(3,N1)*P2(3))/UNORM
      D2 = -AL*(GRAD(1,N2)*P1(1) + GRAD(2,N2)*P1(2) +
     .          GRAD(3,N2)*P1(3))/UNORM - S
      D1D2 = D1*D2
      IER = 1
      SIG = SBIG
      IF (D1D2 .EQ. 0.  .AND.  D1 .NE. D2) GO TO 10
C
C Test for a valid constraint.
C
      IER = 2
      SIG = 0.
      IF (D1D2 .LT. 0.) GO TO 10
C
C Test for SIG = 0 sufficient.
C
      IER = 0
      IF (D1D2 .EQ. 0.) GO TO 10
      T = MAX(D1/D2,D2/D1)
      IF (T .LE. 2.) GO TO 10
C
C Find a zero of F(SIG) = SIG*COSHM(SIG)/SINHM(SIG) - (T+1).
C   Since the derivative of F vanishes at the origin, a
C   quadratic approximation is used to obtain an initial
C   estimate for the Newton method.
C
      TP1 = T + 1.
      SIG = SQRT(10.*T-20.)
      NIT = 0
C
C   Compute an absolute tolerance FTOL = abs(TOL) and a
C     relative tolerance RTOL = 100*Macheps.
C
      FTOL = ABS(TOL)
      RTOL = 1.
    5 RTOL = RTOL/2.
        IF (CSSTORE(RTOL+1.) .GT. 1.) GO TO 5
      RTOL = RTOL*200.
C
C Top of loop:  evaluate F and its derivative FP.
C
    6 IF (SIG .LE. .5) THEN
C
C   Use approximations designed to avoid cancellation error
C     in the hyperbolic functions.
C
        CALL CSSNHCSH (SIG, SINHM,COSHM,DUMMY)
        T1 = COSHM/SINHM
        FP = T1 + SIG*(SIG/SINHM - T1*T1 + 1.)
      ELSE
C
C   Scale SINHM and COSHM by 2*exp(-SIG) in order to avoid
C     overflow.
C
        EMS = EXP(-SIG)
        SSM = 1. - EMS*(EMS+SIG+SIG)
        T1 = (1.-EMS)*(1.-EMS)/SSM
        FP = T1 + SIG*(2.*SIG*EMS/SSM - T1*T1 + 1.)
      ENDIF
C
      F = SIG*T1 - TP1
C
C   Update the number of iterations NIT.
C
      NIT = NIT + 1
      IF (LUN .GE. 0) WRITE (LUN,110) NIT, SIG, F, FP
  110 FORMAT (1X,3X,I2,' -- SIG = ',E15.8,', F = ',
     .        E15.8/1X,31X,'FP = ',E15.8)
C
C   Test for convergence.
C
      IF (FP .LE. 0.) GO TO 10
      DSIG = -F/FP
      IF (ABS(DSIG) .LE. RTOL*SIG  .OR.  (F .GE. 0.  .AND.
     .    F .LE. FTOL)  .OR.  ABS(F) .LE. RTOL) GO TO 10
C
C   Bottom of loop:  update SIG.
C
      SIG = SIG + DSIG
      GO TO 6
C
C No errors encountered.
C
   10 CSSIG2 = SIG
      IF (IFLGS .LE. 0) RETURN
      SIGMA(LP1) = SIG
      SIGMA(LP2) = SIG
      RETURN
C
C Error termination.
C
   11 CSSIG2 = -1.
      RETURN
      END


submodule(burn_state_t_interface) burn_state_t_implementation
  !! Define the burn_state_t user-defined structure constructors and type-bound procedures
  implicit none

  real(dp), parameter :: psipa=6894.76d0    ! unit conversion factor: pascals per psi
  real(dp), parameter :: p_ref=3000d0*psipa ! constant reference pressure for burn-rate calculation

contains

  module procedure new_burn_state_t
    associate(r_ref => (old_burn_state_t%r_ref_))
      new_burn_state_t%r_ref_ = r_ref
      new_burn_state_t%r_ = r_ref*(p/p_ref)**n ! calculate burn rate
    end associate
    associate(r => (new_burn_state_t%r_))
      new_burn_state_t%db_ = old_burn_state_t%db_ + r*dt  ! increment burn depth
    end associate
  end procedure

  module procedure zero_burn_depth
    use constants, only : zero
    zero_burn_depth%r_ref_  = reference_burn_rate
    zero_burn_depth%r_      = reference_burn_rate*(pressure/p_ref)**exponent_
    zero_burn_depth%db_     = zero
  end procedure

  module procedure db
    db = this%db_
  end procedure

  module procedure r
    r = this%r_
  end procedure

end submodule burn_state_t_implementation


SUBROUTINE spabac(kv,loads,kdiag)
!
! This subroutine performs Cholesky forward and back-substitution
! on a symmetric skyline global matrix.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::kv(:)
 REAL(iwp),INTENT(IN OUT)::loads(0:)
 INTEGER,INTENT(IN)::kdiag(:)
 INTEGER::n,i,ki,l,m,j,it,k
 REAL(iwp)::x
 n=UBOUND(kdiag,1)
 loads(1)=loads(1)/kv(1)
 DO i=2,n
   ki=kdiag(i)-i
   l=kdiag(i-1)-ki+1
   x=loads(i)
   IF(l/=i)THEN
     m=i-1
     DO j=l,m
       x=x-kv(ki+j)*loads(j)
     END DO
   END IF
   loads(i)=x/kv(ki+i)
 END DO
 DO it=2,n
   i=n+2-it
   ki=kdiag(i)-i
   x=loads(i)/kv(ki+i)
   loads(i)=x
   l=kdiag(i-1)-ki+1
   IF(l/=i)THEN
     m=i-1
     DO k=l,m
       loads(k)=loads(k)-x*kv(ki+k)
     END DO
   END IF
 END DO
 loads(1)=loads(1)/kv(1)
RETURN
END SUBROUTINE spabac


PROGRAM main
	USE decomp_2d
	USE decomp_2d_fft
	USE decomp_2d_io

	IMPLICIT NONE
	INCLUDE "mpif.h"
	!Grid & Stepping
   	INTEGER(kind=4), PARAMETER 		:: Nx=512, Ny=512, Nz=512
   	INTEGER(kind=4), PARAMETER 		:: Lx=1, Ly=1, Lz=1
	INTEGER(kind=4), PARAMETER		:: Nt=20,plotgap=10
	INTEGER(kind=4)				:: numplots=Nt/plotgap
	!choose initial conditions
	logical					::readinput=.false.,&
						  TGvortex=.true.,&
						  exactsoln=.false.
	!runime parameters
	INTEGER(kind=4), PARAMETER 	  	:: savedata1=0
	REAL(kind=8), PARAMETER			:: dt=0.005d0
	REAL(kind=8), PARAMETER			:: Re=1600.0d0
	REAL(kind=8)				:: theta=0.0d0
	!additional parameters & constants
	REAL(kind=8), PARAMETER	&
		::  pi=3.14159265358979323846264338327950288419716939937510d0
	REAL(kind=8), PARAMETER		:: dx=2.0d0*pi*Lx/REAL(Nx,kind(0d0))
	REAL(kind=8), PARAMETER		:: dy=2.0d0*pi*Ly/REAL(Ny,kind(0d0))
	REAL(kind=8), PARAMETER		:: dz=2.0d0*pi*Lz/REAL(Nz,kind(0d0))
	REAL(kind=8), PARAMETER		::	ReInv=1.0d0/REAL(Re,kind(0d0))
	REAL(kind=8), PARAMETER		:: dtInv=1.0d0/REAL(dt,kind(0d0))
	!Carpenter-Kennedy coefficients, Notation is as in Algorithm 3 of Kectheson(2010)
   	!Butcher table coefficents
	REAL(kind=8), DIMENSION(6)	:: beta,gamma1,gamma2,gamma3
        REAL(kind=8), DIMENSION(7)      :: delta
	!computational arrays/scalars
	REAL(kind=8)						::  scalemodes,mu,factor,t=0.0d0
	COMPLEX(kind=8), DIMENSION(:), ALLOCATABLE		:: kx,ky,kz
	REAL(kind=8), DIMENSION(:), ALLOCATABLE			:: x,y,z,time
	REAL(kind=8), DIMENSION(:), ALLOCATABLE			:: KE,Enstrophy,&
							            KEdissipationRate
	REAL(kind=8), DIMENSION(:,:,:), ALLOCATABLE		:: u,v,w,&
							            ux,uy,uz,&
							            vx,vy,vz,&
							            wx,wy,wz,&
							            omega,nonlin,temp
	COMPLEX(kind=8), DIMENSION(:,:,:), ALLOCATABLE		:: uhat,vhat,what,&
								   omegahat,temp_c,temp_c1,&
								   nonlinhatuh,nonlinhatvh,&
								   nonlinhatwh,phat
	!exact solution
	REAL(kind=8), PARAMETER					:: sl=1.0d0,sk=1.0d0,sm=1.0d0,&
								   lamlkm=sqrt(sl**2+sk**2+sm**2)
	COMPLEX(kind=8), DIMENSION(:,:,:), ALLOCATABLE		:: utemp,vtemp,wtemp,utemp2,vtemp2,wtemp2
	REAL(kind=8)						:: temp3
	!MPI and 2DECOMP variables
	TYPE(DECOMP_INFO)					:: decomp,sp
	INTEGER(kind=4)						:: myid,numprocs,ierr
	INTEGER(kind=MPI_OFFSET_KIND)				:: filesize, disp
	INTEGER(kind=4)						:: p_row=0, p_col=0
	REAL(kind=8), DIMENSION(:), ALLOCATABLE			:: temp1,temp2
	!variables used for saving data and timing
	INTEGER(kind=4)						::  i,j,k,n,nn,kk,allocatestatus
	INTEGER(kind=4)						::  count, iol, ind, plotInt=0
	CHARACTER*100			 			:: name_config
	INTEGER(kind=4)						::	start, finish, count_rate
   	!initialisation of 2DECOMP&FFT and MPI
	CALL MPI_INIT(ierr)
	CALL MPI_COMM_SIZE(MPI_COMM_WORLD, numprocs, ierr)
	CALL MPI_COMM_RANK(MPI_COMM_WORLD, myid, ierr)
	CALL decomp_2d_init(Nx,Ny,Nz,p_row,p_col)
	CALL decomp_info_init(Nx,Ny,Nz,decomp)
   	CALL decomp_info_init(Nx/2+1,Ny,Nz,sp)
	CALL decomp_2d_fft_init

	IF (myid.eq.0) THEN
		PRINT *,'Solve 3D incompressible NS equations with Fourier pseudospectral methods'
		PRINT *,'and fourth order five stage three storage location embedded Runge Kutta method.'
	   	PRINT *,'Grid:',Nx,'X',Ny,'X',Nz
		PRINT *,'dt:',dt
		PRINT *,'Re:',Re
		PRINT *,'Nt:',Nt
      		PRINT *,'plotgap:',plotgap
	END IF
	ALLOCATE(time(1:Nt+1),kx(1:Nx),ky(1:Ny),kz(1:Nz),x(1:Nx),y(1:Ny),z(1:Nz),temp1(1:9),temp2(1:9),&
	KE(1:Nt+1),Enstrophy(1:Nt+1),KEdissipationRate(1:Nt+1),&
	u(decomp%xst(1):decomp%xen(1),decomp%xst(2):decomp%xen(2),decomp%xst(3):decomp%xen(3)),&
	v(decomp%xst(1):decomp%xen(1),decomp%xst(2):decomp%xen(2),decomp%xst(3):decomp%xen(3)),&
	w(decomp%xst(1):decomp%xen(1),decomp%xst(2):decomp%xen(2),decomp%xst(3):decomp%xen(3)),&
	ux(decomp%xst(1):decomp%xen(1),decomp%xst(2):decomp%xen(2),decomp%xst(3):decomp%xen(3)),&
	uy(decomp%xst(1):decomp%xen(1),decomp%xst(2):decomp%xen(2),decomp%xst(3):decomp%xen(3)),&
	uz(decomp%xst(1):decomp%xen(1),decomp%xst(2):decomp%xen(2),decomp%xst(3):decomp%xen(3)),&
	vx(decomp%xst(1):decomp%xen(1),decomp%xst(2):decomp%xen(2),decomp%xst(3):decomp%xen(3)),&
	vy(decomp%xst(1):decomp%xen(1),decomp%xst(2):decomp%xen(2),decomp%xst(3):decomp%xen(3)),&
	vz(decomp%xst(1):decomp%xen(1),decomp%xst(2):decomp%xen(2),decomp%xst(3):decomp%xen(3)),&
	wx(decomp%xst(1):decomp%xen(1),decomp%xst(2):decomp%xen(2),decomp%xst(3):decomp%xen(3)),&
	wy(decomp%xst(1):decomp%xen(1),decomp%xst(2):decomp%xen(2),decomp%xst(3):decomp%xen(3)),&
	wz(decomp%xst(1):decomp%xen(1),decomp%xst(2):decomp%xen(2),decomp%xst(3):decomp%xen(3)),&
	omega(decomp%xst(1):decomp%xen(1),decomp%xst(2):decomp%xen(2),decomp%xst(3):decomp%xen(3)),&
	nonlin(decomp%xst(1):decomp%xen(1),decomp%xst(2):decomp%xen(2),decomp%xst(3):decomp%xen(3)),&
	temp(decomp%xst(1):decomp%xen(1),decomp%xst(2):decomp%xen(2),decomp%xst(3):decomp%xen(3)),&
	uhat(sp%zst(1):sp%zen(1),sp%zst(2):sp%zen(2),sp%zst(3):sp%zen(3)),&
	vhat(sp%zst(1):sp%zen(1),sp%zst(2):sp%zen(2),sp%zst(3):sp%zen(3)),&
	what(sp%zst(1):sp%zen(1),sp%zst(2):sp%zen(2),sp%zst(3):sp%zen(3)),&
	omegahat(sp%zst(1):sp%zen(1),sp%zst(2):sp%zen(2),sp%zst(3):sp%zen(3)),&
	temp_c(sp%zst(1):sp%zen(1),sp%zst(2):sp%zen(2),sp%zst(3):sp%zen(3)),&
	temp_c1(sp%zst(1):sp%zen(1),sp%zst(2):sp%zen(2),sp%zst(3):sp%zen(3)),&
	nonlinhatuh(sp%zst(1):sp%zen(1),sp%zst(2):sp%zen(2),sp%zst(3):sp%zen(3)),&
	nonlinhatvh(sp%zst(1):sp%zen(1),sp%zst(2):sp%zen(2),sp%zst(3):sp%zen(3)),&
	nonlinhatwh(sp%zst(1):sp%zen(1),sp%zst(2):sp%zen(2),sp%zst(3):sp%zen(3)),&
	phat(sp%zst(1):sp%zen(1),sp%zst(2):sp%zen(2),sp%zst(3):sp%zen(3)),&
	utemp(sp%zst(1):sp%zen(1),sp%zst(2):sp%zen(2),sp%zst(3):sp%zen(3)),&
	vtemp(sp%zst(1):sp%zen(1),sp%zst(2):sp%zen(2),sp%zst(3):sp%zen(3)),&
	wtemp(sp%zst(1):sp%zen(1),sp%zst(2):sp%zen(2),sp%zst(3):sp%zen(3)),&
	utemp2(sp%zst(1):sp%zen(1),sp%zst(2):sp%zen(2),sp%zst(3):sp%zen(3)),&
	vtemp2(sp%zst(1):sp%zen(1),sp%zst(2):sp%zen(2),sp%zst(3):sp%zen(3)),&
	wtemp2(sp%zst(1):sp%zen(1),sp%zst(2):sp%zen(2),sp%zst(3):sp%zen(3)),&
	stat=allocatestatus)
	IF (allocatestatus .ne. 0) STOP
	IF (myid.eq.0) THEN
	 	PRINT *,'allocated space'
	END IF
	beta=(/0.0, 0.075152045700771, 0.211361016946069, 1.100713347634329, 0.728537814675568, 0.393172889823198/)
   	gamma1=(/0.0000000000000000, 0.0, -0.497531095840104, 1.010070514199942, -3.196559004608766, 1.717835630267259/)
	gamma2=(/0.0, 1.0, 1.384996869124138, 3.878155713328178, -2.324512951813145, -0.514633322274467/)
	gamma3=(/0.0, 0.0, 0.0, 0.0, 1.642598936063715, 0.188295940828347/)
	delta=(/1.0, 0.081252332929194, -1.083849060586449, -1.096110881845602, 2.859440022030827, -0.655568367959557, -0.194421504490852/)
	! setup fourier frequencies in x-direction
	DO i=1,Nx/2+1
		kx(i)= cmplx(0.0d0,1.0d0)*REAL(i-1,kind(0d0))/Lx
	END DO
	kx(1+Nx/2)=0.0d0
	DO i = 1,Nx/2 -1
		kx(i+1+Nx/2)=-kx(1-i+Nx/2)
	END DO
	ind=1
	DO i=-Nx/2,Nx/2-1
		x(ind)=2.0d0*pi*REAL(i,kind(0d0))*Lx/REAL(Nx,kind(0d0))
		ind=ind+1
	END DO
	! setup fourier frequencies in y-direction
	DO j=1,Ny/2+1
		ky(j)= cmplx(0.0d0,1.0d0)*REAL(j-1,kind(0d0))/Ly
	END DO
	ky(1+Ny/2)=0.0d0
	DO j = 1,Ny/2 -1
		ky(j+1+Ny/2)=-ky(1-j+Ny/2)
	END DO
	ind=1
	DO j=-Ny/2,Ny/2-1
		y(ind)=2.0d0*pi*REAL(j,kind(0d0))*Ly/REAL(Ny,kind(0d0))
		ind=ind+1
	END DO
	! setup fourier frequencies in z-direction
	DO k=1,Nz/2+1
		kz(k)= cmplx(0.0d0,1.0d0)*REAL(k-1,kind(0d0))/Lz
	END DO
	kz(1+Nz/2)=0.0d0
	DO k = 1,Nz/2 -1
		kz(k+1+Nz/2)=-kz(1-k+Nz/2)
	END DO
	ind=1
	DO k=-Nz/2,Nz/2-1
		z(ind)=2.0d0*pi*REAL(k,kind(0d0))*Lz/REAL(Nz,kind(0d0))
		ind=ind+1
	END DO
	IF (myid.eq.0) THEN
		PRINT *,'Setup grid and fourier frequencies'
	END IF
	scalemodes=1.0d0/REAL(Nx*Ny*Nz,kind(0d0)); time(1)=0.0d0

   	IF(readInput.eqv..true.) THEN
		name_config='./data/restartData.dat'
		OPEN(unit=11,file=name_config,status='old')
		REWIND(11)
		READ(11,*) time(1),plotInt
		CLOSE(11)
      		name_config='./data/u'
      		CALL getName(name_config,plotInt)
      		CALL decomp_2d_read_one(1,u,name_config)
      		name_config='./data/v'
      		CALL getName(name_config,plotInt)
      		CALL decomp_2d_read_one(1,v,name_config)
      		name_config='./data/w'
      		CALL getName(name_config,plotInt)
      		CALL decomp_2d_read_one(1,w,name_config)
      		IF(myid.eq.0) THEN
         		PRINT*,'Read in values'
      		END IF
   		ELSE If(TGvortex.eqv..true.) THEN
	   		!initial conditions for Taylor-Green vortex
	   		factor=2.0/sqrt(3.0)
      			DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
	      			u(i,j,k)=factor*sin(theta+2.0*pi/3.0)*sin(x(i))*cos(y(j))*cos(z(k))
      			END DO; END DO; END DO
      			DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
	      			v(i,j,k)=factor*sin(theta-2.0*pi/3.0)*cos(x(i))*sin(y(j))*cos(z(k))
      			END DO ; END DO ; END DO
      			DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
	      			w(i,j,k)=factor*sin(theta)*cos(x(i))*cos(y(j))*sin(z(k))
      			END DO ; END DO ; END DO
      			IF(myid.eq.0) THEN
         			PRINT*,'Taylor-Green Vortex initial conditions'
      			END IF
   		ELSE IF(exactsoln.eqv..true.) THEN
			!special exact sol'n usted for testing
			factor=sqrt(3.0d0)
			DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
				u(i,j,k)=-0.5*( factor*cos(x(i))*sin(y(j))*sin(z(k))&
							+sin(x(i))*cos(y(j))*cos(z(k)) )*exp(-(factor**2)*time(1)/Re)
			END DO; END DO; END DO
			DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
				v(i,j,k)=0.5*(  factor*sin(x(i))*cos(y(j))*sin(z(k))&
							-cos(x(i))*sin(y(j))*cos(z(k)) )*exp(-(factor**2)*time(1)/Re)
			END DO ; END DO ; END DO
			DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
				w(i,j,k)=cos(x(i))*cos(y(j))*sin(z(k))*exp(-(factor**2)*time(1)/Re)
			END DO ; END DO ; END DO
      			IF(myid.eq.0) THEN
         			PRINT*,'Exact Solution initial conditions'
      			END IF
		ELSE
      			IF(myid.eq.0) THEN
         		PRINT*,'--------------------------------------------------------------------'
		   	PRINT*,'Set initial conditions to either readinput, TGvortex, or exactsoln.'
         		PRINT*,'--------------------------------------------------------------------'
         		goto 111
      		END IF
	END IF

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

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

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

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

   	!calculate vorticity
	DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
		temp(i,j,k)=wy(i,j,k)-vz(i,j,k)
	END DO ; END DO ; END DO

	DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
		omega(i,j,k)=temp(i,j,k)*temp(i,j,k)
	END DO ; END DO ; END DO

	DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
		temp(i,j,k)=uz(i,j,k)-wx(i,j,k)
	END DO ; END DO ; END DO

	DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
		omega(i,j,k)=temp(i,j,k)*temp(i,j,k)+omega(i,j,k)
	END DO ; END DO ; END DO

	DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
		temp(i,j,k)=vx(i,j,k)-uy(i,j,k)
	END DO ; END DO ; END DO
	DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
		omega(i,j,k)=temp(i,j,k)*temp(i,j,k)+omega(i,j,k)
	END DO ; END DO ; END DO

	!Calculate Kinetic Energy
	temp1(1) = sum(u*u)
	temp1(2) = sum(v*v)
	temp1(3) = sum(w*w)
	CALL MPI_ALLREDUCE(temp1(1:3),temp2(1:3),3,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
	temp3=temp2(1)+temp2(2)+temp2(3)
	KE(1)=0.5d0*dx*dy*dz*temp3

	!Calculate Enstrophy
   	temp1(1)=sum(omega)
	CALL MPI_ALLREDUCE(temp1(1),temp3,1,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
   	Enstrophy(1)=0.5d0*dx*dy*dz*temp3

   	temp1=0.0;temp2=0.0
	!Calculate Kinetic Energy Dissipation Rate
	temp1(1)=sum(ux*ux)
	temp1(2)=sum(uy*uy)
	temp1(3)=sum(uz*uz)
	temp1(4)=sum(vx*vx)
	temp1(5)=sum(vy*vy)
	temp1(6)=sum(vz*vz)
	temp1(7)=sum(wx*wx)
	temp1(8)=sum(wy*wy)
	temp1(9)=sum(wz*wz)
	CALL MPI_ALLREDUCE(temp1,temp2,9,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
	temp3=temp2(1)+temp2(2)+temp2(3)+temp2(4)+temp2(5)+temp2(6)+temp2(7)+temp2(8)+temp2(9)
	KEdissipationRate(1)=2.0d0*dx*dy*dz*temp3

   	IF(myid.eq.0) THEN
      		PRINT *,'time=',time(1)
	   	PRINT*,'KE=',KE(1)
	   	PRINT*,'Enstrophy=',Enstrophy(1)
	   	PRINT*,'KEdissipationRate=',KEdissipationRate(1)
      		PRINT*,'---------------------------------'
		PRINT*,'starting timestepping and timer'
     		PRINT*,'---------------------------------'
   	END IF
	nonlinhatuh(:,:,:)=0.0d0; nonlinhatvh(:,:,:)=0.0d0; nonlinhatwh(:,:,:)=0.0d0;
   	phat(:,:,:)=0.0d0

	CALL system_clock(start,count_rate)
	DO n=1,numplots
      		DO nn=1,plotgap
         		t=t+dt
			DO k=sp%zst(3),sp%zen(3) ; DO j=sp%zst(2),sp%zen(2) ; DO i=sp%zst(1),sp%zen(1)
         			utemp(i,j,k)=0.0d0
				vtemp(i,j,k)=0.0d0
				wtemp(i,j,j)=0.0d0
				utemp2(i,j,k)=uhat(i,j,k)
				vtemp2(i,j,k)=vhat(i,j,k)
				wtemp2(i,j,k)=what(i,j,k)
			END DO ; END DO ; END DO
		   	DO kk=2,6
            			DO k=sp%zst(3),sp%zen(3) ; DO j=sp%zst(2),sp%zen(2) ; DO i=sp%zst(1),sp%zen(1)
               				utemp2(i,j,k)=utemp2(i,j,k)+delta(kk-1)*uhat(i,j,k)
               				vtemp2(i,j,k)=vtemp2(i,j,k)+delta(kk-1)*vhat(i,j,k)
               				wtemp2(i,j,k)=wtemp2(i,j,k)+delta(kk-1)*what(i,j,k)
            			END DO ; END DO ; END DO

			   	!nonlinuhat
			   	DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
				   	temp(i,j,k)=(u(i,j,k)*ux(i,j,k)+v(i,j,k)*uy(i,j,k)+w(i,j,k)*uz(i,j,k))
			   	END DO ; END DO ; END DO
			   	CALL decomp_2d_fft_3d(temp,nonlinhatuh)

			   	!nonlinvhat
			   	DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
				   	temp(i,j,k)=u(i,j,k)*vx(i,j,k)+v(i,j,k)*vy(i,j,k)+w(i,j,k)*vz(i,j,k)
			   	END DO ; END DO ; END DO
			   	CALL decomp_2d_fft_3d(temp,nonlinhatvh)

			   	!nonlinwhat
			   	DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
				   	temp(i,j,k)=u(i,j,k)*wx(i,j,k)+v(i,j,k)*wy(i,j,k)+w(i,j,k)*wz(i,j,k)
			   	END DO ; END DO ; END DO
			   	CALL decomp_2d_fft_3d(temp,nonlinhatwh)

			   	!phat
			   	DO k=sp%zst(3),sp%zen(3) ; DO j=sp%zst(2),sp%zen(2) ; DO i=sp%zst(1),sp%zen(1)
				   	phat(i,j,k)=-1.0*(kx(i)*nonlinhatuh(i,j,k)+ky(j)*nonlinhatvh(i,j,k)+kz(k)*nonlinhatwh(i,j,k))&
                           		/(kx(i)*kx(i)+ky(j)*ky(j)+kz(k)*kz(k)+REAL(0.1d0**13,kind(0d0)))
			   	END DO ; END DO ; END DO

			   	!uhat,vhat,what
			   	DO k=sp%zst(3),sp%zen(3) ; DO j=sp%zst(2),sp%zen(2) ; DO i=sp%zst(1),sp%zen(1)
				   	factor=(kx(i)*kx(i)+ky(j)*ky(j)+kz(k)*kz(k)+REAL(0.1d0**13,kind(0d0)))
				   	uhat(i,j,k)=gamma1(kk)*uhat(i,j,k)+gamma2(kk)*utemp(i,j,k)+gamma3(kk)*utemp2(i,j,k)+beta(kk)*dt&
                           		*(-nonlinhatuh(i,j,k)-kx(i)*phat(i,j,k)+ReInv*factor*uhat(i,j,k));
				   	vhat(i,j,k)=gamma1(kk)*vhat(i,j,k)+gamma2(kk)*vtemp(i,j,k)+gamma3(kk)*vtemp2(i,j,k)+beta(kk)*dt&
                           		*(-nonlinhatvh(i,j,k)-ky(j)*phat(i,j,k)+ReInv*factor*vhat(i,j,k));
				   	what(i,j,k)=gamma1(kk)*what(i,j,k)+gamma2(kk)*wtemp(i,j,k)+gamma3(kk)*wtemp2(i,j,k)+beta(kk)*dt&
                           		*(-nonlinhatwh(i,j,k)-kz(k)*phat(i,j,k)+ReInv*factor*what(i,j,k));
			   	END DO ; END DO ; END DO

			   	!ifft to get u,v,w and derivatives

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

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

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

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

		END DO
		!calculate vorticity
		DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
			temp(i,j,k)=REAL(wy(i,j,k)-vz(i,j,k),KIND=8)
		END DO ; END DO ; END DO

		DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
			omega(i,j,k)=REAL(temp(i,j,k)*temp(i,j,k),KIND=8)
		END DO ; END DO ; END DO

		DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
			temp(i,j,k)=REAL(uz(i,j,k)-wx(i,j,k),KIND=8)
		END DO ; END DO ; END DO

		DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
			omega(i,j,k)=REAL(temp(i,j,k)*temp(i,j,k)+omega(i,j,k),KIND=8)
		END DO ; END DO ; END DO

		DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
			temp(i,j,k)=REAL(vx(i,j,k)-uy(i,j,k),KIND=8)
		END DO ; END DO ; END DO

		DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
			omega(i,j,k)=REAL(temp(i,j,k)*temp(i,j,k)+omega(i,j,k),KIND=8)
		END DO ; END DO ; END DO

	   	!Calculate Kinetic Energy
	   	temp1(1) = sum(u*u)
	   	temp1(2) = sum(v*v)
	   	temp1(3) = sum(w*w)
	   	CALL MPI_ALLREDUCE(temp1(1:3),temp2(1:3),3,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
	   	temp3=temp2(1)+temp2(2)+temp2(3)
	   	KE(n+1)=0.5d0*dx*dy*dz*temp3

	   	!Calculate Enstrophy
      		temp1(1)=sum(omega)
	   	CALL MPI_ALLREDUCE(temp1(1),temp3,1,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
      		Enstrophy(n+1)=0.5d0*dx*dy*dz*temp3

	   	temp1=0.0;temp2=0.0
	   	!Calculate Kinetic Energy Dissipation Rate
	   	temp1(1)=sum(ux*ux)
	   	temp1(2)=sum(uy*uy)
	   	temp1(3)=sum(uz*uz)
	   	temp1(4)=sum(vx*vx)
	   	temp1(5)=sum(vy*vy)
	   	temp1(6)=sum(vz*vz)
	   	temp1(7)=sum(wx*wx)
	   	temp1(8)=sum(wy*wy)
	   	temp1(9)=sum(wz*wz)
	   	CALL MPI_ALLREDUCE(temp1,temp2,9,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
	   	temp3=temp2(1)+temp2(2)+temp2(3)+temp2(4)+temp2(5)+temp2(6)+temp2(7)+temp2(8)+temp2(9)
	   	KEdissipationRate(n+1)=2.0d0*dx*dy*dz*temp3

      		time(n+1)=time(1)+plotgap*dt*n
     		IF(myid.eq.0) THEN
         		PRINT*,'time=',time(n+1)
	      		PRINT*,'KE=',KE(n+1)
	      		PRINT*,'Enstrophy=',Enstrophy(n+1)
	      		PRINT*,'KEdissipationRate=',KEdissipationRate(n+1)
         		PRINT*,'---------------------------------'
      		END IF
      		IF(savedata1==1) THEN
		   	plotInt=plotInt+1
         		name_config='./data/u'
         		CALL savedata(Nx,Ny,Nz,plotInt,name_config,u,decomp)
         		name_config='./data/v'
         		CALL savedata(Nx,Ny,Nz,plotInt,name_config,v,decomp)
         		name_config='./data/w'
         		CALL savedata(Nx,Ny,Nz,plotInt,name_config,w,decomp)
			name_config='./data/omega'
			CALL savedata(Nx,Ny,Nz,plotInt,name_config,omega,decomp)
      		END IF
		   	IF (savedata1==1) THEN
      		IF (myid.eq.0) THEN
         		name_config='./data/KineticEnergy.dat'
	      		OPEN(UNIT=13, FILE=name_config,position='append')
	         	write(13,*) KE(n+1)
         		CLOSE(13)

         		name_config='./data/Enstrophy.dat'
	      		OPEN(UNIT=13, FILE=name_config,position='append')
	         	write(13,*)  Enstrophy(n+1)
         		CLOSE(13)

         		name_config='./data/KEdissipationRate.dat'
	      		OPEN(UNIT=13, FILE=name_config,position='append')
	         	write(13,*) KEdissipationRate(n+1)
         		CLOSE(13)

         		name_config='./data/tdata.dat'
	      		OPEN(UNIT=13, FILE=name_config,position='append')
	         	write(13,*) time(n+1)
         		CLOSE(13)

			!time and plot number needed for restart
         		name_config='./data/restartData.dat'
	      		OPEN(UNIT=13, FILE=name_config, status='unknown')
			REWIND(13)
	      		write(13,*) time(Nt+1),plotInt
         		CLOSE(13)
      		END IF
   	END IF

	END DO

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

	IF(exactsoln.eqv..true.) THEN
		!Calculate error in final numerical solution
      		factor=sqrt(3.0d0)
		DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
			temp(i,j,k)=u(i,j,k) -&
							(-0.5*( factor*cos(x(i))*sin(y(j))*sin(z(k))&
							+sin(x(i))*cos(y(j))*cos(z(k)) )*exp(-(factor**2)*time(Nt+1)/Re))
		END DO; END DO; END DO
      		temp1(1) = maxval(abs(temp));
		DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
			temp(i,j,k)=v(i,j,k) -&
						(0.5*(  factor*sin(x(i))*cos(y(j))*sin(z(k))&
							-cos(x(i))*sin(y(j))*cos(z(k)) )*exp(-(factor**2)*time(Nt+1)/Re))
		END DO ; END DO ; END DO
      		temp1(2) = maxval(abs(temp));
		DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
			temp(i,j,k)=w(i,j,k)-&
						(cos(x(i))*cos(y(j))*sin(z(k))*exp(-(factor**2)*time(Nt+1)/Re))
		END DO ; END DO ; END DO
		temp1(3) = maxval(abs(temp));
		CALL MPI_ALLREDUCE(temp1(1:3),temp2(1:3),3,MPI_DOUBLE_PRECISION,MPI_MAX,MPI_COMM_WORLD,ierr)
		temp3=temp2(1)+temp2(2)+temp2(3)
		IF (myid.eq.0) THEN
			PRINT*,'The error at time',time(Nt+1),'is=',temp3
		END IF
	END IF

   111 continue
	DEALLOCATE(time,kx,ky,kz,x,y,z,temp1,temp2,&
			  KE,Enstrophy,KEdissipationRate,&
			  u,v,w,&
			  ux,uy,uz,&
			  vx,vy,vz,&
			  wx,wy,wz,&
			  omega,nonlin,temp,&
			  uhat,vhat,what,&
			  omegahat,temp_c,temp_c1,&
			  nonlinhatuh,nonlinhatvh,&
			  nonlinhatwh,phat,&
			  utemp,vtemp,wtemp,&
			  utemp2,vtemp2,wtemp2,&
			  stat=allocatestatus)
	IF (allocatestatus .ne. 0) THEN
                PRINT *,'STOP'
                STOP
   	END IF
   	CALL decomp_2d_fft_finalize
   	CALL decomp_2d_finalize
	IF (myid.eq.0) THEN
		PRINT *,'Program execution complete'
	END IF
	CALL MPI_FINALIZE(ierr)
END PROGRAM main

   SUBROUTINE getName(name_config,plotInt)
      implicit none
      CHARACTER*100,intent(inout)   :: name_config
      INTEGER(kind=4)               :: plotInt
      CHARACTER*100                 :: number_file
      INTEGER(kind=4)               :: ind

      ind = index(name_config,' ') - 1
      WRITE(number_file,'(i0)') 10000000+plotInt
      number_file = name_config(1:ind)//number_file
      ind = index(number_file,' ') - 1
      name_config = number_file(1:ind)//'.datbin'
   END SUBROUTINE getname


      subroutine init_data (U, lo, hi, Ncomp, ng,  &
                            dx, prob_lo, prob_hi)

      implicit none

      integer          :: lo(2), hi(2), Ncomp, ng
      double precision :: U(lo(1)-ng:hi(1)+ng, lo(2)-ng:hi(2)+ng, Ncomp)
      double precision :: dx(2)
      double precision :: prob_lo(2)
      double precision :: prob_hi(2)

      integer          :: i,j
      double precision :: x,y,r2

      do j = lo(2), hi(2)
         y = prob_lo(2) + (dble(j)+0.5d0) * dx(2)
         do i = lo(1), hi(1)
            x = prob_lo(1) + (dble(i)+0.5d0) * dx(1)
            r2 = (x*x + y*y) / 0.01

            U(i,j,1) = 0.d0
            U(i,j,2) = exp(-r2)

         end do
      end do

      end subroutine init_data


c -------- odefor.f -> odefor.dll ------
c compile in R with: system("g77 -shared -o odefor.dll odefor.f")
c or with system("R CMD SHLIB odefor.f")

c Initialiser for parameter common block
      subroutine odefor(odeparms)

      external odeparms
      integer N
      double precision parms(3)
      common /myparms/parms

      N = 3
      call odeparms(N, parms)
      return
      end

c Rate of change and 3 output variables
      subroutine derivsfor (neq, t, y, ydot,out,IP)
      integer          neq, IP(*)
      double precision t, y(neq), ydot(neq), out(*), k1, k2, k3
      common /myparms/k1,k2,k3
      if(IP(1) < 3) call rexit("nout should be at least 3")
      ydot(1) = -k1*y(1) + k2*y(2)*y(3)
      ydot(3) = k3*y(2)*y(2)
      ydot(2) = -ydot(1) - ydot(3)
      out(1)= y(1)+y(2)+y(3)
      out(2)= y(1)*2
      out(3)= IP(1)
      return
      end

c The jacobian matrix
      subroutine jacfor (neq, t, y, ml, mu, pd, nrowpd,RP,IP)
      integer neq, ml, mu, nrowpd ,IP(*)
      double precision y(*), pd(nrowpd,*), t, RP(*), k1, k2, k3
      common /myparms/k1,k2,k3
      pd(1,1) = -k1
      pd(2,1) =  k1
      pd(3,1) = 0.0
      pd(1,2) = k2*y(3)
      pd(2,2) = -k2*y(3) - 2*k3*y(2)
      pd(3,2) = 2*k3*y(2)
      pd(1,3) = k2*y(2)
      pd(2,3) = -k2*y(2)
      pd(3,3) = 0.0

      return
      end


c
c -------------------------------------------------------------
c
      subroutine stepgrid_dimSplit(q,fm,fp,gm,gp,mitot,mjtot,mbc,
     &                             dt,dtnew,dx,dy,
     &                             nvar,xlow,ylow,time,mptr,maux,aux)
c
c
c ::::::::::::::::::: STEPGRID_DIMSPLIT ::::::::::::::::::::::::::::::::::::
c                 dimensionally split version of stepgrid
c    take a step in x, then y. for now only godunov splitting
c    not strang splitting.
c
c take a time step on a single grid. overwrite solution array q.
c A modified version of the clawpack routine step2 is used.
c
c return fluxes in fm,fp and gm,gp.
c patch has room for ghost cells (mbc of them) around the grid.
c everything is the enlarged size (mitot by mjtot).
c
c mbc       = number of ghost cells  (= lwidth)
c mptr      = grid number  (for debugging)
c xlow,ylow = lower left corner of enlarged grid (including ghost cells).
c dt         = incoming time step
c dx,dy      = mesh widths for this grid
c dtnew      = return suggested new time step for this grid's soln.
c
c :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

      use amr_module
      implicit double precision (a-h,o-z)
      external rpn2

      parameter (msize=max1d+4)
      parameter (mwork=msize*(maxvar*maxvar + 13*maxvar + 3*maxaux +2))

      dimension q(nvar,mitot,mjtot)
      dimension fp(nvar,mitot,mjtot),gp(nvar,mitot,mjtot)
      dimension fm(nvar,mitot,mjtot),gm(nvar,mitot,mjtot)
      dimension aux(maux,mitot,mjtot)
C     dimension work(mwork)

      logical    debug,  dump
      data       debug/.false./,  dump/.false./

c
      if (dump) then
         write(outunit,*) "dumping grid ",mptr," at time ",time
         do i = 1, mitot
         do j = 1, mjtot
            write(outunit,545) i,j,(q(ivar,i,j),ivar=1,nvar),
     .                  (aux(ivar,i,j),ivar=1,maux)
 545        format(2i4,4e15.7)
         end do
         end do
      endif
c
      meqn   = nvar
      mx = mitot - 2*mbc
      my = mjtot - 2*mbc
      maxm = max(mx,my)       !# size for 1d scratch array
      mbig = maxm
      xlowmbc = xlow + mbc*dx
      ylowmbc = ylow + mbc*dy

c
c    old work array code now removed.
c
c
      call b4step2(mbc,mx,my,nvar,q,
     &             xlowmbc,ylowmbc,dx,dy,time,dt,maux,aux)
c
c
c     # take one step on the conservation law:  Godunov splitting
c
c                                   1.  First step in x direction:

      call step2x(mbig,nvar,maux, mbc,mx,my,q,aux,dx,dt,cflgrid,
     &              fm,fp,rpn2)
c
!$OMP  CRITICAL (cflm)

        cfl_level = dmax1(cfl_level,cflgrid)

!$OMP END CRITICAL (cflm)

c       # update q with x fluxes first. all rows in y  get updated
        dtdx = dt/dx
        do 50 j=1,mjtot
        do 50 i=mbc+1,mitot-mbc
        do 50 m=1,nvar
         if (mcapa.eq.0) then
c
c            # no capa array.  Standard flux differencing:

           q(m,i,j) = q(m,i,j)  - dtdx * (fm(m,i+1,j) - fp(m,i,j))

         else
c            # with capa array.
           q(m,i,j) = q(m,i,j)
     &          - dtdx * (fm(m,i+1,j) - fp(m,i,j)) / aux(mcapa,i,j)
         endif

 50      continue

c                                 2.  Second step in x direction:

      call step2y(mbig,nvar,maux, mbc,mx,my,q,aux,dy,dt,cflgrid,
     &              gm,gp,rpn2)
c
!$OMP  CRITICAL (cflm)

        cfl_level = dmax1(cfl_level,cflgrid)

!$OMP END CRITICAL (cflm)
c
c       # update q
        dtdy = dt/dy
        do 51 j=mbc+1,mjtot-mbc
        do 51 i=mbc+1,mitot-mbc
        do 51 m=1,nvar
         if (mcapa.eq.0) then
c
c            # no capa array.  Standard flux differencing:

           q(m,i,j) = q(m,i,j) - dtdy * (gm(m,i,j+1) - gp(m,i,j))
         else
c            # with capa array.
           q(m,i,j) = q(m,i,j)
     &          - dtdy * (gm(m,i,j+1) - gp(m,i,j)) / aux(mcapa,i,j)
         endif

 51      continue
c
!--        write(outunit,1001) mptr, node(nestlevel,mptr),cflgrid
!-- 1001   format(' Courant # of grid', i4,
!--     &        ' on level', i3, ' is  ', e10.3)

c
      if (method(5).eq.1) then
c        # with source term:   use Godunov splitting for this too
         call src2(nvar,mbc,mx,my,xlowmbc,ylowmbc,dx,dy,
     &             q,maux,aux,time,dt)
         endif
c
c
c
c     # output fluxes for debugging purposes:
      if (debug) then
         write(dbugunit,*)" fluxes for grid ",mptr
c        do 830 j = mbc+1, mjtot-1
            do 830 i = mbc+1, mitot-1
         do 830 j = mbc+1, mjtot-1
               write(dbugunit,831) i,j,fm(1,i,j),fp(1,i,j),
     .                             gm(1,i,j),gp(1,i,j)
               do 830 m = 2, meqn
                  write(dbugunit,832) fm(m,i,j),fp(m,i,j),
     .            gm(m,i,j),gp(m,i,j)
  831          format(2i4,4d16.6)
  832          format(8x,4d16.6)
  830    continue
      endif

c
c
c For variable time stepping, use max speed seen on this grid to
c choose the allowable new time step dtnew.  This will later be
c compared to values seen on other grids.
c  NB: orig code tested cflgrid, but with dimensional splitting
c  there are 2 - one for each x and y steps, so changed 12/23/14 (mjb)
c  to use level
c
       if (cfl_level .gt. 0.d0) then
           dtnew = dt*cfl/cfl_level
         else
c          # velocities are all zero on this grid so there's no
c          # time step restriction coming from this grid.
            dtnew = rinfinity
          endif

c     # give a warning if Courant number too large...
c
      if (cflgrid .gt. cflv1) then
            write(*,810) cflgrid
            write(outunit,810) cflgrid, cflv1
  810       format('*** WARNING *** Courant number  =', d12.4,
     &              '  is larger than input cfl_max = ', d12.4)
            endif
c
      if (dump) then
         write(outunit,*) "dumping grid ",mptr," after stepgrid"
         do i = 1, mitot
         do j = 1, mjtot
            write(outunit,545) i,j,(q(ivar,i,j),ivar=1,nvar)
         end do
         end do
      endif
      return
      end


      SUBROUTINE SNVDEC(IOP,MD,ND,M,N,A,NOS,B,IAC,ZTEST,Q,V,IRANK,APLUS,
     1 IERR)
C
      INTEGER IAC,IERR,IOP,IRANK,M,MD,N,ND,NOS
      DOUBLE PRECISION A(MD,N),APLUS(ND,N),B(MD,NOS),Q(N),V(ND,N)
      DOUBLE PRECISION ZTEST
C
C   PURPOSE:
C     Compute the singular-value decomposition of a real m x n matrix A.
C
C   REFERENCES:
C     Wilkinson, J.H.; and Reinsch, C.: Handbook for Automatic Compu-
C        tation. Volume II - Linear Algebra. Springer-Verlag, 1971.
C        See pp.135-151 for computational procedure.
C
C   Subroutines employed by SNVDEC: DSVDC
C   Fortran-77 functions employed by SNVDEC: SQRT,MIN,POWER [X**Y]
C   Subroutines employing SNVDEC: CTROL, CSTAB, DSTAB, FACTOR
C
C   Modified to LINPACK form by: John L. Tietze, Boeing Aerospace Co.
C                Latest Version: November 10, 1981
C
C
C   ON ENTRY:
C
C     IOP      INTEGER
C              OPTION CODE WITH FOLLOWING MEANINGS:
C                = 1  RETURN RANK AND SINGULAR VALUES OF A
C                = 2  IOP= 1 INFORMATION PLUS U AND V MATRICES
C                = 3  IOP= 2 INFORMATION PLUS LEAST SQUARES
C                     SOLUTION OF A*X= B
C                = 4  IOP= 2 INFORMATION PLUS PSEUDOINVERSE OF A
C                = 5  IOP= 4 INFORMATION PLUS LEAST SQUARES
C                     SOLUTION OF A*X= B
C
C     MD       INTEGER
C              LEADING DIMENSION OF A AND B MATRICES
C
C     ND       INTEGER
C              LEADING DIMENSION OF V AND APLUS MATRICES
C
C     M        INTEGER
C              NUMBER OF ROWS IN A MATRIX
C
C     N        INTEGER
C              NUMBER OF COLUMNS IN A MATRIX
C
C     A        DOUBLE PRECISION (MD,N)
C              INPUT MATRIX, DESTROYED BY COMPUTATION
C
C     NOS      INTEGER
C              NUMBER OF COLUMNS IN B MATRIX
C
C     B        DOUBLE PRECISION (MD,NOS)
C              B CONTAINS THE NOS RIGHT HAND SIDES TO BE
C              SOLVED FOR IF IOP= 3 OR IOP= 5. B MAY BE
C              A DUMMY VARIABLE IF NOT REFERENCED.
C
C     IAC      INTEGER
C              NUMBER OF DECIMAL DIGITS OF ACCURACY IN THE
C              ELEMENTS OF THE A MATRIX. THIS PARAMETER
C              IS USED IN THE RANK DETERMINATION TEST.
C
C  ON RETURN:
C
C     A        DOUBLE PRECISION (MD,N)
C              A CONTAINS THE ORTHOGONAL MATRIX U WHEN IOP>1
C
C     B        DOUBLE PRECISION (MD,NOS)
C              B CONTAINS THE LEAST SQUARES SOLUTION WHEN
C              IOP= 3 OR IOP= 5
C
C     ZTEST    DOUBLE PRECISION
C              ZERO CRITERION FOR RANK TEST, COMPUTED AS
C              NORM(A)*10**-IAC. NORM(A) IS THE EUCLIDEAN
C              MATRIX NORM. NORM(A)= 1 IF N= 1.
C
C     Q        DOUBLE PRECISION (MIN(M+1,N))
C              SINGULAR VALUES OF A MATRIX IN DESCENDING ORDER.
C
C     V        DOUBLE PRECISION (ND,N)
C              LEFT SINGULAR VECTORS OF A MATRIX WHEN IOP>1.
C
C     IRANK    INTEGER
C              RANK OF A MATRIX DETERMINED FROM THE SINGULAR
C              VALUES AND ZTEST.
C
C     APLUS    DOUBLE PRECISION (ND,N)
C              PSEUDOINVERSE OF A MATRIX IF IOP= 4 OR IOP= 5.
C              APLUS MAY BE A DUMMY VARIABLE IF NOT REFERENCED.
C
C     IERR     INTEGER
C               ERROR INDICATOR:
C                  = 0     A NORMAL RETURN
C                  = K > 0 SINGULAR VALUES FROM K+1 ON HAVE NOT BEEN
C                          FOUND BECAUSE THE QR ITERATION TOOK MORE
C                          THAN 30 PASSES.
C                  = -1    USING THE GIVEN IAC, THE A MATRIX IS CLOSE
C                          TO A MATRIX OF LOWER RANK.
C                  = -2    MATRIX HAS ZERO RANK
C                  = -3    HAVE EXCEEDED THE INTERNAL STORAGE CAPACITY
C                          OF THE E VECTOR.
C
C  LOCAL VARIABLES:
      DOUBLE PRECISION E(150)
      DOUBLE PRECISION SUM
      INTEGER I,J,JOB,K,MINMN
C
C  TEST FOR  SCALAR OR VECTOR A
C
      IF( N .GE. 2 ) GO TO 3000
C
          IERR = 0
          ZTEST = 10.**(-IAC)
          SUM = 0.0
          DO 1000 I=1,M
              SUM = SUM + A(I,1)*A(I,1)
 1000     CONTINUE
          SUM = SQRT(SUM)
          IRANK = 0
          IF( SUM .GT. ZTEST ) IRANK = 1
          Q(1) = SUM
C
          IF( IOP .EQ. 1) GO TO 3500
          V(1,1) = 1.0
          IF( IRANK .EQ. 0 ) GO TO 1200
              DO 1100 I =1,M
                  A(I,1) = A(I,1)/SUM
 1100         CONTINUE
              GO TO 1300
 1200     CONTINUE
          A(1,1) = 1.0
 1300     CONTINUE
C
          IF( IOP .EQ. 2 ) GO TO 3500
          IF( IOP .EQ. 4 ) GO TO 1850
              IF( IRANK .EQ. 0 ) GO TO 1600
                  DO 1500 J = 1,NOS
                      SUM = 0.0
                      DO 1400 I = 1,M
                          SUM = SUM + A(I,1)*B(I,J)/SUM
 1400                 CONTINUE
                      B(1,J) = SUM
 1500             CONTINUE
                  GO TO 1800
 1600         CONTINUE
              DO 1700 J =1,NOS
                  B(1,J) = 0.0
 1700         CONTINUE
 1800         CONTINUE
C
              IF( IOP .EQ. 3 ) GO TO 3500
 1850     CONTINUE
          IF( IRANK .EQ. 0 ) GO TO 2000
              DO 1900 I =1,M
                  APLUS(1,I) = A(I,1)/SUM
 1900         CONTINUE
              GO TO 3500
 2000     CONTINUE
          DO 2100 I=1,M
              APLUS(1,I) = 0.0
 2100     CONTINUE
          GO TO 3500
C
C
 3000 CONTINUE
C
C  COMPUTE THE E-NORM OF MATRIX A AS ZERO TEST FOR SINGULAR VALUES
C
      SUM=0.0D0
      DO 3010 I=1,M
        DO 3010 J=1,N
 3010     SUM = SUM + A(I,J)**2
      ZTEST = SQRT(SUM)*10.0**(-IAC)
C
C   EXECUTIVE CALL TO LINPACK SINGULAR VALUE SUBROUTINE HERE
C   CHECK FOR PROBLEM BIGGER THAN LOCAL ARRAY FIRST
C
      MINMN= MIN (M,N)
      IF (M + MINMN.GT.150) GO TO 4000
C
C  MAY WANT TO MODIFIY THIS FOR LARGE SYSTEMS WHERE M>>N, SEE LINPACK
C  WRITE UP ON SINGULAR VALUE FACTORIZATION.
      JOB= 0
      IF (IOP.GT.1) JOB= 11
C****
      CALL DSVDC (A,MD,M,N,Q,E(M+1),A,MD,V,ND,E,JOB,IERR)
C****
      IF (IERR.GT.0) GO TO 3500
C
C  DETERMINE RANK
      DO 3020 I= 1,MINMN
          IRANK= MINMN+1-I
          IF (Q(IRANK).GT.ZTEST) GO TO 3030
 3020 CONTINUE
      IRANK= 0
      IERR= -2
      GO TO 3500
 3030 CONTINUE
      IF (ZTEST/Q(IRANK).GT..0625D0) IERR= -1
      IF (IOP.LT.3) GO TO 3500
      IF (IOP.EQ.4) GO TO 3100
C
C  GET LEAST-SQUARES SOLUTION, E IS TEMPORARY STORAGE AND
C  A CONTAINS THE LEFT SINGULAR VECTORS
      DO 3080  K=1,NOS
         DO 3050  J=1,IRANK
            SUM=0.0
            DO 3040  I=1,M
 3040          SUM =SUM + A(I,J)*B(I,K)
 3050    E(J)= SUM/Q(J)
C
         DO 3070  J=1,N
            SUM=0.0
            DO 3060  I=1,IRANK
 3060         SUM =SUM  + V(J,I)*E(I)
 3070    B(J,K)=SUM
 3080 CONTINUE
      IF (IOP.LT.4) GO TO 3500
C
C  COMPUTE THE PSEUDOINVERSE  -  IS THIS REALLY NEEDED ???
C
 3100 DO 3130  J=1,M
         DO 3120  I=1,N
            SUM=0.0
            DO 3110  K=1,IRANK
 3110          SUM =SUM + V(I,K)*A(J,K)/Q(K)
 3120       APLUS(I,J)= SUM
 3130 CONTINUE
C
C------------------------------------------- END -----------------------
C
 3500 CONTINUE
      RETURN
C
C  ERROR EXIT
 4000 J= M + MIN(M,N)
      WRITE (6,4010) J
 4010 FORMAT (//15X,'**** M + MIN(M,N) =',I4,' IN SNVDEC.'
     1 /15X,'THIS EXCEEDS THE INTERNAL SPECIFICATION ON',
     2 ' THE E VECTOR OF 150.'/15X,'SNVDEC WILL BE BYPASSED.')
      IERR= -2
      RETURN
C
      END


!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 2011 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                     FFTPACK  version 5.1                      *
!     *                                                               *
!     *                 A Fortran Package of Fast Fourier             *
!     *                                                               *
!     *                Subroutines and Example Programs               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *               Paul Swarztrauber and Dick Valent               *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!     parameter(lensav=2*(l+m) + int(log(real(l))/log(2.))
!    .                         + int(log(real(m))/log(2.)) + 8)
program tcfft2

    use, intrinsic :: ISO_Fortran_env, only: &
        wp => REAL64, &
        ip => INT32, &
        stdout => OUTPUT_UNIT, &
        stderr => ERROR_UNIT

    use type_FFTpack, only: FFTpack

    ! Explicit typing only
    implicit none

    !------------------------------------------------------------------
    ! Dictionary
    !------------------------------------------------------------------
    type (FFTpack)          :: my_fft
    integer (ip), parameter :: l=100, m=100
    complex (wp)            :: complex_data(l,m)
    real (wp)               :: real_part(l,m), imaginary_part(l,m)
    !------------------------------------------------------

    !
    !==> Identify test and initialize FFT
    !
    write( stdout, '(A)') 'program fft2 (complex) and related messages:'

    !
    !==> generate test matrix for forward-backward test
    !
    call get_random_matrix(real_part, imaginary_part, complex_data)

    !
    !==> perform forward transform
    !
    call my_fft%fft2(complex_data)

    !
    !==> perform backward transform
    !
    call my_fft%ifft2(complex_data)

    !
    !==> Print test results
    !
    associate( max_err => maxval(abs(complex_data-cmplx(real_part,imaginary_part,kind=wp))) )

        write( stdout, '(A,E23.15E3)' ) 'fft2 (complex) forward-backward max error =', max_err

    end associate

    !==> generate test matrix for backward-forward test

    call get_random_matrix(real_part, imaginary_part, complex_data)

    !==> perform backward transform

    call my_fft%ifft2(complex_data)

    !==> perform forward transform
    !
    call my_fft%fft2(complex_data)

    !
    !==> Print test results
    !
    associate( max_err => maxval(abs(complex_data-cmplx(real_part,imaginary_part,kind=wp))) )

        write( stdout, '(A,E23.15E3)' ) 'fft2 (complex) backward-forward max error =', max_err
        write( stdout, '(A,/)') 'end program tcfft2 and related messages'

    end associate

contains

    subroutine get_random_matrix(real_part, imaginary_part, complex_data)
        !--------------------------------------------------
        ! Dictionary: calling arguments
        !--------------------------------------------------
        real (wp),    intent (out) :: real_part(:,:)
        real (wp),    intent (out) :: imaginary_part(:,:)
        complex (wp), intent (out) :: complex_data(:,:)
        !--------------------------------------------------

        call random_seed()
        call random_number(real_part)
        call random_number(imaginary_part)

        complex_data = cmplx(real_part, imaginary_part, kind=wp)

    end subroutine get_random_matrix

end program tcfft2


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c ... file vlapec.f
c
c     this file includes documentation and code for
c     subroutine vlapec          i
c
c ... files which must be loaded with vlapec.f
c
c     sphcom.f, hrfft.f, vhaec.f, vhsec.f
c
c
c     subroutine vlapec(nlat,nlon,ityp,nt,vlap,wlap,idvw,jdvw,br,bi,cr,ci,
c    +mdbc,ndbc,wvhsec,lvhsec,work,lwork,ierror)
c
c
c     subroutine vlapec computes the vector laplacian of the vector field
c     (v,w) in (vlap,wlap) (see the definition of the vector laplacian at
c     the output parameter description of vlap,wlap below).  w and wlap
c     are east longitudinal components of the vectors.  v and vlap are
c     colatitudinal components of the vectors.  br,bi,cr, and ci are the
c     vector harmonic coefficients of (v,w).  these must be precomputed by
c     vhaec and are input parameters to vlapec.  the laplacian components
c     in (vlap,wlap) have the same symmetry or lack of symmetry about the
c     equator as (v,w).  the input parameters ityp,nt,mdbc,nbdc must have
c     the same values used by vhaec to compute br,bi,cr, and ci for (v,w).
c     vlap(i,j) and wlap(i,j) are given on the sphere at the colatitude
c
c            theta(i) = (i-1)*pi/(nlat-1)
c
c     for i=1,...,nlat and east longitude
c
c            lambda(j) = (j-1)*2*pi/nlon
c
c     for j=1,...,nlon.
c
c
c     input parameters
c
c     nlat   the number of colatitudes on the full sphere including the
c            poles. for example, nlat = 37 for a five degree grid.
c            nlat determines the grid increment in colatitude as
c            pi/(nlat-1).  if nlat is odd the equator is located at
c            grid point i=(nlat+1)/2. if nlat is even the equator is
c            located half way between points i=nlat/2 and i=nlat/2+1.
c            nlat must be at least 3. note: on the half sphere, the
c            number of grid points in the colatitudinal direction is
c            nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct longitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than zero. the axisymmetric case corresponds to nlon=1.
c            the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c     ityp   this parameter should have the same value input to subroutine
c            vhaec to compute the coefficients br,bi,cr, and ci for the
c            vector field (v,w).  ityp is set as follows:
c
c            = 0  no symmetries exist in (v,w) about the equator. (vlap,wlap)
c                 is computed and stored on the entire sphere in the arrays
c                 vlap(i,j) and wlap(i,j) for i=1,...,nlat and j=1,...,nlon.
c
c
c            = 1  no symmetries exist in (v,w) about the equator. (vlap,wlap)
c                 is computed and stored on the entire sphere in the arrays
c                 vlap(i,j) and wlap(i,j) for i=1,...,nlat and j=1,...,nlon.
c                 the vorticity of (v,w) is zero so the coefficients cr and
c                 ci are zero and are not used.  the vorticity of (vlap,wlap)
c                 is also zero.
c
c
c            = 2  no symmetries exist in (v,w) about the equator. (vlap,wlap)
c                 is computed and stored on the entire sphere in the arrays
c                 vlap(i,j) and wlap(i,j) for i=1,...,nlat and j=1,...,nlon.
c                 the divergence of (v,w) is zero so the coefficients br and
c                 bi are zero and are not used.  the divergence of (vlap,wlap)
c                 is also zero.
c
c            = 3  w is antisymmetric and v is symmetric about the equator.
c                 consequently wlap is antisymmetric and vlap is symmetric.
c                 (vlap,wlap) is computed and stored on the northern
c                 hemisphere only.  if nlat is odd, storage is in the arrays
c                 vlap(i,j),wlap(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
c                 if nlat is even, storage is in the arrays vlap(i,j),
c                 wlap(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c            = 4  w is antisymmetric and v is symmetric about the equator.
c                 consequently wlap is antisymmetric and vlap is symmetric.
c                 (vlap,wlap) is computed and stored on the northern
c                 hemisphere only.  if nlat is odd, storage is in the arrays
c                 vlap(i,j),wlap(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
c                 if nlat is even, storage is in the arrays vlap(i,j),
c                 wlap(i,j) for i=1,...,nlat/2 and j=1,...,nlon.  the
c                 vorticity of (v,w) is zero so the coefficients cr,ci are
c                 zero and are not used. the vorticity of (vlap,wlap) is
c                 also zero.
c
c            = 5  w is antisymmetric and v is symmetric about the equator.
c                 consequently wlap is antisymmetric and vlap is symmetric.
c                 (vlap,wlap) is computed and stored on the northern
c                 hemisphere only.  if nlat is odd, storage is in the arrays
c                 vlap(i,j),wlap(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
c                 if nlat is even, storage is in the arrays vlap(i,j),
c                 wlap(i,j) for i=1,...,nlat/2 and j=1,...,nlon.  the
c                 divergence of (v,w) is zero so the coefficients br,bi
c                 are zero and are not used. the divergence of (vlap,wlap)
c                 is also zero.
c
c
c            = 6  w is symmetric and v is antisymmetric about the equator.
c                 consequently wlap is symmetric and vlap is antisymmetric.
c                 (vlap,wlap) is computed and stored on the northern
c                 hemisphere only.  if nlat is odd, storage is in the arrays
c                 vlap(i,j),wlap(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
c                 if nlat is even, storage is in the arrays vlap(i,j),
c                 wlap(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c            = 7  w is symmetric and v is antisymmetric about the equator.
c                 consequently wlap is symmetric and vlap is antisymmetric.
c                 (vlap,wlap) is computed and stored on the northern
c                 hemisphere only.  if nlat is odd, storage is in the arrays
c                 vlap(i,j),wlap(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
c                 if nlat is even, storage is in the arrays vlap(i,j),
c                 wlap(i,j) for i=1,...,nlat/2 and j=1,...,nlon.  the
c                 vorticity of (v,w) is zero so the coefficients cr,ci are
c                 zero and are not used. the vorticity of (vlap,wlap) is
c                 also zero.
c
c            = 8  w is symmetric and v is antisymmetric about the equator.
c                 consequently wlap is symmetric and vlap is antisymmetric.
c                 (vlap,wlap) is computed and stored on the northern
c                 hemisphere only.  if nlat is odd, storage is in the arrays
c                 vlap(i,j),wlap(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
c                 if nlat is even, storage is in the arrays vlap(i,j),
c                 wlap(i,j) for i=1,...,nlat/2 and j=1,...,nlon.  the
c                 divergence of (v,w) is zero so the coefficients br,bi
c                 are zero and are not used. the divergence of (vlap,wlap)
c                 is also zero.
c
c
c     nt     nt is the number of vector fields (v,w).  some computational
c            efficiency is obtained for multiple fields.  in the program
c            that calls vlapec, the arrays vlap,wlap,br,bi,cr and ci
c            can be three dimensional corresponding to an indexed multiple
c            vector field.  in this case multiple vector synthesis will
c            be performed to compute the vector laplacian for each field.
c            the third index is the synthesis index which assumes the values
c            k=1,...,nt.  for a single synthesis set nt=1.  the description
c            of the remaining parameters is simplified by assuming that nt=1
c            or that all arrays are two dimensional.
c
c   idvw     the first dimension of the arrays vlap and wlap as it appears
c            in the program that calls vlapec.  if ityp=0,1, or 2  then idvw
c            must be at least nlat.  if ityp > 2 and nlat is even then idvw
c            must be at least nlat/2. if ityp > 2 and nlat is odd then idvw
c            must be at least (nlat+1)/2.
c
c   jdvw     the second dimension of the arrays vlap and wlap as it appears
c            in the program that calls vlapec. jdvw must be at least nlon.
c
c
c   br,bi    two or three dimensional arrays (see input parameter nt)
c   cr,ci    that contain vector spherical harmonic coefficients
c            of the vector field (v,w) as computed by subroutine vhaec.
c            br,bi,cr and ci must be computed by vhaec prior to calling
c            vlapec.  if ityp=1,4, or 7 then cr,ci are not used and can
c            be dummy arguments.  if ityp=2,5, or 8 then br,bi are not
c            used and can be dummy arguments.
c
c    mdbc    the first dimension of the arrays br,bi,cr and ci as it
c            appears in the program that calls vlapec.  mdbc must be
c            at least min0(nlat,nlon/2) if nlon is even or at least
c            min0(nlat,(nlon+1)/2) if nlon is odd.
c
c    ndbc    the second dimension of the arrays br,bi,cr and ci as it
c            appears in the program that calls vlapec. ndbc must be at
c            least nlat.
c
c    wvhsec  an array which must be initialized by subroutine vhseci.
c            once initialized, wvhsec
c            can be used repeatedly by vlapec as long as nlat and nlon
c            remain unchanged.  wvhsec must not be altered between calls
c            of vlapec.
c
c    lvhsec  the dimension of the array wvhsec as it appears in the
c            program that calls vlapec.  let
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd.
c
c            then lvhsec must be at least
c
c            4*nlat*l2+3*max0(l1-2,0)*(nlat+nlat-l1-1)+nlon+15

c            (see ierror=9 below).
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls vlapec. define
c
c               l2 = nlat/2                    if nlat is even or
c               l2 = (nlat+1)/2                if nlat is odd
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c
c            if ityp .le. 2 then
c
c               nlat*(2*nt*nlon+max0(6*l2,nlon)) + nlat*(4*nt*l1+1)
c
c            or if ityp .gt. 2 let
c
c               l2*(2*nt*nlon+max0(6*nlat,nlon)) + nlat*(4*nt*l1+1)
c
c            will suffice as a minimum length for lwork
c            (see ierror=10 below)
c
c     **************************************************************
c
c     output parameters
c
c
c    vlap,   two or three dimensional arrays (see input parameter nt) that
c    wlap    contain the vector laplacian of the field (v,w).  wlap(i,j) is
c            the east longitude component and vlap(i,j) is the colatitudinal
c            component of the vector laplacian.  the definition of the
c            vector laplacian follows:
c
c            let cost and sint be the cosine and sine at colatitude theta.
c            let d( )/dlambda  and d( )/dtheta be the first order partial
c            derivatives in longitude and colatitude.  let del2 be the scalar
c            laplacian operator
c
c                 del2(s) = [d(sint*d(s)/dtheta)/dtheta +
c                             2            2
c                            d (s)/dlambda /sint]/sint
c
c            then the vector laplacian opeator
c
c                 dvel2(v,w) = (vlap,wlap)
c
c            is defined by
c
c                 vlap = del2(v) - (2*cost*dw/dlambda + v)/sint**2
c
c                 wlap = del2(w) + (2*cost*dv/dlambda - w)/sint**2
c
c  ierror    a parameter which flags errors in input parameters as follows:
c
c            = 0  no errors detected
c
c            = 1  error in the specification of nlat
c
c            = 2  error in the specification of nlon
c
c            = 3  error in the specification of ityp
c
c            = 4  error in the specification of nt
c
c            = 5  error in the specification of idvw
c
c            = 6  error in the specification of jdvw
c
c            = 7  error in the specification of mdbc
c
c            = 8  error in the specification of ndbc
c
c            = 9  error in the specification of lvhsec
c
c            = 10 error in the specification of lwork (lwork < lwkmin)
c
c
c **********************************************************************
c
c     end of documentation for vlapec
c
c **********************************************************************
c
      subroutine vlapec(nlat,nlon,ityp,nt,vlap,wlap,idvw,jdvw,br,bi,
     +cr,ci,mdbc,ndbc,wvhsec,lvhsec,work,lwork,ierror)
      dimension vlap(idvw,jdvw,nt),wlap(idvw,jdvw,nt)
      dimension br(mdbc,ndbc,nt),bi(mdbc,ndbc,nt)
      dimension cr(mdbc,ndbc,nt),ci(mdbc,ndbc,nt)
      dimension wvhsec(lvhsec),work(lwork)
      ierror = 1
      if(nlat .lt. 3) return
      ierror = 2
      if(nlon .lt. 1) return
      ierror = 3
      if(ityp.lt.0 .or. ityp.gt.8) return
      ierror = 4
      if(nt .lt. 0) return
      ierror = 5
      imid = (nlat+1)/2
      if((ityp.le.2 .and. idvw.lt.nlat) .or.
     1   (ityp.gt.2 .and. idvw.lt.imid)) return
      ierror = 6
      if(jdvw .lt. nlon) return
      ierror = 7
      mmax = min0(nlat,(nlon+1)/2)
      if(mdbc .lt. mmax) return
      ierror = 8
      if(ndbc .lt. nlat) return
      ierror = 9
      idz = (mmax*(nlat+nlat-mmax+1))/2
      lzimn = idz*imid
c
c     check saved work space
c
      l1 = min0(nlat,(nlon+1)/2)
      l2 = (nlat+1)/2
      lwmin = 4*nlat*l2+3*max0(l1-2,0)*(nlat+nlat-l1-1)+nlon+15
      if (lvhsec .lt. lwmin) return
c
c     verify unsaved work space length
c
      ierror = 10
      mn = mmax*nlat*nt
      if(ityp.lt.3) then
c       no symmetry
	if (ityp.eq.0) then
c       br,bi,cr,ci nonzero
	lwkmin = nlat*(2*nt*nlon+max0(6*imid,nlon)+1)+4*mn
	else
c       br,bi or cr,ci zero
	lwkmin = nlat*(2*nt*nlon+max0(6*imid,nlon)+1)+2*mn
	end if
      else
c     symmetry about equator
	if (ityp.eq.3 .or. ityp.eq.6) then
c       br,bi,cr,ci nonzero
	lwkmin = imid*(2*nt*nlon+max0(6*nlat,nlon))+4*mn+nlat
	else
c       br,bi or cr,ci zero
	lwkmin = imid*(2*nt*nlon+max0(6*nlat,nlon))+2*mn+nlat
	end if
      end if
      if (lwork .lt. lwkmin) return
      ierror = 0
c
c     set work space pointers for vector laplacian coefficients
c
      if (ityp.eq.0 .or. ityp.eq.3 .or. ityp.eq.6) then
      ibr = 1
      ibi = ibr+mn
      icr = ibi+mn
      ici = icr+mn
      else if (ityp.eq.1 .or. ityp.eq.4 .or. ityp.eq.7) then
      ibr = 1
      ibi = ibr+mn
      icr = ibi+mn
      ici = icr
      else
      ibr = 1
      ibi = 1
      icr = ibi+mn
      ici = icr+mn
      end if
      ifn = ici + mn
      iwk = ifn + nlat
      liwk = lwork-4*mn-nlat
      call vlapec1(nlat,nlon,ityp,nt,vlap,wlap,idvw,jdvw,work(ibr),
     +work(ibi),work(icr),work(ici),mmax,work(ifn),mdbc,ndbc,br,bi,
     +cr,ci,wvhsec,lvhsec,work(iwk),liwk,ierror)
      return
      end

      subroutine vlapec1(nlat,nlon,ityp,nt,vlap,wlap,idvw,jdvw,brlap,
     +bilap,crlap,cilap,mmax,fnn,mdb,ndb,br,bi,cr,ci,wsave,lwsav,
     +wk,lwk,ierror)
      dimension vlap(idvw,jdvw,nt),wlap(idvw,jdvw,nt)
      dimension fnn(nlat),brlap(mmax,nlat,nt),bilap(mmax,nlat,nt)
      dimension crlap(mmax,nlat,nt),cilap(mmax,nlat,nt)
      dimension br(mdb,ndb,nt),bi(mdb,ndb,nt)
      dimension cr(mdb,ndb,nt),ci(mdb,ndb,nt)
      dimension wsave(lwsav),wk(lwk)
c
c     preset coefficient multiplyers
c
      do 1 n=2,nlat
      fn = float(n-1)
      fnn(n) = -fn*(fn+1.)
    1 continue
c
c     set laplacian coefficients from br,bi,cr,ci
c
      if (ityp.eq.0 .or. ityp.eq.3 .or. ityp.eq.6) then
c
c     all coefficients needed
c
      do 2 k=1,nt
      do 3 n=1,nlat
      do 4 m=1,mmax
      brlap(m,n,k) = 0.0
      bilap(m,n,k) = 0.0
      crlap(m,n,k) = 0.0
      cilap(m,n,k) = 0.0
    4 continue
    3 continue
      do 5 n=2,nlat
      brlap(1,n,k) = fnn(n)*br(1,n,k)
      bilap(1,n,k) = fnn(n)*bi(1,n,k)
      crlap(1,n,k) = fnn(n)*cr(1,n,k)
      cilap(1,n,k) = fnn(n)*ci(1,n,k)
    5 continue
      do 6 m=2,mmax
      do 7 n=m,nlat
      brlap(m,n,k) = fnn(n)*br(m,n,k)
      bilap(m,n,k) = fnn(n)*bi(m,n,k)
      crlap(m,n,k) = fnn(n)*cr(m,n,k)
      cilap(m,n,k) = fnn(n)*ci(m,n,k)
    7 continue
    6 continue
    2 continue
      else if (ityp.eq.1 .or. ityp.eq.4 .or. ityp.eq.7) then
c
c     vorticity is zero so cr,ci=0 not used
c
      do 12 k=1,nt
      do 13 n=1,nlat
      do 14 m=1,mmax
      brlap(m,n,k) = 0.0
      bilap(m,n,k) = 0.0
   14 continue
   13 continue
      do 15 n=2,nlat
      brlap(1,n,k) = fnn(n)*br(1,n,k)
      bilap(1,n,k) = fnn(n)*bi(1,n,k)
   15 continue
      do 16 m=2,mmax
      do 17 n=m,nlat
      brlap(m,n,k) = fnn(n)*br(m,n,k)
      bilap(m,n,k) = fnn(n)*bi(m,n,k)
   17 continue
   16 continue
   12 continue
      else
c
c     divergence is zero so br,bi=0 not used
c
      do 22 k=1,nt
      do 23 n=1,nlat
      do 24 m=1,mmax
      crlap(m,n,k) = 0.0
      cilap(m,n,k) = 0.0
   24 continue
   23 continue
      do 25 n=2,nlat
      crlap(1,n,k) = fnn(n)*cr(1,n,k)
      cilap(1,n,k) = fnn(n)*ci(1,n,k)
   25 continue
      do 26 m=2,mmax
      do 27 n=m,nlat
      crlap(m,n,k) = fnn(n)*cr(m,n,k)
      cilap(m,n,k) = fnn(n)*ci(m,n,k)
   27 continue
   26 continue
   22 continue
      end if
c
c     sythesize coefs into vector field (vlap,wlap)
c
      call vhsec(nlat,nlon,ityp,nt,vlap,wlap,idvw,jdvw,brlap,bilap,
     +           crlap,cilap,mmax,nlat,wsave,lwsav,wk,lwk,ierror)
      return
      end