*> \brief \b CEBCHVXX
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*      SUBROUTINE CEBCHVXX( THRESH, PATH )
*
*     .. Scalar Arguments ..
*      REAL               THRESH
*      CHARACTER*3        PATH
*       ..
*
*  Purpose
*  ======
*
*> \details \b Purpose:
*> \verbatim
*>
*>  CEBCHVXX will run CGESVXX on a series of Hilbert matrices and then
*>  compare the error bounds returned by CGESVXX to see if the returned
*>  answer indeed falls within those bounds.
*>
*>  Eight test ratios will be computed.  The tests will pass if they are .LT.
*>  THRESH.  There are two cases that are determined by 1 / (SQRT( N ) * EPS).
*>  If that value is .LE. to the component wise reciprocal condition number,
*>  it uses the guaranteed case, other wise it uses the unguaranteed case.
*>
*>  Test ratios:
*>     Let Xc be X_computed and Xt be X_truth.
*>     The norm used is the infinity norm.
*>
*>     Let A be the guaranteed case and B be the unguaranteed case.
*>
*>       1. Normwise guaranteed forward error bound.
*>       A: norm ( abs( Xc - Xt ) / norm ( Xt ) .LE. ERRBND( *, nwise_i, bnd_i ) and
*>          ERRBND( *, nwise_i, bnd_i ) .LE. MAX(SQRT(N),10) * EPS.
*>          If these conditions are met, the test ratio is set to be
*>          ERRBND( *, nwise_i, bnd_i ) / MAX(SQRT(N), 10).  Otherwise it is 1/EPS.
*>       B: For this case, CGESVXX should just return 1.  If it is less than
*>          one, treat it the same as in 1A.  Otherwise it fails. (Set test
*>          ratio to ERRBND( *, nwise_i, bnd_i ) * THRESH?)
*>
*>       2. Componentwise guaranteed forward error bound.
*>       A: norm ( abs( Xc(j) - Xt(j) ) ) / norm (Xt(j)) .LE. ERRBND( *, cwise_i, bnd_i )
*>          for all j .AND. ERRBND( *, cwise_i, bnd_i ) .LE. MAX(SQRT(N), 10) * EPS.
*>          If these conditions are met, the test ratio is set to be
*>          ERRBND( *, cwise_i, bnd_i ) / MAX(SQRT(N), 10).  Otherwise it is 1/EPS.
*>       B: Same as normwise test ratio.
*>
*>       3. Backwards error.
*>       A: The test ratio is set to BERR/EPS.
*>       B: Same test ratio.
*>
*>       4. Reciprocal condition number.
*>       A: A condition number is computed with Xt and compared with the one
*>          returned from CGESVXX.  Let RCONDc be the RCOND returned by CGESVXX
*>          and RCONDt be the RCOND from the truth value.  Test ratio is set to
*>          MAX(RCONDc/RCONDt, RCONDt/RCONDc).
*>       B: Test ratio is set to 1 / (EPS * RCONDc).
*>
*>       5. Reciprocal normwise condition number.
*>       A: The test ratio is set to
*>          MAX(ERRBND( *, nwise_i, cond_i ) / NCOND, NCOND / ERRBND( *, nwise_i, cond_i )).
*>       B: Test ratio is set to 1 / (EPS * ERRBND( *, nwise_i, cond_i )).
*>
*>       6. Reciprocal componentwise condition number.
*>       A: Test ratio is set to
*>          MAX(ERRBND( *, cwise_i, cond_i ) / CCOND, CCOND / ERRBND( *, cwise_i, cond_i )).
*>       B: Test ratio is set to 1 / (EPS * ERRBND( *, cwise_i, cond_i )).
*>
*>     .. Parameters ..
*>     NMAX is determined by the largest number in the inverse of the hilbert
*>     matrix.  Precision is exhausted when the largest entry in it is greater
*>     than 2 to the power of the number of bits in the fraction of the data
*>     type used plus one, which is 24 for single precision.
*>     NMAX should be 6 for single and 11 for double.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex_lin
*
*  =====================================================================
      SUBROUTINE CEBCHVXX( THRESH, PATH )
      IMPLICIT NONE
*     .. Scalar Arguments ..
      REAL               THRESH
      CHARACTER*3        PATH

      INTEGER            NMAX, NPARAMS, NERRBND, NTESTS, KL, KU
      PARAMETER          (NMAX = 6, NPARAMS = 2, NERRBND = 3,
     $                    NTESTS = 6)

*     .. Local Scalars ..
      INTEGER            N, NRHS, INFO, I ,J, k, NFAIL, LDA,
     $                   N_AUX_TESTS, LDAB, LDAFB
      CHARACTER          FACT, TRANS, UPLO, EQUED
      CHARACTER*2        C2
      CHARACTER(3)       NGUAR, CGUAR
      LOGICAL            printed_guide
      REAL               NCOND, CCOND, M, NORMDIF, NORMT, RCOND,
     $                   RNORM, RINORM, SUMR, SUMRI, EPS,
     $                   BERR(NMAX), RPVGRW, ORCOND,
     $                   CWISE_ERR, NWISE_ERR, CWISE_BND, NWISE_BND,
     $                   CWISE_RCOND, NWISE_RCOND,
     $                   CONDTHRESH, ERRTHRESH
      COMPLEX            ZDUM

*     .. Local Arrays ..
      REAL               TSTRAT(NTESTS), RINV(NMAX), PARAMS(NPARAMS),
     $                   S(NMAX), R(NMAX),C(NMAX),RWORK(3*NMAX),
     $                   DIFF(NMAX, NMAX),
     $                   ERRBND_N(NMAX*3), ERRBND_C(NMAX*3)
      INTEGER            IPIV(NMAX)
      COMPLEX            A(NMAX,NMAX),INVHILB(NMAX,NMAX),X(NMAX,NMAX),
     $                   WORK(NMAX*3*5), AF(NMAX, NMAX),B(NMAX, NMAX),
     $                   ACOPY(NMAX, NMAX),
     $                   AB( (NMAX-1)+(NMAX-1)+1, NMAX ),
     $                   ABCOPY( (NMAX-1)+(NMAX-1)+1, NMAX ),
     $                   AFB( 2*(NMAX-1)+(NMAX-1)+1, NMAX )

*     .. External Functions ..
      REAL               SLAMCH

*     .. External Subroutines ..
      EXTERNAL           CLAHILB, CGESVXX, CSYSVXX, CPOSVXX,
     $                   CGBSVXX, CLACPY, LSAMEN
      LOGICAL            LSAMEN

*     .. Intrinsic Functions ..
      INTRINSIC          SQRT, MAX, ABS, REAL, AIMAG

*     .. Statement Functions ..
      REAL               CABS1
*     ..
*     .. Statement Function Definitions ..
      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )

*     .. Parameters ..
      INTEGER            NWISE_I, CWISE_I
      PARAMETER          (NWISE_I = 1, CWISE_I = 1)
      INTEGER            BND_I, COND_I
      PARAMETER          (BND_I = 2, COND_I = 3)

*  Create the loop to test out the Hilbert matrices

      FACT = 'E'
      UPLO = 'U'
      TRANS = 'N'
      EQUED = 'N'
      EPS = SLAMCH('Epsilon')
      NFAIL = 0
      N_AUX_TESTS = 0
      LDA = NMAX
      LDAB = (NMAX-1)+(NMAX-1)+1
      LDAFB = 2*(NMAX-1)+(NMAX-1)+1
      C2 = PATH( 2: 3 )

*     Main loop to test the different Hilbert Matrices.

      printed_guide = .false.

      DO N = 1 , NMAX
         PARAMS(1) = -1
         PARAMS(2) = -1

         KL = N-1
         KU = N-1
         NRHS = n
         M = MAX(SQRT(REAL(N)), 10.0)

*        Generate the Hilbert matrix, its inverse, and the
*        right hand side, all scaled by the LCM(1,..,2N-1).
         CALL CLAHILB(N, N, A, LDA, INVHILB, LDA, B,
     $        LDA, WORK, INFO, PATH)

*        Copy A into ACOPY.
         CALL CLACPY('ALL', N, N, A, NMAX, ACOPY, NMAX)

*        Store A in band format for GB tests
         DO J = 1, N
            DO I = 1, KL+KU+1
               AB( I, J ) = (0.0E+0,0.0E+0)
            END DO
         END DO
         DO J = 1, N
            DO I = MAX( 1, J-KU ), MIN( N, J+KL )
               AB( KU+1+I-J, J ) = A( I, J )
            END DO
         END DO

*        Copy AB into ABCOPY.
         DO J = 1, N
            DO I = 1, KL+KU+1
               ABCOPY( I, J ) = (0.0E+0,0.0E+0)
            END DO
         END DO
         CALL CLACPY('ALL', KL+KU+1, N, AB, LDAB, ABCOPY, LDAB)

*        Call C**SVXX with default PARAMS and N_ERR_BND = 3.
         IF ( LSAMEN( 2, C2, 'SY' ) ) THEN
            CALL CSYSVXX(FACT, UPLO, N, NRHS, ACOPY, LDA, AF, LDA,
     $           IPIV, EQUED, S, B, LDA, X, LDA, ORCOND,
     $           RPVGRW, BERR, NERRBND, ERRBND_N, ERRBND_C, NPARAMS,
     $           PARAMS, WORK, RWORK, INFO)
         ELSE IF ( LSAMEN( 2, C2, 'PO' ) ) THEN
            CALL CPOSVXX(FACT, UPLO, N, NRHS, ACOPY, LDA, AF, LDA,
     $           EQUED, S, B, LDA, X, LDA, ORCOND,
     $           RPVGRW, BERR, NERRBND, ERRBND_N, ERRBND_C, NPARAMS,
     $           PARAMS, WORK, RWORK, INFO)
         ELSE IF ( LSAMEN( 2, C2, 'HE' ) ) THEN
            CALL CHESVXX(FACT, UPLO, N, NRHS, ACOPY, LDA, AF, LDA,
     $           IPIV, EQUED, S, B, LDA, X, LDA, ORCOND,
     $           RPVGRW, BERR, NERRBND, ERRBND_N, ERRBND_C, NPARAMS,
     $           PARAMS, WORK, RWORK, INFO)
         ELSE IF ( LSAMEN( 2, C2, 'GB' ) ) THEN
            CALL CGBSVXX(FACT, TRANS, N, KL, KU, NRHS, ABCOPY,
     $           LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B,
     $           LDA, X, LDA, ORCOND, RPVGRW, BERR, NERRBND,
     $           ERRBND_N, ERRBND_C, NPARAMS, PARAMS, WORK, RWORK,
     $           INFO)
         ELSE
            CALL CGESVXX(FACT, TRANS, N, NRHS, ACOPY, LDA, AF, LDA,
     $           IPIV, EQUED, R, C, B, LDA, X, LDA, ORCOND,
     $           RPVGRW, BERR, NERRBND, ERRBND_N, ERRBND_C, NPARAMS,
     $           PARAMS, WORK, RWORK, INFO)
         END IF

         N_AUX_TESTS = N_AUX_TESTS + 1
         IF (ORCOND .LT. EPS) THEN
!        Either factorization failed or the matrix is flagged, and 1 <=
!        INFO <= N+1. We don't decide based on rcond anymore.
!            IF (INFO .EQ. 0 .OR. INFO .GT. N+1) THEN
!               NFAIL = NFAIL + 1
!               WRITE (*, FMT=8000) N, INFO, ORCOND, RCOND
!            END IF
         ELSE
!        Either everything succeeded (INFO == 0) or some solution failed
!        to converge (INFO > N+1).
            IF (INFO .GT. 0 .AND. INFO .LE. N+1) THEN
               NFAIL = NFAIL + 1
               WRITE (*, FMT=8000) C2, N, INFO, ORCOND, RCOND
            END IF
         END IF

*        Calculating the difference between C**SVXX's X and the true X.
         DO I = 1,N
            DO J =1,NRHS
               DIFF(I,J) = X(I,J) - INVHILB(I,J)
            END DO
         END DO

*        Calculating the RCOND
         RNORM = 0
         RINORM = 0
         IF ( LSAMEN( 2, C2, 'PO' ) .OR. LSAMEN( 2, C2, 'SY' ) .OR.
     $        LSAMEN( 2, C2, 'HE' ) ) THEN
            DO I = 1, N
               SUMR = 0
               SUMRI = 0
               DO J = 1, N
                  SUMR = SUMR + S(I) * CABS1(A(I,J)) * S(J)
                  SUMRI = SUMRI + CABS1(INVHILB(I, J)) / (S(J) * S(I))
               END DO
               RNORM = MAX(RNORM,SUMR)
               RINORM = MAX(RINORM,SUMRI)
            END DO
         ELSE IF ( LSAMEN( 2, C2, 'GE' ) .OR. LSAMEN( 2, C2, 'GB' ) )
     $           THEN
            DO I = 1, N
               SUMR = 0
               SUMRI = 0
               DO J = 1, N
                  SUMR = SUMR + R(I) * CABS1(A(I,J)) * C(J)
                  SUMRI = SUMRI + CABS1(INVHILB(I, J)) / (R(J) * C(I))
               END DO
               RNORM = MAX(RNORM,SUMR)
               RINORM = MAX(RINORM,SUMRI)
            END DO
         END IF

         RNORM = RNORM / CABS1(A(1, 1))
         RCOND = 1.0/(RNORM * RINORM)

*        Calculating the R for normwise rcond.
         DO I = 1, N
            RINV(I) = 0.0
         END DO
         DO J = 1, N
            DO I = 1, N
               RINV(I) = RINV(I) + CABS1(A(I,J))
            END DO
         END DO

*        Calculating the Normwise rcond.
         RINORM = 0.0
         DO I = 1, N
            SUMRI = 0.0
            DO J = 1, N
               SUMRI = SUMRI + CABS1(INVHILB(I,J) * RINV(J))
            END DO
            RINORM = MAX(RINORM, SUMRI)
         END DO

!        invhilb is the inverse *unscaled* Hilbert matrix, so scale its norm
!        by 1/A(1,1) to make the scaling match A (the scaled Hilbert matrix)
         NCOND = CABS1(A(1,1)) / RINORM

         CONDTHRESH = M * EPS
         ERRTHRESH = M * EPS

         DO K = 1, NRHS
            NORMT = 0.0
            NORMDIF = 0.0
            CWISE_ERR = 0.0
            DO I = 1, N
               NORMT = MAX(CABS1(INVHILB(I, K)), NORMT)
               NORMDIF = MAX(CABS1(X(I,K) - INVHILB(I,K)), NORMDIF)
               IF (INVHILB(I,K) .NE. 0.0) THEN
                  CWISE_ERR = MAX(CABS1(X(I,K) - INVHILB(I,K))
     $                            /CABS1(INVHILB(I,K)), CWISE_ERR)
               ELSE IF (X(I, K) .NE. 0.0) THEN
                  CWISE_ERR = SLAMCH('OVERFLOW')
               END IF
            END DO
            IF (NORMT .NE. 0.0) THEN
               NWISE_ERR = NORMDIF / NORMT
            ELSE IF (NORMDIF .NE. 0.0) THEN
               NWISE_ERR = SLAMCH('OVERFLOW')
            ELSE
               NWISE_ERR = 0.0
            ENDIF

            DO I = 1, N
               RINV(I) = 0.0
            END DO
            DO J = 1, N
               DO I = 1, N
                  RINV(I) = RINV(I) + CABS1(A(I, J) * INVHILB(J, K))
               END DO
            END DO
            RINORM = 0.0
            DO I = 1, N
               SUMRI = 0.0
               DO J = 1, N
                  SUMRI = SUMRI
     $                 + CABS1(INVHILB(I, J) * RINV(J) / INVHILB(I, K))
               END DO
               RINORM = MAX(RINORM, SUMRI)
            END DO
!        invhilb is the inverse *unscaled* Hilbert matrix, so scale its norm
!        by 1/A(1,1) to make the scaling match A (the scaled Hilbert matrix)
            CCOND = CABS1(A(1,1))/RINORM

!        Forward error bound tests
            NWISE_BND = ERRBND_N(K + (BND_I-1)*NRHS)
            CWISE_BND = ERRBND_C(K + (BND_I-1)*NRHS)
            NWISE_RCOND = ERRBND_N(K + (COND_I-1)*NRHS)
            CWISE_RCOND = ERRBND_C(K + (COND_I-1)*NRHS)
!            write (*,*) 'nwise : ', n, k, ncond, nwise_rcond,
!     $           condthresh, ncond.ge.condthresh
!            write (*,*) 'nwise2: ', k, nwise_bnd, nwise_err, errthresh
            IF (NCOND .GE. CONDTHRESH) THEN
               NGUAR = 'YES'
               IF (NWISE_BND .GT. ERRTHRESH) THEN
                  TSTRAT(1) = 1/(2.0*EPS)
               ELSE
                  IF (NWISE_BND .NE. 0.0) THEN
                     TSTRAT(1) = NWISE_ERR / NWISE_BND
                  ELSE IF (NWISE_ERR .NE. 0.0) THEN
                     TSTRAT(1) = 1/(16.0*EPS)
                  ELSE
                     TSTRAT(1) = 0.0
                  END IF
                  IF (TSTRAT(1) .GT. 1.0) THEN
                     TSTRAT(1) = 1/(4.0*EPS)
                  END IF
               END IF
            ELSE
               NGUAR = 'NO'
               IF (NWISE_BND .LT. 1.0) THEN
                  TSTRAT(1) = 1/(8.0*EPS)
               ELSE
                  TSTRAT(1) = 1.0
               END IF
            END IF
!            write (*,*) 'cwise : ', n, k, ccond, cwise_rcond,
!     $           condthresh, ccond.ge.condthresh
!            write (*,*) 'cwise2: ', k, cwise_bnd, cwise_err, errthresh
            IF (CCOND .GE. CONDTHRESH) THEN
               CGUAR = 'YES'
               IF (CWISE_BND .GT. ERRTHRESH) THEN
                  TSTRAT(2) = 1/(2.0*EPS)
               ELSE
                  IF (CWISE_BND .NE. 0.0) THEN
                     TSTRAT(2) = CWISE_ERR / CWISE_BND
                  ELSE IF (CWISE_ERR .NE. 0.0) THEN
                     TSTRAT(2) = 1/(16.0*EPS)
                  ELSE
                     TSTRAT(2) = 0.0
                  END IF
                  IF (TSTRAT(2) .GT. 1.0) TSTRAT(2) = 1/(4.0*EPS)
               END IF
            ELSE
               CGUAR = 'NO'
               IF (CWISE_BND .LT. 1.0) THEN
                  TSTRAT(2) = 1/(8.0*EPS)
               ELSE
                  TSTRAT(2) = 1.0
               END IF
            END IF

!     Backwards error test
            TSTRAT(3) = BERR(K)/EPS

!     Condition number tests
            TSTRAT(4) = RCOND / ORCOND
            IF (RCOND .GE. CONDTHRESH .AND. TSTRAT(4) .LT. 1.0)
     $         TSTRAT(4) = 1.0 / TSTRAT(4)

            TSTRAT(5) = NCOND / NWISE_RCOND
            IF (NCOND .GE. CONDTHRESH .AND. TSTRAT(5) .LT. 1.0)
     $         TSTRAT(5) = 1.0 / TSTRAT(5)

            TSTRAT(6) = CCOND / NWISE_RCOND
            IF (CCOND .GE. CONDTHRESH .AND. TSTRAT(6) .LT. 1.0)
     $         TSTRAT(6) = 1.0 / TSTRAT(6)

            DO I = 1, NTESTS
               IF (TSTRAT(I) .GT. THRESH) THEN
                  IF (.NOT.PRINTED_GUIDE) THEN
                     WRITE(*,*)
                     WRITE( *, 9996) 1
                     WRITE( *, 9995) 2
                     WRITE( *, 9994) 3
                     WRITE( *, 9993) 4
                     WRITE( *, 9992) 5
                     WRITE( *, 9991) 6
                     WRITE( *, 9990) 7
                     WRITE( *, 9989) 8
                     WRITE(*,*)
                     PRINTED_GUIDE = .TRUE.
                  END IF
                  WRITE( *, 9999) C2, N, K, NGUAR, CGUAR, I, TSTRAT(I)
                  NFAIL = NFAIL + 1
               END IF
            END DO
      END DO

c$$$         WRITE(*,*)
c$$$         WRITE(*,*) 'Normwise Error Bounds'
c$$$         WRITE(*,*) 'Guaranteed error bound: ',ERRBND(NRHS,nwise_i,bnd_i)
c$$$         WRITE(*,*) 'Reciprocal condition number: ',ERRBND(NRHS,nwise_i,cond_i)
c$$$         WRITE(*,*) 'Raw error estimate: ',ERRBND(NRHS,nwise_i,rawbnd_i)
c$$$         WRITE(*,*)
c$$$         WRITE(*,*) 'Componentwise Error Bounds'
c$$$         WRITE(*,*) 'Guaranteed error bound: ',ERRBND(NRHS,cwise_i,bnd_i)
c$$$         WRITE(*,*) 'Reciprocal condition number: ',ERRBND(NRHS,cwise_i,cond_i)
c$$$         WRITE(*,*) 'Raw error estimate: ',ERRBND(NRHS,cwise_i,rawbnd_i)
c$$$         print *, 'Info: ', info
c$$$         WRITE(*,*)
*         WRITE(*,*) 'TSTRAT: ',TSTRAT

      END DO

      WRITE(*,*)
      IF( NFAIL .GT. 0 ) THEN
         WRITE(*,9998) C2, NFAIL, NTESTS*N+N_AUX_TESTS
      ELSE
         WRITE(*,9997) C2
      END IF
 9999 FORMAT( ' C', A2, 'SVXX: N =', I2, ', RHS = ', I2,
     $     ', NWISE GUAR. = ', A, ', CWISE GUAR. = ', A,
     $     ' test(',I1,') =', G12.5 )
 9998 FORMAT( ' C', A2, 'SVXX: ', I6, ' out of ', I6,
     $     ' tests failed to pass the threshold' )
 9997 FORMAT( ' C', A2, 'SVXX passed the tests of error bounds' )
*     Test ratios.
 9996 FORMAT( 3X, I2, ': Normwise guaranteed forward error', / 5X,
     $     'Guaranteed case: if norm ( abs( Xc - Xt )',
     $     ' / norm ( Xt ) .LE. ERRBND( *, nwise_i, bnd_i ), then',
     $     / 5X,
     $     'ERRBND( *, nwise_i, bnd_i ) .LE. MAX(SQRT(N), 10) * EPS')
 9995 FORMAT( 3X, I2, ': Componentwise guaranteed forward error' )
 9994 FORMAT( 3X, I2, ': Backwards error' )
 9993 FORMAT( 3X, I2, ': Reciprocal condition number' )
 9992 FORMAT( 3X, I2, ': Reciprocal normwise condition number' )
 9991 FORMAT( 3X, I2, ': Raw normwise error estimate' )
 9990 FORMAT( 3X, I2, ': Reciprocal componentwise condition number' )
 9989 FORMAT( 3X, I2, ': Raw componentwise error estimate' )

 8000 FORMAT( ' C', A2, 'SVXX: N =', I2, ', INFO = ', I3,
     $     ', ORCOND = ', G12.5, ', real RCOND = ', G12.5 )

      END


!*****************************************************************************************
!> author: Jacob Williams
!  date: 12/16/2015
!
!  Unit test for [[ddeabm_class]].
!  Integrate a two-body orbit around the Earth.
!  Also tests integration to an event.

    program ddeabm_test

    use ddeabm_kinds
    use ddeabm_module

    implicit none

    integer,parameter  :: n = 6            !! number of state variables
    real(wp),parameter :: tol = 1.0e-12_wp !! event location tolerance
    real(wp),parameter :: rtol = 1.0e-12_wp !! integrator tolerances
    real(wp),parameter :: atol = 1.0e-12_wp !! integrator tolerances
    integer,parameter :: maxnum = 10000  !! max func evals
    real(wp),parameter :: mu = 398600.436233_wp !! MU for Earth

    real(wp),dimension(6),parameter :: x0 = [10000.0_wp,10000.0_wp,10000.0_wp,&   !! initial state [r,v] (km,km/s)
                                             1.0_wp,2.0_wp,3.0_wp]
    real(wp),parameter :: t0 = 0.0_wp       !! initial time (sec)

    type,extends(ddeabm_with_event_class) :: spacecraft
        !! spacecraft propagation type.
        !! extends the [[ddeabm_class]] to include data used in the deriv routine
        real(wp) :: mu = mu          !! central body gravitational parameter (km3/s2)
        integer :: fevals = 0        !! number of function evaluations
        logical :: first = .true.    !! first point is being exported
    end type spacecraft

    type(spacecraft) :: s, s2
    real(wp),dimension(n) :: xf,x02,x
    real(wp) :: tf,dt,gf,tf_actual,t,gval,z_target
    integer :: idid
    integer :: icase

    write(*,*) ''
    write(*,*) '---------------'
    write(*,*) ' ddeabm_test'
    write(*,*) '---------------'
    write(*,*) ''

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

    write(*,*) ''
    write(*,*) '-----------------------'
    write(*,*) 'forward/backward test:'
    write(*,*) '-----------------------'
    write(*,*) ''

    !constructor (main body is Earth):

    call s%initialize(n,maxnum=maxnum,df=twobody,rtol=[rtol],atol=[atol],&
                        report=twobody_report)

    !initial conditions:
    tf = 1000.0_wp    !final time (sec)
    s%fevals = 0

    write(*,'(A/,*(F15.6/))') 'Initial time:',t0
    write(*,'(A/,*(F15.6/))') 'Initial state:',x0
    s%fevals = 0
    s%first = .true.
    t = t0
    x = x0
    call s%first_call()
    call s%integrate(t,x,tf,idid=idid,integration_mode=2)    !forward (report points)
    xf = x
    write(*,*) ''
    write(*,'(A/,*(I5/))')    'idid: ',idid
    write(*,'(A/,*(F15.6/))') 'Final time:',t
    write(*,'(A/,*(F15.6/))') 'Final state:',xf
    write(*,'(A,I5)') 'Function evaluations:', s%fevals
    write(*,*) ''

    t = tf
    x = xf
    s%fevals = 0
    call s%first_call()  !restarting the integration
    call s%integrate(t,x,t0,idid=idid)  !backwards
    x02 = x

    write(*,'(A/,*(I5/))')    'idid: ',idid
    write(*,'(A/,*(F15.6/))') 'Initial state:',x02
    write(*,*) ''
    write(*,'(A/,*(E20.12/))') 'Error:',x02-x0
    write(*,'(A,I5)') 'Function evaluations:', s%fevals
    write(*,*) ''

    write(*,*) ''
    write(*,*) '-----------------------'
    write(*,*) 'continue integration:'
    write(*,*) '-----------------------'
    write(*,*) ''

    t = t0
    x = x02
    tf = t0 - 100.0_wp
    s%fevals = 0
    call s%first_call()  !restarting the integration (go from t -> tf)
    call s%integrate(t,x,tf,idid=idid)  !backwards
    xf = x
    write(*,'(A/,*(I5/))')    'idid: ',idid
    write(*,'(A/,*(F15.6/))') 'Final time:',t
    write(*,'(A/,*(F15.6/))') 'Final state:',xf
    write(*,'(A,I5)') 'Function evaluations:', s%fevals
    write(*,*) ''

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

    !integration to event test (integrate until z-coordinate is 12,000 km)

    write(*,*) ''
    write(*,*) '-----------------------'
    write(*,*) 'integration to event [default steps]:'
    write(*,*) '-----------------------'
    write(*,*) ''

    call s%destroy()
    call s%initialize_event(n,maxnum=maxnum,df=twobody,rtol=[rtol],atol=[atol],&
                                g=twobody_event,root_tol=tol,report=twobody_report)
    write(*,'(A/,*(F15.6/))') 'Initial time:',t0
    write(*,'(A/,*(F15.6/))') 'Initial state:',x0
    s%fevals = 0
    s%first = .true.
    t = t0
    x = x0
    tf = 1000.0_wp    !max final time (sec)
    z_target = 12000.0_wp
    call s%first_call()
    call s%integrate_to_event(t,x,tf,idid=idid,gval=gval,integration_mode=2)
    xf = x
    write(*,*) ''
    write(*,'(A/,*(I5/))')    'idid: ',idid
    write(*,'(A/,*(F30.16/))') 'gval: ',gval
    write(*,'(A/,*(F15.6/))') 'Final time:',t
    write(*,'(A/,*(F15.6/))') 'Final state:',xf
    write(*,'(A,I5)') 'Function evaluations:', s%fevals
    write(*,*) ''

    ! write(*,*) ''
    ! write(*,*) '-----------------------'
    ! write(*,*) 'integration to event [fixed steps]:'
    ! write(*,*) '-----------------------'
    ! write(*,*) ''

    ! call s%destroy()
    ! call s%initialize_event(n,maxnum=maxnum,df=twobody,rtol=[rtol],atol=[atol],&
    !                             g=twobody_event,root_tol=tol,report=twobody_report)
    ! write(*,'(A/,*(F15.6/))') 'Initial time:',t0
    ! write(*,'(A/,*(F15.6/))') 'Initial state:',x0
    ! s%fevals = 0
    ! s%first = .true.
    ! t = t0
    ! x = x0
    ! tf = 1000.0_wp    !max final time (sec)
    ! z_target = 12000.0_wp
    ! call s%first_call()
    ! call s%integrate_to_event(t,x,tf,idid=idid,gval=gval,integration_mode=2,tstep=50.0_wp)
    ! xf = x
    ! write(*,*) ''
    ! write(*,'(A/,*(I5/))')    'idid: ',idid
    ! write(*,'(A/,*(F30.16/))') 'gval: ',gval
    ! write(*,'(A/,*(F15.6/))') 'Final time:',t
    ! write(*,'(A/,*(F15.6/))') 'Final state:',xf
    ! write(*,'(A,I5)') 'Function evaluations:', s%fevals
    ! write(*,*) ''

    ! write(*,*) '======================='
    ! write(*,*) 'integrate normally to root and compare ...'
    ! write(*,*) '======================='
    ! call s%first_call()  !have to restart the integration after a root finding
    ! tf = t
    ! t = t0
    ! x = x0
    ! call s%integrate(t,x,tf,idid=idid,integration_mode=2)
    ! call twobody_event(s,t,x,gval)
    ! write(*,*) ''
    ! write(*,'(A/,*(I5/))')    'idid: ',idid
    ! write(*,'(A/,*(F30.16/))') 'gval: ',gval
    ! write(*,'(A/,*(F15.6/))') 'Final time:',t
    ! write(*,'(A/,*(F15.6/))') 'Final state:',x
    ! write(*,*) ''

    ! write(*,*) '======================='
    ! write(*,*) 'integrate with fixed step size to root and compare ...'
    ! write(*,*) '======================='
    ! call s%first_call()  !have to restart the integration after a root finding
    ! tf = t
    ! t = t0
    ! x = x0
    ! call s%integrate(t,x,tf,idid=idid,integration_mode=2,tstep=50.0_wp)
    ! call twobody_event(s,t,x,gval)
    ! write(*,*) ''
    ! write(*,'(A/,*(I5/))')    'idid: ',idid
    ! write(*,'(A/,*(F30.16/))') 'gval: ',gval
    ! write(*,'(A/,*(F15.6/))') 'Final time:',t
    ! write(*,'(A/,*(F15.6/))') 'Final state:',x
    ! write(*,*) ''

    ! stop
    ! ! ....................

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

    ! Now, continue integration (until z-coordinate is 13,000 km)

    write(*,*) '======================='
    write(*,*) 'continue integration...'
    write(*,*) '======================='

    s%fevals = 0
    s%first = .true.
    x = xf
    tf = 2000.0_wp    !max final time (sec)
    z_target = 13000.0_wp !change the target value

    !...new ... try to continue without restarting ...
    call s%integrate_to_event(t,x,tf,idid=idid,gval=gval,integration_mode=2,tstep=50.0_wp,continue=.true.) ! test dense output here
    !call s%integrate_to_event(t,x,tf,idid=idid,gval=gval,integration_mode=2,continue=.true.) ! default points

    !...original... restart integration ...
    ! call s%first_call()  !have to restart the integration after a root finding
    ! call s%integrate_to_event(t,x,tf,idid=idid,gval=gval,integration_mode=2,tstep=50.0_wp) ! test dense output here
    ! !call s%integrate_to_event(t,x,tf,idid=idid,gval=gval,integration_mode=2) ! default points

    xf = x
    write(*,*) ''
    write(*,'(A/,*(I5/))')    'idid: ',idid
    write(*,'(A/,*(F30.16/))') 'gval: ',gval
    write(*,'(A/,*(F15.6/))') 'Final time:',t
    write(*,'(A/,*(F15.6/))') 'Final state:',xf
    write(*,'(A,I5)') 'Function evaluations:', s%fevals
    write(*,*) ''

    write(*,*) '======================='
    write(*,*) 'integrate normally to root and compare ...'
    write(*,*) '======================='

    call s2%initialize(n,maxnum=maxnum,df=twobody,rtol=[rtol],atol=[atol])
    call s2%first_call()  !have to restart the integration after a root finding
    s2%fevals = 0
    tf = t
    t = t0
    x = x0
    call s2%integrate(t,x,tf,idid=idid,integration_mode=1)
    call twobody_event(s2,t,x,gval)
    write(*,*) ''
    write(*,'(A/,*(I5/))')     'idid: ',idid
    write(*,'(A/,*(F30.16/))') 'gval: ',gval
    write(*,'(A/,*(F15.6/))')  'Initial time:',t0
    write(*,'(A/,*(F15.6/))')  'Final time:',t
    write(*,'(A/,*(F15.6/))')  'Final state:',x
    write(*,'(A,I5)') 'Function evaluations:', s2%fevals
    write(*,*) ''

    ! write(*,*) '======================='
    ! write(*,*) 'integrate with fixed step size to root and compare ...'
    ! write(*,*) '======================='
    ! call s2%initialize(n,maxnum=maxnum,df=twobody,rtol=[rtol],atol=[atol])
    ! call s2%first_call()  !have to restart the integration after a root finding
    ! s2%fevals = 0
    ! tf = t
    ! t = t0
    ! x = x0
    ! call s2%integrate(t,x,tf,idid=idid,integration_mode=1,tstep=50.0_wp)
    ! call twobody_event(s2,t,x,gval)
    ! write(*,*) ''
    ! write(*,'(A/,*(I5/))')     'idid: ',idid
    ! write(*,'(A/,*(F30.16/))') 'gval: ',gval
    ! write(*,'(A/,*(F15.6/))')  'Initial time:',t0
    ! write(*,'(A/,*(F15.6/))')  'Final time:',t
    ! write(*,'(A/,*(F15.6/))')  'Final state:',x
    ! write(*,'(A,I5)') 'Function evaluations:', s2%fevals
    ! write(*,*) ''

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

    ! !
    ! ! try continuing without root finding. This accurate for both default and fixed steps
    ! !

    ! do icase = 1, 2  !first with default steps, next with fixed steps

    !     write(*,*) ''
    !     write(*,*) '========================================================='
    !     if (icase==1) then
    !         write(*,*) ' default steps'
    !     else
    !         write(*,*) ' fixed 50 sec step'
    !     end if
    !     write(*,*) '========================================================='
    !     write(*,*) ''

    !     write(*,*) ''
    !     write(*,*) '====================================='
    !     write(*,*) ' integrate from t=0 to t=300'

    !     call s%initialize(n,maxnum=maxnum,df=twobody,rtol=[rtol],atol=[atol],&
    !                         report=twobody_report)

    !     !initial conditions:
    !     tf = 300.0_wp    !final time (sec)
    !     s%fevals = 0
    !     s%fevals = 0
    !     s%first = .true.
    !     t = t0
    !     x = x0
    !     call s%first_call()
    !     if (icase==1) then
    !         call s%integrate(t,x,tf,idid=idid,integration_mode=1)
    !     else
    !         call s%integrate(t,x,tf,idid=idid,integration_mode=1,tstep=50.0_wp)
    !     end if
    !     xf = x
    !     write(*,*) ''
    !     write(*,'(A/,*(I5/))')     'idid: ',idid
    !     write(*,'(A/,*(F15.6/))')  'Initial time:',t0
    !     write(*,'(A/,*(F15.6/))')  'Final time:',t
    !     write(*,'(A/,*(F15.6/))')  'Final state:',x
    !     write(*,'(A,I5)') 'Function evaluations:', s%fevals
    !     write(*,*) ''

    !     write(*,*) ' continue to t=600'
    !     t = tf
    !     tf = 600.0_wp
    !     if (icase==1) then
    !         call s%integrate(t,x,tf,idid=idid,integration_mode=1)
    !     else
    !         call s%integrate(t,x,tf,idid=idid,integration_mode=1,tstep=50.0_wp)
    !     end if
    !     write(*,*) ''
    !     write(*,'(A/,*(I5/))')     'idid: ',idid
    !     write(*,'(A/,*(F15.6/))')  'Final time:',t
    !     write(*,'(A/,*(F15.6/))')  'Final state:',x
    !     write(*,'(A,I5)') 'Function evaluations:', s%fevals
    !     write(*,*) ''

    !     write(*,*) ''
    !     write(*,*) '====================================='
    !     write(*,*) ' integrate all at once from t=0 to t=600'

    !     call s%initialize(n,maxnum=maxnum,df=twobody,rtol=[rtol],atol=[atol],&
    !                         report=twobody_report)
    !     !initial conditions:
    !     tf = 600.0_wp    !final time (sec)
    !     s%fevals = 0
    !     s%fevals = 0
    !     s%first = .true.
    !     t = t0
    !     x = x0
    !     call s%first_call()
    !     if (icase==1) then
    !         call s%integrate(t,x,tf,idid=idid,integration_mode=1)
    !     else
    !         call s%integrate(t,x,tf,idid=idid,integration_mode=1,tstep=50.0_wp)
    !     end if
    !     xf = x
    !     write(*,*) ''
    !     write(*,'(A/,*(I5/))')     'idid: ',idid
    !     write(*,'(A/,*(F15.6/))')  'Initial time:',t0
    !     write(*,'(A/,*(F15.6/))')  'Final time:',t
    !     write(*,'(A/,*(F15.6/))')  'Final state:',x
    !     write(*,'(A,I5)') 'Function evaluations:', s%fevals
    !     write(*,*) ''

    !     write(*,*) '====================================='

    ! end do

    contains
!*****************************************************************************************

    !*********************************************************
        subroutine twobody(me,t,x,xdot)

        !! derivative routine for two-body orbit propagation

        implicit none

        class(ddeabm_class),intent(inout) :: me
        real(wp),intent(in)               :: t
        real(wp),dimension(:),intent(in)  :: x
        real(wp),dimension(:),intent(out) :: xdot

        real(wp),dimension(3) :: r,v,a_grav
        real(wp) :: rmag

        select type (me)
        class is (spacecraft)

            r = x(1:3)
            v = x(4:6)
            rmag = norm2(r)
            a_grav = -me%mu/rmag**3 * r !acceleration due to gravity

            xdot(1:3) = v
            xdot(4:6) = a_grav

            me%fevals = me%fevals + 1

        end select

        end subroutine twobody
    !*********************************************************

    !*********************************************************
        subroutine twobody_report(me,t,x)

        !! report function - write time,state to console

        implicit none

        class(ddeabm_class),intent(inout)    :: me
        real(wp),intent(in)                  :: t
        real(wp),dimension(:),intent(in)     :: x

        select type (me)
        class is (spacecraft)
            if (me%first) then  !print header
                write(*,*) ''
                write(*,'(*(A15,1X))')  'time (sec)','x (km)','y (km)','z (km)',&
                                        'vx (km/s)','vy (km/s)','vz (km/s)'
                me%first = .false.
            end if
        end select

        write(*,'(*(F15.6,1X))') t,x

        end subroutine twobody_report
    !*********************************************************

    !*********************************************************
        subroutine twobody_event(me,t,x,g)

        !! event function for z = 12,000 km

        implicit none

        class(ddeabm_with_event_class),intent(inout) :: me
        real(wp),intent(in)                          :: t
        real(wp),dimension(:),intent(in)             :: x
        real(wp),intent(out)                         :: g

        g = z_target - x(3)  !z coordinate

        end subroutine twobody_event
    !*********************************************************

    end program ddeabm_test
!*****************************************************************************************


      REAL FUNCTION CLA_RPVGRW( N, NCOLS, A, LDA, AF, LDAF )
*
*     -- LAPACK routine (version 3.2.2)                                 --
*     -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and --
*     -- Jason Riedy of Univ. of California Berkeley.                 --
*     -- June 2010                                                    --
*
*     -- LAPACK is a software package provided by Univ. of Tennessee, --
*     -- Univ. of California Berkeley and NAG Ltd.                    --
*
      IMPLICIT NONE
*     ..
*     .. Scalar Arguments ..
      INTEGER            N, NCOLS, LDA, LDAF
*     ..
*     .. Array Arguments ..
      COMPLEX            A( LDA, * ), AF( LDAF, * )
*     ..
*
*  Purpose
*  =======
*
*  CLA_RPVGRW computes the reciprocal pivot growth factor
*  norm(A)/norm(U). The "max absolute element" norm is used. If this is
*  much less than 1, the stability of the LU factorization of the
*  (equilibrated) matrix A could be poor. This also means that the
*  solution X, estimated condition numbers, and error bounds could be
*  unreliable.
*
*  Arguments
*  =========
*
*     N       (input) INTEGER
*     The number of linear equations, i.e., the order of the
*     matrix A.  N >= 0.
*
*     NCOLS   (input) INTEGER
*     The number of columns of the matrix A. NCOLS >= 0.
*
*     A       (input) COMPLEX array, dimension (LDA,N)
*     On entry, the N-by-N matrix A.
*
*     LDA     (input) INTEGER
*     The leading dimension of the array A.  LDA >= max(1,N).
*
*     AF      (input) COMPLEX array, dimension (LDAF,N)
*     The factors L and U from the factorization
*     A = P*L*U as computed by CGETRF.
*
*     LDAF    (input) INTEGER
*     The leading dimension of the array AF.  LDAF >= max(1,N).
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, J
      REAL               AMAX, UMAX, RPVGRW
      COMPLEX            ZDUM
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, ABS, REAL, AIMAG
*     ..
*     .. Statement Functions ..
      REAL               CABS1
*     ..
*     .. Statement Function Definitions ..
      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
*     ..
*     .. Executable Statements ..
*
      RPVGRW = 1.0

      DO J = 1, NCOLS
         AMAX = 0.0
         UMAX = 0.0
         DO I = 1, N
            AMAX = MAX( CABS1( A( I, J ) ), AMAX )
         END DO
         DO I = 1, J
            UMAX = MAX( CABS1( AF( I, J ) ), UMAX )
         END DO
         IF ( UMAX /= 0.0 ) THEN
            RPVGRW = MIN( AMAX / UMAX, RPVGRW )
         END IF
      END DO
      CLA_RPVGRW = RPVGRW
      END


** Copyright (c) 1989, NVIDIA CORPORATION.  All rights reserved.
**
** Licensed under the Apache License, Version 2.0 (the "License");
** you may not use this file except in compliance with the License.
** You may obtain a copy of the License at
**
**     http://www.apache.org/licenses/LICENSE-2.0
**
** Unless required by applicable law or agreed to in writing, software
** distributed under the License is distributed on an "AS IS" BASIS,
** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
** See the License for the specific language governing permissions and
** limitations under the License.

*   Intrinsics and generics - AINT, DINT, ..., CABS.

	parameter(n = 23)
	integer rslts(n), expect(n)
	real  rrslts(n), rexpect(n)
	equivalence (rslts, rrslts), (expect, rexpect)

	double precision d3, d349, d36
	complex c43

	data i234 / 234 /
	data x349, xn39 / 3.49, -3.9 /
	data d3, d349, d36 / 3d0, 3.49d0, 3.6d0 /
	data c43  / (4.0, 3.0) /

c ---- tests 1 - 5:  AINT, DINT:

	data (rexpect(i), i = 1, 5) /2.0, -3.0, -2.0, 3.0, 2.0 /
	rrslts(1) = aint(2.1)
	rrslts(2) = aint(xn39)
	rrslts(3) = sngl( aint(-2.9D0) )
	rrslts(4) = aint(d36)
	rrslts(5) = sngl( dint(2.0d0) )

c ---- tests 6 - 13: ANINT, DNINT, NINT, IDNINT:

	data (rexpect(i), i = 6, 9) / 3.0, -4.0, 249653.0, 3.0 /
	rrslts(6) = anint( 2.5 )
	rrslts(7) = anint( xn39 )
	rrslts(8) = sngl( anint(249653.1d0) )
	rrslts(9) = sngl( dnint(d349) )

	data (expect(i), i = 10, 13) / 23, -4, 4, 4 /
	rslts(10) = nint(22.5)
	rslts(11) = nint(xn39)
	rslts(12) = nint(d36 + .41)
	rslts(13) = idnint(.39 + d36)

c ---- tests 14 - 23: IABS, ABS, DABS, CABS:

	data (expect(i), i = 14, 16) / 5, 234, 234 /
	rslts(14) = iabs(-5)
	rslts(15) = iabs(i234)
	rslts(16) = abs( - i234 )

	data (rexpect(i), i = 17, 21) /
     +        23.47, 3.49, 2.341d-3, 2.0, +2.3d0 /
	rrslts(17) = abs(-23.47)
	rrslts(18) = abs(x349)
	rrslts(19) = sngl( abs(2.341d-3) )
	rrslts(20) = sngl( abs(1.0 - d3) )
	rrslts(21) = dabs(-2.3d0)

	data expect(22), expect(23) / 130, 50 /
	rslts(22) = nint(10 * cabs((-12.0, 5.0)))
	rslts(23) = nint(10 * abs( c43 ))

c ---- check results:

	call check(rslts, expect, n)

	end


module m_tick
private
public tick
contains
      subroutine tick (nymd,nhms,ndt)
!***********************************************************************
!  Purpose
!     Tick the Date (nymd) and Time (nhms) by NDT (seconds)
!
!***********************************************************************
!*                  GODDARD LABORATORY FOR ATMOSPHERES                 *
!***********************************************************************

      IF(NDT.NE.0) THEN
      NSEC = NSECF(NHMS) + NDT

      IF (NSEC.GT.86400)  THEN
      DO WHILE (NSEC.GT.86400)
      NSEC = NSEC - 86400
      NYMD = INCYMD (NYMD,1)
      ENDDO
      ENDIF

      IF (NSEC.EQ.86400)  THEN
      NSEC = 0
      NYMD = INCYMD (NYMD,1)
      ENDIF

      IF (NSEC.LT.00000)  THEN
      DO WHILE (NSEC.LT.0)
      NSEC = 86400 + NSEC
      NYMD = INCYMD (NYMD,-1)
      ENDDO
      ENDIF

      NHMS = NHMSF (NSEC)
      ENDIF

      RETURN
      END

      FUNCTION INCYMD (NYMD,M)
!***********************************************************************
!  PURPOSE
!     INCYMD:  NYMD CHANGED BY ONE DAY
!     MODYMD:  NYMD CONVERTED TO JULIAN DATE
!  DESCRIPTION OF PARAMETERS
!     NYMD     CURRENT DATE IN YYMMDD FORMAT
!     M        +/- 1 (DAY ADJUSTMENT)
!
!***********************************************************************
!*                  GODDARD LABORATORY FOR ATMOSPHERES                 *
!***********************************************************************

      INTEGER NDPM(12)
      DATA    NDPM /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/
      LOGICAL LEAP
      DATA    NY00     / 1900 /
      LEAP(NY) = MOD(NY,4).EQ.0 .AND. (NY.NE.0 .OR. MOD(NY00,400).EQ.0)

!***********************************************************************
!
      NY = NYMD / 10000
      NM = MOD(NYMD,10000) / 100
      ND = MOD(NYMD,100) + M

      IF (ND.EQ.0) THEN
      NM = NM - 1
      IF (NM.EQ.0) THEN
          NM = 12
          NY = NY - 1
      ENDIF
      ND = NDPM(NM)
      IF (NM.EQ.2 .AND. LEAP(NY))  ND = 29
      ENDIF

      IF (ND.EQ.29 .AND. NM.EQ.2 .AND. LEAP(NY))  GO TO 20

      IF (ND.GT.NDPM(NM)) THEN
      ND = 1
      NM = NM + 1
      IF (NM.GT.12) THEN
          NM = 1
          NY = NY + 1
      ENDIF
      ENDIF

   20 CONTINUE
      INCYMD = NY*10000 + NM*100 + ND
      RETURN

!***********************************************************************
!                      E N T R Y    M O D Y M D
!***********************************************************************

      ENTRY MODYMD (NYMD)
      NY = NYMD / 10000
      NM = MOD(NYMD,10000) / 100
      ND = MOD(NYMD,100)

   40 CONTINUE
      IF (NM.LE.1)  GO TO 60
      NM = NM - 1
      ND = ND + NDPM(NM)
      IF (NM.EQ.2 .AND. LEAP(NY))  ND = ND + 1
      GO TO 40

   60 CONTINUE
      MODYMD = ND
      RETURN
      END

      function nhmsf (nsec)
!***********************************************************************
!  Purpose
!     Converts Total Seconds to NHMS format
!
!***********************************************************************
!*                  GODDARD LABORATORY FOR ATMOSPHERES                 *
!***********************************************************************
      implicit none
      integer  nhmsf, nsec
      nhmsf =  nsec/3600*10000 + mod(nsec,3600)/60*100 + mod(nsec,60)
      return
      end

      function nsecf (nhms)
!***********************************************************************
!  Purpose
!     Converts NHMS format to Total Seconds
!
!***********************************************************************
!*                  GODDARD LABORATORY FOR ATMOSPHERES                 *
!***********************************************************************
      implicit none
      integer  nhms, nsecf
      nsecf =  nhms/10000*3600 + mod(nhms,10000)/100*60 + mod(nhms,100)
      return
      end
end module m_tick


module datastruct
  !====================================================================
  !
  ! Data structures for a geodesic grid with primal
  !  (Delaney triangular) and dual (Voronoi) grids
  !
  ! Commnets:
  !   - To obtain better memory alignement, the data is ordered
  !    in each type by size, from large numeric arrays to smaller
  !    and then strings. Source:
  !   software.intel.com/sites/products/documentation/hpc/compilerpro/
  !     en-us/fortran/lin/compiler_f/optaps/fortran/optaps_prg_algn_f.htm
  !
  ! P. Peixoto - 10-03-2011
  !=====================================================================

  !Use global constants and kinds
  use constants, only: i4, r8

  !-------------------------------------------------
  ! Simple 3d cartesian vector
  !------------------------------------------------
  type vector
     real (r8), dimension(1:3) :: v
  end type vector

  !-------------------------------------------------
  ! Simple string of 8 chars, to be used when creating array of strings
  !------------------------------------------------
  type string8
     character (len=8) :: s
  end type string8

  !-------------------------------------------------
  ! Coeficients of a 2nd order polinomial
  ! c(1:5) refers to a x^2, xy, y^2, x, y
  ! Also has the rotation parameters
  !------------------------------------------------
  type polcoef
     !Polinomial coeficients
     real (r8), allocatable :: c(:)

     ! Rotation parameters
     real(r8):: cx, sx, cy, sy

     !Kind of coeficients stored
     ! "spol2" = 2nd order scalar polinomial
     ! "vpol1" = 1st order vector polonomial
     character (len=8) :: polkind

  end type polcoef

  !-------------------------------------------------
  !General sphere point structure
  ! This point is not necessarily a grid point
  !-------------------------------------------------
  type point_structure

     !Vector form of cartesian coordinates
     real (r8), dimension(1:3) :: p

     !Spherical/geographic coordinates of node in radians
     !  lat in [-pi/2, pi/2] , lon in [-pi, pi[
     real (r8) :: lat, lon

     !Barycentric coordinates relative to a triangle kct
     !  Could be used for other purposes
     real (r8), allocatable :: b(:)

     !Barycentric coordinates relative to a triangle kt
     !  Could be used for other purposes
     integer(i4) :: kt

  end type point_structure

  !----------------------------------------------------------------
  !Triangle vertice/node structure
  ! This has a bit more information then regular sphere point structure
  !------------------------------------------------------------------
  type vertice_structure

     !List of distances to neighbour nodes.
     ! The distances are actually the -cos(angle), where angle is the angle between
     ! the 2 nodes, that is, -dot_product(node, neighbour)
     ! this distance is a increasing function of the real distance, belongs to [-1,1].
     ! It is used in interpolation procedures. Size: 1:nnb
     real (r8), allocatable :: nbd(:)

     !List of geodesical distances to neighbour nodes (in radians).
     !  Size: 1:nnb
     real (r8), allocatable :: nbdg(:)

     !List of neighbour nodes/vertices (list of indexes). Size: 1:nnb
     ! counterclockwise-ordered sequences of neighboring nodes
     integer (i4), allocatable :: nb(:)

     !List of edges that has this point as vertice.
     !Size: 1:nnb
     integer (i4), allocatable :: ed(:)

     !List of triangle that has this point as vertice.
     !Size: 1:nnb
     integer (i4), allocatable :: tr(:)

     !Vector form of cartesian coordinates
     real (r8), dimension(1:3) :: p

     !Spherical/geographic coordinates of node in radians
     !  lat in [-pi/2, pi/2] , lon in [-pi, pi[
     real (r8) :: lon, lat

     !Number of neighbour nodes (conected through edges)
     integer (i4):: nnb

  end type vertice_structure

  !--------------------------------------------------------
  !Structure for edges
  !--------------------------------------------------------
  type edge_structure

     !Midpoint of the edge / intersecting point
     !  between triangle and hexagonal edges
     type(point_structure) :: c

     !Tangent unit vector to edge placed at the midpoint,
     ! it must be tangent to the sphere, and is
     ! defined in the deriction from v(1) to v(2)
     real (r8), dimension(1:3) :: tg

     !Normal unit vector to edge, placed at the midpoint
     ! it must be tangent to the sphere, and
     ! it is defined so that  tg x nr = c,
     ! that is, given the tangent vector, the normal vector is the one
     ! obtained rotation the tangent vector counter-clockwise 90 degrees
     real (r8), dimension(1:3) :: nr

     !End point vertices (in case of triangle edges),
     !  or tringle circumcenters (in case of voronoi cell
     !Only the index of vertice/triangle is used
     integer (i4), dimension(1:2) :: v

     !Triangles/hexagons sharing this edge
     ! In the case of triangles, only their index is stored
     ! In the case of hexagons, vertice indexes are stored
     integer (i4), dimension(1:2) :: sh

     !Projected length- Euclidian distance in R3
     ! considers the unit sphere
     real (r8) :: lenp

     !Geodesical length considering the unit sphere
     real (r8) :: leng

     !Area of edge volume by tiles -- not automatic loaded!!
     ! d_e - geodesic length of voronoi edge e
     ! l_e - geodesic length of triangle edge e
     ! A_t= d_e*l_e
     ! NOT saved with mesh
     real (r8) :: areat

  end type edge_structure

  !--------------------------------------------------------
  !Structure for triangles
  !--------------------------------------------------------
  type triangle_structure
     !Internal angles
     real (r8), dimension(1:3) :: angles

     !Circumcenter point
     type(point_structure) :: c

     !Barycenter Point
     type(point_structure) :: b

     !Circumradius of planar triangle of unit sphere
     real (r8) :: radp

     !Circumradius of geodesical triangle
     real (r8) :: radg

     !Area of planar triangle of unit sphere
     real (r8) :: areap

     !Area of geodesical triangle of unit sphere
     real (r8) :: areag

     !Area by tiles
     ! d_e - geodesic distance from circuncenter to tr edge midpoint
     ! l_e - geodesic length of edge e
     ! A_t= sum_edges d_e*l_e/2
     ! NOT saved with mesh
     real (r8) :: areat

     !Generating vertices (index only)
     !  Counter clockwise ordering
     integer (i4), dimension(1:3) :: v

     !Edges generating triangle (index only)
     !  The ith edge is conecting v(i) and v(i+1)
     integer (i4), dimension(1:3) :: ed

     !Neighbour triangles (index only)
     integer (i4), dimension(1:3) :: nb

     ! Vector correction sign for tangent vectors:
     !   For each edge, set 1 if the direction of the tangent
     !   vector, set counterclockwisely with respect to the triangle,
     !   is the same as the edge tangent vector, or else
     !   store -1
     integer (i4), dimension(1:3) :: tg

     !Vector correction sign for normal vectors
     ! For each edge, set 1 if the direction of the outer normal
     !  vector is the same as the edge normal vector, or else,
     !  store -1. (Obs: nr(1:3)=-tg(1:3)
     integer (i4), dimension(1:3) :: nr

     ! Voronoi normal vector correction relative to
     ! triangle CCw direction
     ! For each edge of the triangle,
     ! set 1 if the direction of the normal vector of Hx edge
     ! is given counter clockwiselly with respect to the triangle,
     ! or else store -1
     !  =dsign(1., dot_product(mesh%edhx()%nr,mesh%ed()%tg))*mesh%tr()%tg()
     !integer(i4), dimension(1:3) :: hxnrccw

     !Dual-primal cell intersection area
     ! Area of triangle intersection with Voronoi/hexagonal cell
     ! Areas relative to cells given in %v(1:n)
     ! NOT saved with mesh
     real (r8), dimension(1:3) :: trhx_area

  end type triangle_structure

  !--------------------------------------------------------
  !Structure for voronoi cells (pentagons/hexagons)
  !  Each cell is centered at on grid vertice/node
  !  so that the vertice structure is shared with this one
  !--------------------------------------------------------
  type hexagon_structure

     ! Tangent conterclockwise vector correction
     ! For each hx edge, set 1 if the direction of the tangent
     !  vector is given counter clockwiselly with respect to the polygon,
     ! or else store -1
     integer(i4), allocatable :: tg(:)

     ! Normal outputing vector correction
     ! For each hx edge, set 1 if the direction of the outer normal
     !  vector is the same as the edge normal vector, or else,
     !  store -1
     integer(i4), allocatable :: nr(:)

     ! Tringle edge tangent vector correction relative to Voronoi cells
     ! For each edge (triangle edge with respect to the voronoi cell),
     ! set 1 if the direction of the tangent points outward, or else,
     !  store -1 (tirangle tangent outwards
     !  =dot_product(mesh%edhx()%nr,mesh%ed()%tg)*mesh%hx()%nr
     integer(i4), allocatable :: ttgout(:)

     ! Tringle edge normal vector correction relative to Voronoi cells
     ! For each edge (triangle edge with respect to the voronoi cell),
     ! set 1 if the direction of the normal vector of tr edge
     ! is given counter clockwiselly with respect to the polygon,
     ! or else store -1
     !  =dot_product(mesh%edhx()%tg,mesh%ed()%nr)*mesh%hx()%tg
     integer(i4), allocatable :: tnrccw(:)

     !Barycenter Point
     type(point_structure) :: b

     !Area of planar polygon
     real (r8) :: areap

     !Area of geodesical polygon
     real (r8) :: areag

     !Area by tiles
     ! d_e - geodesic length of voronoi edge e
     ! l_e - geodesic length of triangle edge e
     ! A_t= sum_edges d_e*l_e/4
     ! NOT saved with mesh
     real (r8) :: areat

     !Alignment index
     real (r8) :: align

     !Weights of ith edge of hexagon relative to jth
     !TRISK - (see Thuburn et all 2009)
     ! NOT saved with mesh
     real (r8), allocatable :: trskw(:, :)

     !Dual-primal cell intersection area
     ! Area of triangle intersection with Voronoi/hexagonal cell
     ! Areas relative to cells given in %v(1:n)
     ! Divided by cell areas (normalized)!!!
     ! NOT saved with mesh
     real (r8), allocatable :: hxtr_area(:)

      !Weights for each vertex of the cell such
      ! that div remap is consistent
      ! and they sum 1 in triangular cell
      ! NOT saved with mesh
     real (r8), allocatable :: hxtr_remapw(:)

     !Sum of weights for each vertex of the cell such
     ! that div remap is consistent
     ! and they sum 1 in triangular cell
     ! NOT saved with mesh
     real (r8) :: hxtr_remapwsum

  end type hexagon_structure

  !--------------------------------------------------------
  !Structure for regular grid rectangles/quadrilaterals
  !--------------------------------------------------------
  type quadrilateral_structure

     !List of triangles intersecting this rectangle
     ! Size: 1:ntr
     integer (i4), allocatable :: tr(:)

     !Regular grid longitude in radians
     ! lon in [-pi, pi[
     real (r8) :: lon

     !Number of intersecting triangles
     integer (i4) :: ntr

  end type quadrilateral_structure

  !--------------------------------------------------------
  !List of by quads for fixed latitudes (varying longitudes)
  !--------------------------------------------------------
  type quad_lon_structure

     !List of quadrilaterals
     type(quadrilateral_structure), allocatable :: qd_lon(:)

     !Regular grid latitude in radians
     !  lat in [-pi/2, pi/2]
     real (r8) :: lat

     !Number of longitudes
     integer (i4) :: nlon

     !Regular grid spacing between points in radians
     ! This is obtained as: dlon=2pi/nlon
     real (r8) :: dlon

  end type quad_lon_structure

  !---------------------------------
  ! Global grid structure
  !---------------------------------
  type grid_structure

     !List of vertices. Size: 1:nv
     type(vertice_structure), allocatable :: v(:)

     !List of triangle edges. Size: 1:ne
     type(edge_structure), allocatable :: ed(:)

     !List of triangles. Size: 1:nt
     type(triangle_structure), allocatable :: tr(:)

     !List of voronoi cell edges, they have the same index of the
     !  triangle edges intersecting it (1 to 1 relation)
     ! Size: 1:ne
     type(edge_structure), allocatable :: edhx(:)

     !List of pentagonal/hexagonal voronoi polygons. Size: 1:nv
     !  This list should be used toghether with vertices list.
     type(hexagon_structure), allocatable :: hx(:)

     !List of quadrilaterals. Size: (1:nlon, 1:nlat)
     !type(quadrilateral_structure), allocatable :: qd(:,:)
     type(quad_lon_structure), allocatable :: qd_lat(:)

     !Regular grid spacing between points in radians
     ! This is obtained as: dlat=pi/nlat ; dlon=2pi/nlon
     real (r8) :: dlat !dlon,

     !Number latitudes and longitudes in regular grid
     !  these variables are used for tabular searching scheme
     integer(i4):: nlat !, nlon

     !Minimum/Maximum angular distance between vertice points in radians
     real(r8):: minvdist, maxvdist, meanvdist

     !Minimum/Maximum angular distance between circumcenters in radians
     real(r8):: mincdist, maxcdist, meancdist

     !Minimum/Maximum triangle geodesical areas
     real(r8):: mintrarea, maxtrarea, meantrarea

     !Minimum/Maximum triangle geodesical internal angles
     real(r8) :: mintrangle, maxtrangle, meantrangle

     !Minimum/Maximum voronoi cell geodesical areas
     real(r8) :: minhxarea, maxhxarea, meanhxarea

     !Optimization parameter (dependes on the method)
     real(r8) :: optpar

     !Maximum number of neighbours for all nodes (triangle vertices)
     integer(i4):: maxvnb

     !Maximum number of triangles intersecting a regular qrid rectangle
     integer(i4):: maxtrsqint

     !Number of bisection (g-level)
     integer (i4) :: glevel

     !Flag for loadable grid (1- yes, 0- no)
     integer (i4) :: loadable

     !Number of triangle vertices, that is,
     ! number of nodes on generated grid
     integer(i4)::nv

     !Number of triangles
     integer (i4)::nt

     !Number of triangle edges
     integer (i4):: ne

     !Mesh kind
     !icos (icosahedral)
     !octg (octahedral)
     !read (read from file)
     !rand (random points - be careful...)
     character(len=16) :: kind

     !Mesh Positions:
     !  eqs (equator symmetric)
     !  pol (north pole point)
     !  ran (all random points)
     !  ref (random with local mesh refinement - needs scvt optimization)
     character(len=16) :: pos

     ! 'nopt'  -> No optimization
     ! 'scvt'   -> Spherical centroidal voronoi
     !            Nodes are the mass centers of the voronoi cells
     ! 'sprg'  -> Spring dynamics optimization
     character(len=16) :: optm

     !Hierarchical construction/optimization flag
     !  0-No;
     !  1-Yes;
     !  2 - Optimizes only the new points in hierarchy;
     !  3 - Do not optimize nodes that belong to primary icosahedral edges
     integer (i4) :: hrchy

     !Triangulation read from file
     !  0-No;
     !  1-Yes;
     ! mesh%kind must be 'read'
     ! and file to be read must have the same name as
     ! the files with nodes but extention .nbd (neighbours)
     !  If =1, it is not necessary to do the delaunay triangulation
     integer (i4) :: deltriread

     !Grid name, used for file names as outputs
     ! name=kind//pos//optm//hrchy//n
     ! or file name if nodes are read from file
     character (len=128) :: name
     character (len=256) :: filename

     real (r8), allocatable  :: densf_table(:,:)

  end type grid_structure

  !---------------------------------------------------------
  ! Variable for scalar values on geodesic grid
  !---------------------------------------------------------
  type scalar_field

     ! Values array, ordered in the same sequence as the
     !   original nodes/circumcenter/edges mid points
     !   indexation
     real (r8), allocatable  :: f(:)

     ! Gradient vectors on the respective nodes
     ! The gradient calculation routines are only done for
     !  position = 0
     type(vector), allocatable  :: g(:)

     ! 2nd Order polinomial least saure fit on node
     ! or 1st order vector field recosntruction least square fit
     type(polcoef), allocatable :: pol(:)

     !Number of values on the mesh
     integer (i4) :: n

     ! Position of the values relative to a mesh
     !   0 - Nodes - Triangle vertices (voronoi centers)
     !   1 - Triangle circumcenter (voronoi vertices)
     !   2 - Triangle's edge midpoint
     !   3 - Hexagon's edges midpoint
     !   4 - Voronoi cell barycenter
     !   5 - Triangle barycenter
     !   6 - Edges - Intersection point of tr x hx, reference hx
     ! Obs: 6 is essencially the same as 2, but when
     !   vector components are put at 6 the refence are the hx
     !   whereas in 2, the reference are the triangles
     integer (i4) :: pos

     !Variable name - long name - detailed name
     ! This is used to for filenames of this variable
     character (len=256) :: name

  end type scalar_field

  !---------------------------------------------------------
  ! Variables for mesh vector values
  !---------------------------------------------------------

  type vector_field_cart
     !Cartesian vector variable

     ! Vector in cartesian coord on 'pos'
     type(vector), allocatable  :: p(:)

     ! Position of the values relative to a mesh
     !   0 - Nodes - Triangle's vertices (voronoi centers)
     !   1 - Triangle's circumcenters (voronoi vertices)
     !   2 - Triangle's edge mid points
     !   3 - Hexagonal's edge mid points
     !   4 - Voronoi cell barycenter
     !   5 - Triangle barycenter
     !   6 - Edges - Intersection point of tr x hx
     integer (i4) :: pos

     !Number of values on the mesh
     integer (i4) :: n

     !Variable name - long name - detailed name
     ! This is used to for filenames of this variable
     character (len=256) :: name

  end type vector_field_cart

  type vector_variable_edge
     ! Vector defined on edges

     ! Normal vector component value
     ! Ordered in the same sequence as the
     !   original edges indexation
     real (r8), allocatable  :: nr(:)

     ! Tangent vector component value
     ! Ordered in the same sequence as the
     !   original edges indexation
     real (r8), allocatable  :: tg(:)

     ! Position of the values relative to a mesh
     !   0 - Triangle's edge mid points
     !   1 - Voronoi cell edge mid point
     integer (i4) :: pos

     !Number of edges on the mesh
     integer (i4) :: n

     !Variable name - long name - detailed name
     ! This is used to for filenames of this variable
     character (len=256) :: name

  end type vector_variable_edge

  type vector_variable_uv
     ! West-East vector value
     ! Ordered in the same sequence as the
     !   original nodes/circumcenter/edges mid points
     !   indexation
     real (r8), allocatable  :: u(:)

     ! South-North vector value
     ! Ordered in the same sequence as the
     !   original nodes/circumcenter/edges mid points
     !   indexation
     real (r8), allocatable  :: v(:)

     ! Position of the values relative to a mesh
     !   0 - Nodes - Triangle vertices (voronoi centers)
     !   1 - Triangle circumcenter (voronoi vertices)
     !   2 - Triangle's edge mid points
     integer (i4) :: pos

     !Number of values on the mesh
     integer (i4) :: n

     !Variable name - long name - detailed name
     ! This is used to for filenames of this variable
     character (len=256) :: name

  end type vector_variable_uv

  !---------------------------------------------------------
  ! Structures for RBF matrices
  !---------------------------------------------------------

  type rbf_matrix_structure
     !Radial Basis Function matrix for a given point

     !Cholesky decomposition (LDL') of rbf matrix
     !It has a lower triangular matrix L and
     !  a diagonal D stored in the diagonal of L
     real(r8), allocatable :: L(:,:)

     !Right hand side of RBF system
     real(r8), allocatable :: b(:)

     ! RBF weights for interpolation
     real(r8), allocatable :: w(:)

     ! Polinomial to be added
     ! For scalar rbf, dim(pol)=1
     ! For vec recon, dim(pol)=3
     real(r8), allocatable :: pol(:)

     ! Estimative of the condition number
     real(r8) :: condnum, dmin, dmax

     !Nodes/triangles indexes involved in the rbf matrix
     integer (i4) , allocatable :: pts(:)

     !RBF width (shape parameter)
     real (r8) :: h

     !Number of points involved in the rbf matrix
     integer (i4) :: n

  end type rbf_matrix_structure

  !---------------------------------------------------------
  ! Structures for Natural Neighbour Coordinates
  !---------------------------------------------------------

  type general_coords
     !Natural coordinate vectors

     !Number of natural neighbours or near neighbours
     integer (i4) :: n

     ! Position of the values relative to a mesh
     !   0 - Nodes - Triangle's vertices (voronoi centers)
     !   1 - Triangle's circumcenters (voronoi vertices)
     !   2 - Triangle's edge mid points
     !   3 - Hexagonal's edge mid points
     !   4 - Voronoi cell barycenter
     !   5 - Triangle barycenter
     !   6 - Edges - Intersection point of tr x hx
     integer (i4) :: pos

     !Neighbour indexes (vertice index, or edge index)
     integer (i4), allocatable :: v(:)

     !Coordinate value, or weight relative to each vertice
     real (r8), allocatable :: w(:)

  end type general_coords

  !----------------------------------------------------------
  ! Structure for multi method vector reconstruction
  !----------------------------------------------------------
  type vectorinterpol_methods
     !Methods involved in vector reconstruction

     !Basic reconstruction method
     character (len=16):: recon

     !Vector interpolation method
     character (len=16):: interp

     !Higher order reconstruction
     character (len=16):: horecon

     !Full name
     character (len=24):: name

     !Alignment index cut off value
     real (r8) :: alignlimit

     !Percentage of aligned cells
     real (r8) :: alignpercent

     !Logic for hybrid method (horeconq/=0)
     logical :: hyb

     !Logic for reconstruction for barycenters
     logical :: massc

     !Logical variable to reconstruc only on ill aligned cells
     ! Do nothing on aligned cells
     logical :: nonalignedonly

     !Radial basis function parameter
     real (r8) :: rbf_par

  end type vectorinterpol_methods

end module datastruct


!---------------------------------------------------!
! Copyright (c) 2016 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine Imaginary_time
  use global_variables
  implicit none
  integer :: Niter_im = 20000,iter
  real(dp) :: dt_im = 0.005
  real(dp) :: Etot,esp_e,esp_n, res_e,res_n
  real(dp) :: ss
  integer :: ix

  open(30,file="GS_data.out")
  do iter = 0,Niter_im
    twfn_e = wfn_e !; twfn_n = wfn_n
    call hpsi
    esp_e = sum(wfn_e*hwfn_e)*dx !; esp_n = sum(wfn_n*hwfn_n)*dr
    res_e = sum( (hwfn_e - esp_e*wfn_e)**2)*dx
!    res_n = sum( (hwfn_n - esp_n*wfn_n)**2)*dr
    Etot = esp_e !+ esp_n - 1.0d0*sum(rho*v_e)*dx
    write(30,"(I7,2x,999e16.6e3)")iter,Etot,esp_e,res_e
    write(*,"(I7,2x,999e16.6e3)")iter,Etot,esp_e,res_e

    wfn_e = wfn_e - dt_im * hwfn_e
!    wfn_n = wfn_n - 10d0*dt_im * hwfn_n
    ss = sum(wfn_e**2)*dx; wfn_e = wfn_e/sqrt(ss)
!    ss = sum(wfn_n**2)*dr; wfn_n = wfn_n/sqrt(ss)

    call wfn_rho
!    call mean_field_pot

  end do
  close(30)

  open(90,file = 'GS_wfn_e.out')
  write(90,'(A)')'# x,  rho(x)'
  do ix =0,Nx
     write(90,'(100e26.16e3)')xn(ix),wfn_e(ix),rho(ix),v_e(ix)
  end do
  close(90)
  write(*,*)'rho',sum(rho(:))*dx

end subroutine Imaginary_time


      subroutine clawpack46_qinit(maxmx,maxmy,meqn,mbc,mx,my,
     &      xlower,ylower,dx,dy,q,maux,aux)
       implicit double precision (a-h,o-z)
       dimension q(1-mbc:maxmx+mbc, 1-mbc:maxmy+mbc, meqn)
c
       do 20 i=1-mbc,mx+mbc
          xi = xlower + (i-0.5d0)*dx
          do 20 j=1-mbc,my+mbc
             yj = ylower + (j-0.5d0)*dy
             r = dsqrt((xi-0.25d0)**2 + (yj-0.4d0)**2)
             q(i,j,1) = p0(r)
             q(i,j,2) = 0.d0
             q(i,j,3) = 0.d0
  20         continue
       return
       end


Module ModLine
  !
  ! robust fit of the line
  !
  use mo_kind, only: dp
  use mo_ansi_colors, only: color, c_red, c_green

  implicit none

  ! debug mode
  logical, parameter, private :: debug = .false.

  integer, private :: n
  real(dp), private, pointer :: x(:), y(:)
  real(dp), private, allocatable, dimension(:,:) :: jacmin

contains

  subroutine line(ndata,xdata,ydata,t,dt,s0)

    use mo_minpack, only: hybrj, qrfac, covar, qrfac, qform !, qrinv

    implicit none

    integer, parameter :: npar = 2
    integer, parameter :: lr = (npar*(npar+1))/2

    integer :: ndata
    real(dp), target :: xdata(:),ydata(:)
    real(dp) :: t(2),dt(2),s0

    integer :: i, j, info, ipvt(2), iflag, nfev, njev
    real(dp) :: tol, fvec(2), fjac(2,2),h(2,2),cov(2,2)
    real(dp) :: fjacdiag(2),acnorm(2),sum1,sum2,temp,temp2
    real(dp) :: v(2,2),w(2)
    real(dp), dimension(npar) :: diag,wa1,wa2,wa3,wa4,qtf
    real(dp), dimension(lr) :: r

    LOGICAL :: isgood

! initialization
    n = ndata
    x => xdata
    y => ydata
    allocate(jacmin(2,2))

! 0th estimator, it get value of parameters by minimization of the absolute
! deviations, uses simplex method
    t = 0
    dt = 1.0
    t = (/29.223, -1.913 /)
    t = 0
    dt = 0

! iterate to get better solution
    tol = sqrt(epsilon(tol))
    info = 0
!    call hybrj1(minfun,2,t,fvec,fjac,2,tol,info,wa,(2*(2+13))/2)
!    write(*,*) 'hybrj1 finished with code',info
    diag = 1.0
    call hybrj(minfun,2,t,fvec,fjac,2,tol,200*(2+1),diag,2,100.0_dp,1, &
         info,nfev,njev,r,lr,qtf,wa1,wa2,wa3,wa4)
    if (debug) write(*,*) 'hybrj finished with code',info

! form inverse matrix
    if (debug) write(*,*) "hybr:"
    if (debug) write(*,'(2F15.5)') fjac

    fjac = jacmin
    call qrfac(2,2,fjac,2,.true.,ipvt,2,fjacdiag,acnorm,w)
    do i = 1,2
       fjac(i,i) = fjacdiag(i)
    end do

    call covar(2,fjac,2,ipvt,epsilon(fjac),w)

    if (debug) write(*,*) " covariance matrix = "
    if (debug) write(*,'(2f15.5)') fjac

!    call covar(2,fjac,2,ipvt,epsilon(fjac),w)

    iflag = 2
    call minfun(2,t,fvec,fjac,2,iflag)
    call qrfac(2,2,fjac,2,.false.,ipvt,2,fjacdiag,acnorm,w)
    if (debug) write(*,*) acnorm
    if (debug) write(*,'(2F15.5)') fjac
    call qform(2,2,fjac,2,w)
    v = fjac
    w = fjacdiag
    if (debug) write(*,*) ipvt
    if (debug) write(*,"(A,2(2F15.5/))") "eigean. vectors", v

    if (debug) write(*,*) "eigrn values"
    if (debug) write(*,'(2F15.5)') w

    ! MC: commented because w is dimension(2) but w is return value of qrinv with dimension(2,2)
    ! MC: fja is input into qrinv
    ! call qrinv(2,2,v,w,2,fjac)
    ! if (debug) write(*,*) "qrinv:"
    ! if (debug) write(*,'(2F15.5)') fjac

! inverse matrix
    iflag = 2
    call minfun(2,t,fvec,fjac,2,iflag)
    call qrfac(2,2,fjac,2,.true.,ipvt,2,fjacdiag,acnorm,w)
    do i = 1,2
      h(i,i) = 1.0/fjacdiag(i)
    enddo
    if (debug) write(*,*) h
    do j = 2,1,-1
       do i = j-1,1,-1
          h(i,j) = -sum(fjac(i,i+1:j)*h(i+1:j,j))/fjacdiag(i)
       enddo
    enddo
    if (debug) write(*,*) "inverse = "
    if (debug) write(*,'(2F15.5)') h

! compute inverse matrix
!    fjac(1,1:2) = (/ 1.0, -1.0/)
!    fjac(2,1:2) = (/ -1.0, 1.0 /)
    iflag = 2
    call minfun(2,t,fvec,fjac,2,iflag)
    if (debug) write(*,*) " input jacobian = "
    if (debug) write(*,'(2F15.5)') fjac
    call qrfac(2,2,fjac,2,.true.,ipvt,2,fjacdiag,acnorm,w)

    if (debug) write(*,*) fjacdiag
    if (debug) write(*,*) acnorm
    if (debug) write(*,*) ipvt
!    ipvt = (/ 1,2/)
    if (debug) write(*,'(a,2F15.5)') " inverse jacobian = ",fjac(1,1:2)
    if (debug) write(*,'(a,2F15.5)') "                    ",fjac(2,1:2)

    do i = 1,2
       fjac(i,i) = fjacdiag(i)
    end do

    call covar(2,fjac,2,ipvt,epsilon(fjac),w)

    if (debug) write(*,*) " covariance matrix = "
    if (debug) write(*,'(2f15.5)') fjac

    sum1 = 0.0
    sum2 = 0.0
    s0 = 0
    do i = 1, n
       temp = (y(i) - (t(1) + t(2)*x(i)))
       temp2 = temp**2
       sum1 = sum1 + temp2
       sum2 = sum2 + 1.0
       s0 = s0 + temp**2
       if (debug) write(*,'(5f15.5)') x(i), y(i),temp,sum1, s0
    enddo
    if (debug) write(*,*) sum1,sum2**2
!    s0 = sum1
    cov = s0*fjac/(n - 2)!*(sum2/n)**2
    write(*,*) "covariance:"
    write(*,'(2f15.5)') cov
    do i = 1,2
       dt(i) = sqrt(cov(i,i))
    enddo

    if( debug ) then
       write(*,*) "Exit for "
       if( info == 0 ) then
          write(*,*) " improper input parameters."
       elseif( info == 1 )then
          write(*,*) " algorithm estimates that the relative error between x and the solution is at most tol."
       elseif( info == 2 )then
          write(*,*) " number of calls to fcn with iflag = 1 has reached 100*(n+1)."
       elseif( info == 3 ) then
          write(*,*) " tol is too small. no further improvement in the approximate solution x is possible."
       elseif( info == 4 )then
          write(*,*) " iteration is not making good progress."
       endif

       write(*,*) "Solution"
       write(*,*) " info = ", info
       write(*,*) " solution = ",t," with dev = ",dt
       write(*,*) " residual sum s0 = ",s0
       write(*,*) " standard deviation = ",sqrt(s0/(n - 2))
       write(*,*) " No. of data = ",n

    else
       write(*,*) "Solution"
       write(*,*) t(1)," +- ",dt(1)
       write(*,*) t(2)," +- ",dt(2)
       write(*,*) " residual sum: ",s0
       write(*,*) " No. of data:  ",n
    endif
    isgood = .True.
    isgood = isgood .and. (nint(1000._dp*t(1)) == 29223)
    isgood = isgood .and. (nint(1000._dp*t(2)) == -1913)
    isgood = isgood .and. (nint(1000._dp*dt(1)) == 1278)
    isgood = isgood .and. (nint(1000._dp*dt(2)) == 122)

    s0 = 0.0
    do i = 1, n
       sum1 = y(i) - (t(1) + t(2)*x(i))
       s0 =  s0 + sum1**2
    enddo
    if (debug) write(*,*) s0

    if (isgood) then
       write(*,*) 'mo_minpack double precision ', color('o.k.', c_green)
    else
       write(*,*) 'mo_minpack double precision ', color('failed!', c_red)
    endif

  end subroutine line
!
!--------------------------------------------------------------------------
!
  subroutine minfun(nt,t,fvec,fjac,ldjac,iflag)

    implicit none

    ! integer, intent(in) :: nt, ldjac
    ! integer, intent(inout) :: iflag
    ! real(dp), intent(in) :: t(nt)
    ! real(dp), intent(inout) :: fvec(nt), fjac(ldjac,nt)
    integer :: nt, ldjac
    integer :: iflag
    real(dp) :: t(nt)
    real(dp) :: fvec(nt), fjac(ldjac,nt)

    integer :: i
    real(dp) :: r, sa,sb

    if( ldjac /= 2 .or. nt /= 2 ) stop

    if( iflag == 0 .and. debug )then
       write(*,'(a,2F15.5,a,2f15.5)') "minpack: par = ",t," sum = ", &
            sum(abs(y(1:n) - (t(1) + t(2)*x(1:n)))**2)
    endif

    if( iflag == 1 )then
!       fvec = 0.0_dp
       sa = 0.0; sb = 0.0;
       do i = 1, n
          r = y(i) - (t(1) + t(2)*x(i))
!          write(*,*) r,t(1) + t(2)*x(i),y(i),x(i),t
          sa = sa - r
          sb = sb - r*x(i)
!          rp = r
!          fvec(1) = fvec(1) - rp*1.0_dp
!          fvec(2) = fvec(2) - rp*x(i)
!          if(debug) write(*,'(5f15.5)') x(i),y(i),r,sa,sb
       enddo
!       fvec = fvec
       fvec = (/sa,sb/)
!       fvec = 0.0
       if( debug ) write(*,'(a,2f15.5)') " vector of residuals = ",fvec
    endif

    if( iflag == 2 )then
!       fjac = 0.0_dp
       sa = 0.0; sb = 0.0;
       do i = 1, n
!          r = y(i) - (t(1) + t(2)*x(i))
          sa = sa - x(i)
          sb = sb - x(i)**2
!          rp = 1.0_dp
!          fjac(1,1) = fjac(1,1) - rp*1.0_dp
!          fjac(1,2) = fjac(1,2) - rp*x(i)
!          fjac(2,2) = fjac(2,2) - rp*x(i)**2
       enddo
!       fjac(2,1) = fjac(1,2)
!       fjac = - fjac
       fjac(1,:) = (/real(n,kind=dp),-sa/)
       fjac(2,:) = (/-sa,-sb/)
       if( debug ) write(*,'(a,4f15.5)') " jacobian = ",fjac
       jacmin = fjac
    endif

  end subroutine minfun
!
!--------------------------------------------------------------------------
!
end Module ModLine


      SUBROUTINE EARTH(KFILDO,IPACK,ND5,IS3,NS3,L3264B,
     1                 LOCN,IPOS,IER)
C
C        MARCH    2000   LAWRENCE  GSC/TDL   ORIGINAL CODING
C        JANUARY  2001   GLAHN     COMMENTS; CHANGED IER = 24 TO 310
C        JANUARY  2001   GLAHN/LAWRENCE FILLED SOME ELEMENTS OF IS3( );
C                                  CORRECTED IS3(13).EQ.2 ERROR TO
C                                  IS3(15).EQ.2; CORRECTED IS2(23)
C                                  ERROR TO IS3(22) IN CALL TO PKBG
C        FEBRUARY 2001   GLAHN/LAWRENCE CHANGED IS3(16)=IRADIUS TO
C                                  IS3(17); AND IS3(22)=IMINAXIS TO
C                                  IS3(27); REMOVED RETURN 1
C
C        PURPOSE
C            PACKS SHAPE OF THE EARTH INFORMATION INTO SECTION 3
C            OF A GRIB2 MESSAGE.  THIS INFORMATION IS BASED
C            ON TABLE 3.2 OF THE WMO GRIB2 DOCUMENTATION AND IS
C            REQUIRED BY MANY OF THE MAP TEMPLATES IN SECTION 3.
C
C            THE USER HAS THE OPTION TO CHOOSE A SPHERICAL EARTH
C            OR AN OBLATE SPHEROID EARTH. FOR THE SPHERICAL EARTH
C            THE USER MAY EITHER USE THE EARTH'S RADIUS AS DEFINED
C            BY THE WMO OR SUPPLY HIS/HER OWN RADIUS VALUE. FOR THE
C            OBLATE SPHEROID EARTH, THE USER MAY EITHER USE THE
C            MAJOR AND MINOR AXES LENGTHS AS DEFINED BY THE WMO OR
C            SUPPLY HIS/HER OWN VALUES FOR THEM.
C
C        DATA SET USE
C           KFILDO - UNIT NUMBER FOR OUTPUT (PRINT) FILE. (OUTPUT)
C
C        VARIABLES
C              KFILDO = UNIT NUMBER FOR OUTPUT (PRINT) FILE. (INPUT)
C            IPACK(J) = THE ARRAY THAT HOLDS THE ACTUAL PACKED MESSAGE
C                       (J=1,ND5). (INPUT/OUTPUT)
C                 ND5 = THE SIZE OF THE ARRAY IPACK( ). (INPUT)
C              IS3(J) = CONTAINS THE EARTH-SHAPE INFORMATION
C                       (IN ELEMENTS 15 THROUGH 27) THAT WILL BE
C                       PACKED INTO IPACK( ) (J=1,NS3). (INPUT)
C                 NS3 = SIZE OF IS3( ). (INPUT/OUTPUT)
C              L3264B = THE INTEGER WORD LENGTH IN BITS OF THE MACHINE
C                       BEING USED. VALUES OF 32 AND 64 ARE
C                       ACCOMMODATED. (INPUT)
C                LOCN = THE WORD POSITION TO PLACE THE NEXT VALUE.
C                       (INPUT/OUTPUT)
C                IPOS = THE BIT POSITION IN LOCN TO START PLACING
C                       THE NEXT VALUE. (INPUT/OUTPUT)
C                 IER = RETURN STATUS CODE. (OUTPUT)
C                         0 = GOOD RETURN.
C                       1-4 = ERROR CODES GENERATED BY PKBG. SEE THE
C                             DOCUMENTATION IN THE PKBG ROUTINE.
C                       310 = UNSUPPORTED SHAPE OF EARTH CODE IN
C                             IS3(15).
C
C             LOCAL VARIABLES
C            EARTHRAD = THE EARTH'S RADIUS AS OUTLINED IN THE
C                       WMO GRIB2 DOCUMENTATION, CODE TABLE 3.2.
C                       THIS IS IN KM ANDAPPLIES TO A SPHERICAL EARTH.
C            EMAJAXIS = THE MAJOR AXIS OF AN OBLATE SPHEROID EARTH
C                       AS OUTLINED IN THE WMO GRIB2 DOCUMENTATION,
C                       CODE TABLE 3.2.  THE VALUE IS IN KM.
C            EMINAXIS = THE MINOR AXIS OF AN OBLATE SPHEROID EARTH
C                       AS OUTLINED IN THE WMO GRIB2 DOCUMENTATION,
C                       CODE TABLE 3.2.  THE VALUE IS IN KM.
C            IMAJAXIS = THE SCALED MAJOR AXIS OF AN OBLATE SPHEROID
C                       EARTH.
C            IMINAXIS = THE SCALED MINOR AXIS OF AN OBLATE SPHEROID
C                       EARTH.
C             IRADIUS = THE SCALED RADIUS OF A SPHERICAL EARTH
C            ISCALEMJ = THE DECIMAL SCALE FACTOR TO MULTIPLY THE
C                       MAJOR AXIS OF THE EARTH (EMAJAXIS) BY TO
C                       RETAIN ITS PRECISION WHEN THE VALUE IS PACKED.
C            ISCALEMN = THE DECIMAL SCALE FACTOR TO MULTIPLY THE
C                       MINOR AXIS OF THE EARTH (EMINAXIS) BY TO
C                       RETAIN ITS PRECISION WHEN THE VALUE IS PACKED.
C            ISCALERD = THE DECIMAL SCALE FACTOR TO MULTIPLY THE
C                       RADIUS OF THE EARTH (EARTHRAD) BY TO
C                       RETAIN ITS PRECISION WHEN THE VALUE IS PACKED.
C                   N = L3264B = THE INTEGER WORD LENGTH IN BITS OF
C                       THE MACHINE BEING USED. VALUES OF 32 AND
C                       64 ARE ACCOMMODATED.
C
C        NON SYSTEM SUBROUTINES CALLED
C           PKBG
C
      PARAMETER (EARTHRAD=6367.47,
     1           ISCALERD=2,
     2           EMAJAXIS=6378.160,
     3           ISCALEMJ=3,
     4           EMINAXIS=6356.775,
     5           ISCALEMN=3)
C
      DIMENSION IPACK(ND5),IS3(NS3)
C
      DATA IZERO/0/
C
      N=L3264B
      IER=0
C
C        PACK THE SHAPE OF THE EARTH.
      CALL PKBG(KFILDO,IPACK,ND5,LOCN,IPOS,IS3(15),8,N,IER,*900)
C
C        DEPENDING ON THE SHAPE OF THE EARTH THAT THE
C        USER HAS CHOSEN, PACK THE APPROPRIATE SCALE
C        FACTOR AND VALUE FOR THE RADIUS OF THE EARTH.
      IF((IS3(15).EQ.0).OR.(IS3(15).EQ.1))THEN
C
         IF(IS3(15).EQ.0)THEN
C              PACK THE SCALE FACTOR OF THE RADIUS OF THE
C              SPHERICAL EARTH AND THE SCALED RADIUS OF THE
C              SPHERICAL EARTH AS DEFINED IN THE WMO GRIB2
C              DOCUMENTATION, IN THIS CASE 2.
            IRADIUS=NINT((10**ISCALERD)*EARTHRAD)
            CALL PKBG(KFILDO,IPACK,ND5,LOCN,IPOS,ISCALERD,8,N,
     1                IER,*900)
            IS3(16)=ISCALERD
            CALL PKBG(KFILDO,IPACK,ND5,LOCN,IPOS,IRADIUS,
     1                32,N,IER,*900)
            IS3(17)=IRADIUS
         ELSE
C
C              PACK THE SCALE FACTOR OF THE RADIUS OF THE
C              SPHERICAL EARTH AND THE SCALED RADIUS OF THE
C              SPHERICAL EARTH AS DEFINED BY THE USER IN THE
C              IS3( ) ARRAY.
            CALL PKBG(KFILDO,IPACK,ND5,LOCN,IPOS,IS3(16),8,N,
     1                IER,*900)
            CALL PKBG(KFILDO,IPACK,ND5,LOCN,IPOS,IS3(17),32,N,
     1                IER,*900)
         ENDIF
C
C           ZERO OUT THE LOCATIONS PERTAINING TO AN OBLATE
C           SPHERIOD EARTH.
C
         CALL PKBG(KFILDO,IPACK,ND5,LOCN,IPOS,IZERO,32,N,IER,*900)
         CALL PKBG(KFILDO,IPACK,ND5,LOCN,IPOS,IZERO,32,N,IER,*900)
         CALL PKBG(KFILDO,IPACK,ND5,LOCN,IPOS,IZERO,16,N,IER,*900)
C
      ELSEIF((IS3(15).EQ.2).OR.(IS3(15).EQ.3))THEN
C
C           ZERO OUT THE LOCATIONS PERTAINING TO A SPHERICAL
C           EARTH.
C
         CALL PKBG(KFILDO,IPACK,ND5,LOCN,IPOS,IZERO,32,N,IER,*900)
         CALL PKBG(KFILDO,IPACK,ND5,LOCN,IPOS,IZERO,8,N,IER,*900)
C
         IF(IS3(15).EQ.2)THEN
C
C              PACK THE SCALE FACTOR OF THE MAJOR AND MINOR
C              AXES OF AN OBLATE SPHEROID EARTH ALONG WITH
C              WITH THEIR SCALED VALUES AS DEFINED BY THE
C              WMO GRIB2 DOCUMENTATION.
            IMAJAXIS=NINT((10**ISCALEMJ)*EMAJAXIS)
            CALL PKBG(KFILDO,IPACK,ND5,LOCN,IPOS,ISCALEMJ,8,N,
     1                IER,*900)
            IS3(21)=ISCALEMJ
            CALL PKBG(KFILDO,IPACK,ND5,LOCN,IPOS,IMAJAXIS,
     1                32,N,IER,*900)
            IS3(22)=IMAJAXIS
            IMINAXIS=NINT((10**ISCALEMN)*EMINAXIS)
            CALL PKBG(KFILDO,IPACK,ND5,LOCN,IPOS,ISCALEMN,8,N,
     1                IER,*900)
            IS3(26)=ISCALEMN
            CALL PKBG(KFILDO,IPACK,ND5,LOCN,IPOS,IMINAXIS,
     1                32,N,IER,*900)
            IS3(27)=IMINAXIS
         ELSE
C
C              PACK THE SCALE FACTOR OF THE MAJOR AND MINOR
C              AXES OF AN OBLATE SPHEROID EARTH ALONG WITH
C              WITH THEIR SCALED VALUES AS DEFINED BY THE
C              USER.
            CALL PKBG(KFILDO,IPACK,ND5,LOCN,IPOS,IS3(21),8,N,
     1                IER,*900)
            CALL PKBG(KFILDO,IPACK,ND5,LOCN,IPOS,IS3(22),
     1                32,N,IER,*900)
            CALL PKBG(KFILDO,IPACK,ND5,LOCN,IPOS,IS3(26),8,N,
     1                IER,*900)
            CALL PKBG(KFILDO,IPACK,ND5,LOCN,IPOS,IS3(27),
     1                32,N,IER,*900)
         ENDIF
C
      ELSE
C           AN INVALID OR UNSUPPORTED CODE FOR THE SHAPE OF THE
C           EARTH IS IN IS3(15).
         IER=310
      ENDIF
C
 900  RETURN
      END


subroutine MakeGrid2D(grid, cilm, lmax, interval, nlat, nlong, norm, csphase, &
                      f, a, north, south, east, west, dealloc, exitstatus)
!------------------------------------------------------------------------------
!
!   Given the Spherical Harmonic coefficients cilm, this subroutine
!   will compute a 2D grid with equal latitude and longitude spacings.
!   Note that since this is NOT done using FFTs, this routine is therefore
!   relatively SLOW! You might want to instead use MakeGridDH.
!
!   The value at grid(1,1) correspons to 90 degrees latitude
!   and 0 degrees longitude, and the longitude spacing goes from 0 to 360,
!   with both points being calculated. If the optional
!   parameters NORTH, SOUTH, EAST and WEST are specified, the upper-left and
!   lower right coordinates of the output grid are (NORTH, WEST) and
!   (SOUTH, EAST), respectively.
!
!   Calling Parameters
!
!       IN
!           cilm        Spherical harmonic coefficients.
!           lmax        Maximum degree of expansions to be performed.
!           interval    Spacing of output grid in DEGREES.
!
!       OUT
!           grid        Gridded expansion of spherical harmonic coefficients.
!           nlat        Number of latitude points for the grid.
!           nlong       Number of longitude points for the grid.
!
!       OPTIONAL (IN)
!           norm        Spherical harmonic normalization:
!                           (1) "geodesy" (default)
!                           (2) Schmidt
!                           (3) unnormalized
!                           (4) orthonormalized
!           csphase     1: Do not include the phase factor of (-1)^m (default).
!                       -1: Apply the phase factor of (-1)^m.
!           f           Flattening of the reference ellipsoid (a-c)/a. If
!                       included, this ellipsoid will be subtracted from
!                       the data.
!           a           Semimajor axis of the reference ellipsoid. If included,
!                       an ellipsoid with these parameters will be subtracted
!                       from the data.
!           north       Maximum latitude to compute, in degrees.
!           south       Minimum latitude to compute, in degrees.
!           east        Maximum longitude to compute, in degrees.
!           west        Minimum latitude to compute, in degrees.
!           dealloc     0 (default): Do not deallocate saved variables in the
!                       Legendre function routines. (1) Dellocate this memory
!                       at the end of the routine.
!
!       OPTIONAL (OUT)
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Notes:
!       1.  If lmax is greater than the the maximum spherical harmonic
!           degree of the input file, then this file will be ZERO PADDED!
!           (i.e., those degrees after lmax are assumed to be zero).
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use SHTOOLS, only:  PlmBar, PlBar, PlmSchmidt, PlSchmidt, PLegendreA, &
                        PLegendre, PlmON, PlON
    use ftypes

    implicit none

    real(dp), intent(in) :: cilm(:,:,:), interval
    real(dp), intent(out) :: grid(:,:)
    integer(int32), intent(in) :: lmax
    integer(int32), intent(out) :: nlat, nlong
    integer(int32), intent(in), optional :: norm, csphase, dealloc
    real(dp), intent(in), optional :: f, a, north, south, east, west
    integer(int32), intent(out), optional :: exitstatus
    integer(int32) :: l, m, j, k, index, l1, m1, lmax_comp, phase, lnorm, &
                      temp, astat(4)
    real(dp) :: pi, latmax, latmin, longmin, longmax, lat, longitude, &
                x, intervalrad, r_ex
    real(dp), allocatable :: pl(:), cosm(:, :), sinm(:, :), cilm2(:,:, :)

    if (present(exitstatus)) exitstatus = 0

    temp = 0

    if (present(north)) temp = temp + 1
    if (present(south)) temp = temp + 1
    if (present(east)) temp = temp + 1
    if (present(west)) temp = temp + 1

    if (temp /= 0 .and. temp /= 4) then
        print*, "Error --- MakeGrid2d"
        print*, "The optional parameters NORTH, SOUTH, EAST, and WEST " // &
                "must all be specified", present(north), present(south), &
                present(east), present(west)
        if (present(exitstatus)) then
            exitstatus = 5
            return
        else
            stop
        end if

    end if

    if (temp == 4) then
        latmax = north
        latmin = south
        longmin = west
        longmax = east

        if (latmax < latmin) then
            print*, "Error --- MakeGrid2d"
            print*, "NORTH must be larger than SOUTH."
            print*, "NORTH = ", latmax
            print*, "SOUTH = ", latmin
            if (present(exitstatus)) then
                exitstatus = 2
                return
            else
                stop
            end if
        end if

        if (latmax > 90.0_dp .or. latmin < -90.0_dp) then
            print*, "Error --- MakeGrid2d"
            print*, "NORTH and SOUTH must lie between 90 and -90."
            print*, "NORTH = ", latmax
            print*, "SOUTH = ", latmin
            if (present(exitstatus)) then
                exitstatus = 2
                return
            else
                stop
            end if

        end if

        if (longmin > longmax) longmax = longmax + 360.0_dp

    else
        latmax = 90.0_dp
        latmin = -90.0_dp
        longmin = 0.0_dp
        longmax = 360.d0

    end if

    nlat = int((latmax - latmin) / interval + 1)
    nlong = int((longmax - longmin) / interval + 1)

    if (present(norm)) then
        if (norm > 4 .or. norm < 1) then
            print*, "Error --- MakeGrid2d"
            print*, "Parameter NORM must be 1 (geodesy), " // &
                    "2 (Schmidt), 3 (unnormalized), or 4 (orthonormalized)."
            print*, "Input value is ", norm
            if (present(exitstatus)) then
                exitstatus = 2
                return
            else
                stop
            end if
        end if

        lnorm = norm

    else
        lnorm = 1

    end if

    if (present(csphase)) then
            if (csphase /= -1 .and. csphase /= 1) then
                print*, "Error --- MakeGrid2D"
                print*, "CSPHASE must be 1 (exclude) or -1 (include)"
                print*, "Input valuse is ", csphase
                if (present(exitstatus)) then
                    exitstatus = 2
                    return
                else
                    stop
                end if

            else
                phase = csphase

            end if
        else
            phase = 1

        end if

    if (size(grid(:,1)) < nlat .or. size(grid(1,:)) < nlong ) then
        print*, "Error --- MakeGrid2D"
        print*, "GRID must be dimensioned ( (LATMAX-LATMIN)/INTERVAL+1, " // &
                "(LONGMAX-LONGMIN)/INTERVAL+1 ) where"
        print*, "INTERVAL = ", interval
        print*, "LATMAX = ", latmax
        print*, "LATMIN = ", latmin
        print*, "LONGMIN = ", longmin
        print*, "LONGMAX = ", longmax
        print*, "Input array is dimensioned ", size(grid(:,1)), size(grid(1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(cilm(:,1,1)) < 2 .or. size(cilm(1,:,1)) < lmax+1 .or. &
                size(cilm(1,1,:)) < lmax+1) then
        print*, "Error --- MakeGrid2D"
        print*, "CILM must be dimensioned as (2, LMAX+1, LMAX+1) " // &
                "where LMAX is ", lmax
        print*, "Input dimension is ", size(cilm(:,1,1)), size(cilm(1,:,1)), &
                size(cilm(1,1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    if ((present(f) .and. .not. present(a)) .or. (present(a) .and. &
            .not. present(f)) ) then
        print*, "Error --- MakeGrid2D"
        print*, "Both F and A must be present"
        print*, "F ", present(f)
        print*, "A ", present(a)
        if (present(exitstatus)) then
            exitstatus = 5
            return
        else
            stop
        end if

    end if

    allocate (pl(((lmax+1) * (lmax+2)) / 2), stat = astat(1))
    allocate (cosm(lmax+1, int(360.0_dp/interval + 1)), stat = astat(2))
    allocate (sinm(lmax+1, int(360.0_dp/interval + 1)), stat = astat(3))
    allocate (cilm2(2,lmax+1,lmax+1), stat = astat(4))

    if (astat(1) /= 0 .or. astat(2) /= 0 .or. astat(3) /=0 &
            .or. astat(4) /= 0) then
        print*, "Error --- MakeGrid2D"
        print*, "Problem allocating arrays PL, COSM, SINM, and CILM2", &
            astat(1), astat(2), astat(3), astat(4)
        if (present(exitstatus)) then
            exitstatus = 3
            return
        else
            stop
        end if

    end if

    pi = acos(-1.0_dp)
    grid = 0.0_dp

    lmax_comp = min(lmax, size(cilm(1,1,:))-1)

    intervalrad = interval*pi/180.0_dp

    cilm2(1:2,1:lmax+1,1:lmax+1) = cilm(1:2,1:lmax+1,1:lmax+1)

    !--------------------------------------------------------------------------
    !
    !   Precomputing sines and cosines leads to an increase in speed by a
    !   factor of almost 4 with no optimization, and by a factor of about 15
    !   with normal optimizations.
    !
    !--------------------------------------------------------------------------

    do k = 1, nlong
        longitude = longmin * pi / 180.0_dp + dble(k-1) * intervalrad
        sinm(1,k) = 0.0_dp
        cosm(1,k) = 1.0_dp

        if (lmax > 0) then
            sinm(2,k) = sin(longitude)
            cosm(2,k) = cos(longitude)
        end if

        do m = 2, lmax, 1
            sinm(m+1,k) = 2 * sinm(m,k)*cosm(2,k) - sinm(m-1,k)
            cosm(m+1,k) = 2 * cosm(m,k)*cosm(2,k) - cosm(m-1,k)
        end do

    end do

    do j = 1, nlat
        lat = latmax - (j-1)*interval
        x = sin(lat*pi/180.0_dp)

        if (lat == 90.0_dp .or. lat == -90.0_dp) then

            if (present(exitstatus)) then
                select case (lnorm)
                    case (1); call PlBar(pl, lmax_comp, x, &
                                         exitstatus = exitstatus)
                    case (2); call PlSchmidt(pl, lmax_comp, x, &
                                             exitstatus = exitstatus)
                    case (3); call PLegendre(pl, lmax_comp, x, &
                                             exitstatus = exitstatus)
                    case (4); call PlON(pl, lmax_comp, x, &
                                        exitstatus = exitstatus)
                end select
                if (exitstatus /= 0) return

            else
                select case (lnorm)
                    case (1); call PlBar(pl, lmax_comp, x)
                    case (2); call PlSchmidt(pl, lmax_comp, x)
                    case (3); call PLegendre(pl, lmax_comp, x)
                    case (4); call PlON(pl, lmax_comp, x)
                end select
            end if

            do l = lmax_comp, 0, -1
                l1 = l + 1
                grid(j,1) = grid(j,1) + cilm2(1,l1,1) * pl(l1)
            end do

            grid(j, 2:nlong) = grid(j,1)

            if (present(f)) grid(j,1:nlong) = grid(j,1:nlong) - a * (1.0_dp - f)

        else

            if (present(exitstatus)) then
                select case (lnorm)
                    case (1); call PlmBar(pl, lmax_comp, x, csphase = phase, &
                                          exitstatus = exitstatus)
                    case (2); call PlmSchmidt(pl, lmax_comp, x, &
                                              csphase = phase, &
                                              exitstatus = exitstatus)
                    case (3); call PLegendreA(pl, lmax_comp, x, &
                                              csphase = phase, &
                                              exitstatus = exitstatus)
                    case (4); call PlmON(pl, lmax_comp, x, csphase = phase, &
                                         exitstatus = exitstatus)
                end select
                if (exitstatus /= 0) return

            else
                select case (lnorm)
                    case (1); call PlmBar(pl, lmax_comp, x, csphase = phase)
                    case (2); call PlmSchmidt(pl, lmax_comp, x, csphase = phase)
                    case (3); call PLegendreA(pl, lmax_comp, x, csphase = phase)
                    case (4); call PlmON(pl, lmax_comp, x, csphase = phase)
                end select
            end if

            do k = 1, nlong

                ! do m = 0 term first
                m1 = 1
                do l = 0, lmax_comp, 1
                    l1 = l + 1
                    index = ((l+1) * l) / 2 + 1
                    grid(j,k) = grid(j,k) + cilm2(1,l1,1) * cosm(1,k) * &
                                pl(index)
                end do

                do m = 1, lmax_comp, 1
                    m1 = m + 1
                    do l = m, lmax_comp, 1
                        l1 = l + 1
                        index = ((l+1) * l) / 2 + m + 1
                        grid(j,k) = grid(j,k) + (cilm2(1,l1,m1) * cosm(m1,k) +&
                                                 cilm2(2,l1,m1) * sinm(m1,k)) &
                                                 * pl(index)
                    end do
                end do

            end do

            if (present(f)) then
                lat = lat * pi / 180.0_dp
                r_ex = cos(lat)**2 + sin(lat)**2 / (1.0_dp - f)**2
                r_ex = a * sqrt(1.0_dp / r_ex)

                grid(j,1:nlong) = grid(j,1:nlong) - r_ex
            end if

        end if

    end do

    ! deallocate memory
    if (present(dealloc)) then
        if (dealloc == 1) then
            select case (lnorm)
                case (1); call PlmBar(pl, -1, x, csphase = phase)
                case (2); call PlmSchmidt(pl, -1, x, csphase = phase)
                case (4); call PlmON(pl, -1, x, csphase = phase)
            end select
        end if
    end if

    deallocate (pl)
    deallocate (cosm)
    deallocate (sinm)
    deallocate (cilm2)

end subroutine MakeGrid2D