      SUBROUTINE PDBSSOLVER1( N, M, IM, JM, DESCM, K, IK, JK, DESCK,
     $                        LAMBDA, X, IX, JX, DESCX, WORK, LWORK,
     $                        IWORK, LIWORK, INFO )
*
      IMPLICIT NONE
*
*     .. Scalar Arguments ..
      INTEGER            N, IM, JM, IK, JK, IX, JX, LWORK, LIWORK, INFO
*     ..
*     .. Array Arguments ..
      INTEGER            DESCM( * ), DESCK( * ), DESCX( * ), IWORK( * )
      DOUBLE PRECISION   M( * ), K( * ), LAMBDA( * ), X( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  PDBSSOLVER1() computes all eigenvalues and (both right and
*  left) eigenvectors of 2n-by-2n real matrix
*
*     H = [ A,  B;
*          -B, -A ],
*
*  where both A and B are n-by-n symmetric.
*
*  On entry, the information of H is provided in the lower triangular
*  parts of two n-by-n matrices M = A+B and K = A-B.
*
*  The matrices M and K are required to be positive definite.
*
*  The structure of H leads to the following properties.
*
*     1) H is diagonalizable with n pairs of real eigenvalues
*        (lambda_i, -lambda_i).
*
*     2) The eigenvectors of H has the block structure
*
*           X = [ X_1, X_2;     Y = [ X_1, -X_2;
*                 X_2, X_1 ],        -X_2,  X_1 ],
*
*        and satisfy that
*
*           X_1**T * X_2 = X_2**T * X_1,
*           X_1**T * X_1 - X_2**T * X_2 = I,
*           Y**T * X = I,
*           H * X = X * diag(lambda, -lambda),
*           Y**T * H = diag(lambda, -lambda) * Y**T.
*
*  On exit, only the positive eigenvalues and the corresponding right
*  eigenvectors are returned.  The eigenvalues are sorted in ascending
*  order.  The eigenvectors are normalized (i.e., X = [ X_1; X_2 ] with
*  X_1**T * X_1 - X_2**T * X_2 = I).
*
*  M and K are destroyed on exit.
*
*  Notes
*  =====
*
*  Each global data object is described by an associated description
*  vector.  This vector stores the information required to establish
*  the mapping between an object element and its corresponding process
*  and memory location.
*
*  Let A be a generic term for any 2D block cyclicly distributed array.
*  Such a global array has an associated description vector DESCA.
*  In the following comments, the character _ should be read as
*  "of the global array".
*
*  NOTATION        STORED IN      EXPLANATION
*  --------------- -------------- --------------------------------------
*  DTYPE_A(global) DESCA( DTYPE_ )The descriptor type.  In this case,
*                                 DTYPE_A = 1.
*  CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
*                                 the BLACS process grid A is distribu-
*                                 ted over. The context itself is glo-
*                                 bal, but the handle (the integer
*                                 value) may vary.
*  M_A    (global) DESCA( M_ )    The number of rows in the global
*                                 array A.
*  N_A    (global) DESCA( N_ )    The number of columns in the global
*                                 array A.
*  MB_A   (global) DESCA( MB_ )   The blocking factor used to distribute
*                                 the rows of the array.
*  NB_A   (global) DESCA( NB_ )   The blocking factor used to distribute
*                                 the columns of the array.
*  RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
*                                 row of the array A is distributed.
*  CSRC_A (global) DESCA( CSRC_ ) The process column over which the
*                                 first column of the array A is
*                                 distributed.
*  LLD_A  (local)  DESCA( LLD_ )  The leading dimension of the local
*                                 array.  LLD_A >= MAX(1,LOCr(M_A)).
*
*  Let K be the number of rows or columns of a distributed matrix,
*  and assume that its process grid has dimension p x q.
*  LOCr( K ) denotes the number of elements of K that a process
*  would receive if K were distributed over the p processes of its
*  process column.
*  Similarly, LOCc( K ) denotes the number of elements of K that a
*  process would receive if K were distributed over the q processes of
*  its process row.
*  The values of LOCr() and LOCc() may be determined via a call to the
*  ScaLAPACK tool function, NUMROC:
*          LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
*          LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
*  An upper bound for these quantities may be computed by:
*          LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
*          LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
*
*  Arguments
*  =========
*
*  N       (global input) INTEGER
*          The number of rows and columns of A and B.
*          The size of M, K, and X are N*N, N*N, and (2N)*N,
*          respectively.
*          N >= 0.
*
*  M       (local input and output) DOUBLE PRECISION pointer into the
*          local memory to an array of dimension
*          (LLD_M, LOCc(JM+N-1)).
*          On entry, the symmetric positive definite matrix M. Only the
*          lower triangular part of M is used to define the elements of
*          the symmetric matrix.
*          On exit, all entries of M are destroyed.
*
*  IM      (global input) INTEGER
*          The row index in the global array M indicating the first
*          row of sub( M ).
*
*  JM      (global input) INTEGER
*          The column index in the global array M indicating the
*          first column of sub( M ).
*
*  DESCM   (global and local input) INTEGER array of dimension DLEN_.
*          The array descriptor for the distributed matrix M.
*
*  K       (local input and output) DOUBLE PRECISION pointer into the
*          local memory to an array of dimension
*          (LLD_K, LOCc(JK+N-1)).
*          On entry, the symmetric positive definite matrix K. Only the
*          lower triangular part of K is used to define the elements of
*          the symmetric matrix.
*          On exit, all entries of K are destroyed.
*
*  IK      (global input) INTEGER
*          The row index in the global array K indicating the first
*          row of sub( K ).
*
*  JK      (global input) INTEGER
*          The column index in the global array K indicating the
*          first column of sub( K ).
*
*  DESCK   (global and local input) INTEGER array of dimension DLEN_.
*          The array descriptor for the distributed matrix K.
*
*  LAMBDA  (global output) DOUBLE PRECISION array, dimension (N)
*          On normal exit LAMBDA contains the positive eigenvalues of H
*          in ascending order.
*
*  X       (local output) DOUBLE PRECISION array,
*          global dimension (2N, N),
*          local dimension ( LLD_X, LOCc(JX+N-1) )
*          On normal exit X contains the normalized right eigenvectors
*          of H corresponding to the positive eigenvalues.
*
*  IX      (global input) INTEGER
*          X's global row index, which points to the beginning of the
*          submatrix which is to be operated on.
*          In this version, only IX = JX = 1 is supported.
*
*  JX      (global input) INTEGER
*          X's global column index, which points to the beginning of
*          the submatrix which is to be operated on.
*          In this version, only IX = JX = 1 is supported.
*
*  DESCX   (global and local input) INTEGER array of dimension DLEN_.
*          The array descriptor for the distributed matrix X.
*          DESCX( CTXT_ ) must equal DESCA( CTXT_ )
*
*  WORK    (local workspace/output) DOUBLE PRECISION array,
*          dimension (LWORK)
*          On output, WORK( 1 ) returns the minimal amount of workspace
*          needed to guarantee completion.
*          If the input parameters are incorrect, WORK( 1 ) may also be
*          incorrect.
*
*  LWORK   (local input) INTEGER
*          The length of the workspace array WORK.
*          If LWORK = -1, the LWORK is global input and a workspace
*          query is assumed; the routine only calculates the minimum
*          size for the WORK/IWORK array. The required workspace is
*          returned as the first element of WORK/IWORK and no error
*          message is issued by PXERBLA.
*
*  IWORK   (local workspace/output) INTEGER array,
*          dimension (LIWORK)
*          On output, IWORK( 1 ) returns the minimal amount of workspace
*          needed to guarantee completion.
*          If the input parameters are incorrect, IWORK( 1 ) may also be
*          incorrect.
*
*  LIWORK   (local input) INTEGER
*          The length of the workspace array IWORK.
*          If LIWORK = -1, the LIWORK is global input and a workspace
*          query is assumed; the routine only calculates the minimum
*          size for the WORK/IWORK array. The required workspace is
*          returned as the first element of WORK/IWORK and no error
*          message is issued by PXERBLA.
*
*  INFO    (global output) INTEGER
*          = 0:  successful exit
*          < 0:  If the i-th argument is an array and the j-entry had
*                an illegal value, then INFO = -(i*100+j), if the i-th
*                argument is a scalar and had an illegal value, then
*                INFO = -i.
*          > 0:  The eigensolver did not converge.
*
*  Alignment requirements
*  ======================
*
*  This subroutine requires M and K to be identically distributed.
*  In addition, square blocks ( i.e., MB = NB ) are required.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
     $                   LLD_, MB_, M_, NB_, N_, RSRC_
      PARAMETER          ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
     $                     CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
     $                     RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
      DOUBLE PRECISION   ZERO, ONE, HALF
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            ICTXT, NPROCS, NPROW, NPCOL, MYROW, MYCOL, I,
     $                   TWON, LWKOPT, LLWORK, INDWORK, ITMP, DIMV, NZ,
     $                   LIWKOPT
      DOUBLE PRECISION   DTMP
      DOUBLE PRECISION   T_CHOL, T_FORMW, T_DIAG, T_VEC1, T_VEC2, T_PREP
*     ..
*     .. Local Arrays ..
      DOUBLE PRECISION   DDUM( 3 )
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE, DSQRT
*     ..
*     .. External Functions ..
      EXTERNAL           NUMROC, MPI_WTIME
      INTEGER            NUMROC
      DOUBLE PRECISION   MPI_WTIME
*     ..
*     .. External Subroutines ..
      EXTERNAL           PDAXPY, PDCOPY, PDSCAL, PDGEADD, PDPOTRF,
     $                   PDSYEVR, PDSYGST, PXERBLA, BLACS_GRIDINFO,
     $                   CHK1MAT, PCHK2MAT, PDTRMM, PDTRSM
*     ..
*     .. Executable Statements ..
*
      T_PREP = MPI_WTIME()
      INFO = 0
      TWON = 2*N
      ICTXT = DESCM( CTXT_ )
      CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
      NPROCS = NPROW*NPCOL
      IF ( NPROW .EQ. -1 ) THEN
         INFO = -( 500+CTXT_ )
      END IF
*
*     Test the input arguments.
*
      IF ( INFO .EQ. 0 .AND. N .LT. 0 ) THEN
         INFO = -1
      END IF
      IF ( INFO .EQ. 0 )
     $   CALL CHK1MAT( N, 1, N, 1, IM, JM, DESCM, 5, INFO )
      IF ( INFO .EQ. 0 .AND. DESCM( MB_ ) .NE. DESCM( NB_ ) )
     $   INFO = -( 500+MB_ )
      IF ( INFO .EQ. 0 )
     $   CALL CHK1MAT( N, 1, N, 1, IK, JK, DESCK, 9, INFO )
      IF ( INFO .EQ. 0 .AND. DESCK( MB_ ) .NE. DESCK( NB_ ) )
     $   INFO = -( 900+MB_ )
      IF ( INFO .EQ. 0)
     $   CALL PCHK2MAT( N, 1, N, 1, IM, JM, DESCM, 5, N, 1, N, 1,
     $        IK, JK, DESCK, 9, 0, ITMP, ITMP, INFO )
      IF ( INFO .EQ. 0 )
     $   CALL CHK1MAT( TWON, 1, N, 1, IX, JX, DESCX, 14, INFO )
      IF ( INFO .EQ. 0 .AND. DESCX( MB_ ) .NE. DESCX( NB_ ) )
     $   INFO = -( 1000+MB_ )
*
*     Compute required workspace.
*
      IF ( INFO .EQ. 0 ) THEN
*
*        Set up local indices for the workspace.
*
         LQUERY = LWORK .EQ. -1
         INDWORK = 1
         LLWORK = LWORK - INDWORK + 1
*
*        Estimate the workspace required by external subroutines.
*
!         CALL PDSYEV( 'V', 'L', N, DTMP, IK, JK, DESCK, DTMP, DTMP, IM,
!     $        JM, DESCM, WORK, -1, ITMP )
         CALL PDSYEVR( 'V', 'A', 'L', N, DTMP, IK, JK, DESCK, ZERO,
     $        ZERO, 1, N, DIMV, NZ, DTMP, DTMP, IM, JM, DESCM, DDUM, -1,
     $        IWORK, -1, ITMP )
         LWKOPT = INT( DDUM( 1 ) )
         LIWKOPT = IWORK( 1 )
*
         LWKOPT = INDWORK - 1 + LWKOPT
         IF ( .NOT. LQUERY .AND. LWORK .LT. LWKOPT )
     $      INFO = -16
         IF ( INFO .EQ. 0 .AND. .NOT. LQUERY .AND. LIWORK .LT. LIWKOPT )
     $      INFO = -18
      END IF
*
      IF ( INFO .NE. 0 ) THEN
         CALL PXERBLA( ICTXT, 'PDBSSOLVER1', -INFO )
         RETURN
      END IF
      WORK( 1 ) = DBLE( LWKOPT )
      IF ( LQUERY )
     $   RETURN
*
*     Quick return if possible.
*
      IF ( N .EQ. 0 )
     $   RETURN
      T_PREP = MPI_WTIME() - T_PREP
!      IF ( MYROW+MYCOL .EQ. 0 )
!     $   WRITE( *, * ) 't_prep = ', T_PREP, ';'
*
*     Compute the Cholesky factorization M = L * L**T.
*     In case of failure, a general solver is needed.
*
      T_CHOL = MPI_WTIME()
      CALL PDPOTRF( 'L', N, M, IM, JM, DESCM, ITMP )
*
*     Keep a copy of L in X for later use.
*
      CALL PDGEADD( 'N', N, N, ONE, M, IM, JM, DESCM,
     $     ZERO, X, IX, JX, DESCX )
      T_CHOL = MPI_WTIME() - T_CHOL
!      IF ( MYROW+MYCOL .EQ. 0 )
!     $   WRITE( *, * ) 't_chol = ', T_CHOL, ';'
!      CALL PDLAPRNT( N, N, M, IM, JM, DESCM, 0, 0, 'L', 6,
!     $     WORK( INDWORK ) )
!      IF ( MYROW+MYCOL .EQ. 0 )
!     $   WRITE( *, * ) "L=tril(L);"
      IF ( ITMP .NE. 0 ) THEN
         INFO = -2
         RETURN
      END IF
*
*     Explicitly formulate W = L**T * K * L.
*     Only the lower triangular part of W is filled by the correct
*     values.
*
      T_FORMW = MPI_WTIME()
      CALL PDSYGST( 3, 'L', N, K, IK, JK, DESCK, M, IM, JM, DESCM, DTMP,
     $     ITMP )
      T_FORMW = MPI_WTIME() - T_FORMW
!      IF ( MYROW+MYCOL .EQ. 0 )
!     $   WRITE( *, * ) 't_formw = ', T_FORMW, ';'
!      CALL PDLAPRNT( N, N, K, IK, JK, DESCK, 0, 0, 'W',
!     $     6, WORK( INDWORK ) )
*
*     Diagonalization: V**T * (L**T * K * L) * V = diag(lambda).
*
      T_DIAG = MPI_WTIME()
!      CALL PDSYEV( 'V', 'L', N, K, IK, JK, DESCK, LAMBDA, M,
!     $     IM, JM, DESCM, WORK( INDWORK ), LLWORK, ITMP )
      CALL PDSYEVR( 'V', 'A', 'L', N, K, IK, JK, DESCK, ZERO, ZERO,
     $     1, N, DIMV, NZ, LAMBDA, M, IM, JM, DESCM,
     $     WORK( INDWORK ), LLWORK, IWORK, LIWORK, ITMP )
      T_DIAG = MPI_WTIME() - T_DIAG
!      IF ( MYROW+MYCOL .EQ. 0 )
!     $   WRITE( *, * ) 't_diag = ', T_DIAG, ';'
      IF ( ITMP .NE. 0 ) THEN
         INFO = ITMP
         WRITE( *, * ) '% PDSYEVR fails with INFO =', INFO
         RETURN
      END IF
      DO I = 1, N
         LAMBDA( I ) = DSQRT( LAMBDA( I ) )
      END DO
!      IF ( MYROW+MYCOL .EQ. 0 ) THEN
!         DO I = 1, N
!            WRITE( *, * ) 'lambda0(', I, ', 1) =', LAMBDA( I ), ';'
!         END DO
!      END IF
!      CALL PDLAPRNT( N, N, M, IM, JM, DESCM, 0, 0, 'V',
!     $     6, WORK( INDWORK ) )
*
*     Recover the eigenvectors:
*
*        X = [ ( Psi * Lambda**{1/2} + Phi * Lambda**{-1/2} ) / 2
*              ( Psi * Lambda**{1/2} - Phi * Lambda**{-1/2} ) / 2 ]
*
*     where
*
*        Phi = L * V, Psi = L**{-T} * V.
*
*     To save memory, Psi and Phi are stored in M and K, respectively.
*
      T_VEC1 = MPI_WTIME()
      CALL PDGEADD( 'N', N, N, ONE, M, IM, JM, DESCM,
     $     ZERO, K, IK, JK, DESCK )
      CALL PDTRMM( 'L', 'L', 'N', 'N', N, N, ONE, X, IX, JX, DESCX,
     $     K, IK, JK, DESCK )
      CALL PDTRSM( 'L', 'L', 'T', 'N', N, N, ONE, X, IX, JX, DESCX,
     $     M, IM, JM, DESCM )
*
*     Scale Psi and Phi.
*
      DO I = 1, N
         CALL PDSCAL( N, HALF*DSQRT( LAMBDA( I ) ),
     $        M, IM, JM+I-1, DESCM, 1 )
      END DO
      DO I = 1, N
         CALL PDSCAL( N, HALF/DSQRT( LAMBDA( I ) ),
     $        K, IK, JK+I-1, DESCK, 1 )
      END DO
      T_VEC1 = MPI_WTIME() - T_VEC1
!      IF ( MYROW+MYCOL .EQ. 0 )
!     $   WRITE( *, * ) 't_vec1 = ', T_VEC1, ';'
!      CALL PDLAPRNT( N, N, M, IM, JM, DESCM, 0, 0, 'Psi',
!     $     6, WORK( INDWORK ) )
!      CALL PDLAPRNT( N, N, K, IK, JK, DESCK, 0, 0, 'Phi',
!     $     6, WORK( INDWORK ) )
*
*     Construct X.
*
      T_VEC2 = MPI_WTIME()
      CALL PDGEADD( 'N', N, N, ONE, M, IM, JM, DESCM,
     $     ZERO, X, IX, JX, DESCX )
      CALL PDGEADD( 'N', N, N, ONE, M, IM, JM, DESCM,
     $     ZERO, X, IX+N, JX, DESCX )
      CALL PDGEADD( 'N', N, N, ONE, K, IK, JK, DESCK,
     $     ONE, X, IX, JX, DESCX )
      CALL PDGEADD( 'N', N, N, -ONE, K, IK, JK, DESCK,
     $     ONE, X, IX+N, JX, DESCX )
      T_VEC2 = MPI_WTIME() - T_VEC2
!      IF ( MYROW+MYCOL .EQ. 0 )
!     $   WRITE( *, * ) 't_vec2 = ', T_VEC2, ';'
!      CALL PDLAPRNT( TWON, N, X, IX, JX, DESCX, 0, 0, 'X', 6,
!     $     WORK( INDWORK ) )
*
      WORK( 1 ) = DBLE( LWKOPT )
*
      RETURN
*
*     End of PDBSSOLVER1().
*
      END


C
C***********************************************************************
C                                                                      *
C            NACHOS II - A Finite Element Computer Program             *
C                        for Incompressible Flow Problems              *
C                                                                      *
C     Copyright (c) 1986,2019   National Technology & Engineering      *
C                               Solutions of Sandia, LLC (NTESS)       *
C                                                                      *
C                            All rights reserved.                      *
C                                                                      *
C     This software is distributed under the BSD 3-Clause License.     *
C                                                                      *
C***********************************************************************
C
      SUBROUTINE COORD6 (XB,YB,XX,YY,S,T,INODE,ICONV)
C
C     ******************************************************************
C
C     SUBROUTINE TO LOCATE NORMALIZED COORDINATES S,T IN PARENT ELEMENT
C     ISOPARAMETRIC SIX-NODE TRIANGLE
C
C     ******************************************************************
C
      DIMENSION XX(*), YY(*)
      DIMENSION SS(6), TT(6)
C
      DATA SS/1.,0.,0.,.5,0.,.5/
      DATA TT/0.,1.,0.,.5,.5,0./
      DATA TOL/.005/,IMAX/20/
C
C     STATEMENT FUNCTIONS FOR SHAPE FUNCTIONS AND DERIVATIVES
C
      FX(SP,TP)=XX(1)*SP*(2.*SP-1.)+XX(2)*TP*(2.*TP-1.)+XX(3)*(2.*(SP+TP
     1)**2-3.*(SP+TP)+1.)+XX(4)*4.*SP*TP+XX(5)*4.*(-TP*TP-SP*TP+TP)+XX(6
     2)*4.*(-SP*SP-SP*TP+SP)
C
      FY(SP,TP)=YY(1)*SP*(2.*SP-1.)+YY(2)*TP*(2.*TP-1.)+YY(3)*(2.*(SP+TP
     1)**2-3.*(SP+TP)+1.)+YY(4)*4.*SP*TP+YY(5)*4.*(-TP*TP-SP*TP+TP)+YY(6
     2)*4.*(-SP*SP-SP*TP+SP)
C
      DFXDS(SP,TP)=XX(1)*(4.*SP-1.)+XX(3)*(4.*SP+4.*TP-3.)+XX(4)*(4.*TP)
     1+XX(5)*(-4.*TP)+XX(6)*(-8.*SP-4.*TP+4.)
C
      DFYDS(SP,TP)=YY(1)*(4.*SP-1.)+YY(3)*(4.*SP+4.*TP-3.)+YY(4)*(4.*TP)
     1+YY(5)*(-4.*TP)+YY(6)*(-8.*SP-4.*TP+4.)
C
      DFXDT(SP,TP)=XX(2)*(4.*TP-1.)+XX(3)*(4.*TP+4.*SP-3.)+XX(4)*(4.*SP)
     1+XX(5)*(-8.*TP-4.*SP+4.)+XX(6)*(-4.*SP)
C
      DFYDT(SP,TP)=YY(2)*(4.*TP-1.)+YY(3)*(4.*TP+4.*SP-3.)+YY(4)*(4.*SP)
     1+YY(5)*(-8.*TP-4.*SP+4.)+YY(6)*(-4.*SP)
C
C     ******************************************************************
C
C     CHECK FOR COINCIDENT NODE
C
      IF (INODE.EQ.0) GO TO 10
C
      S=SS(INODE)
      T=TT(INODE)
      RETURN
C
C     USE NEWTON RAPHSON PROCEDURE TO COMPUTE S,T COORDINATES
C
   10 CONTINUE
      SG=0.
      TG=0.
      ICOUNT=0
   20 CONTINUE
C
C     BUILD JACOBIAN AND INVERT
C
      A11=DFXDS(SG,TG)
      A12=DFYDS(SG,TG)
      A21=DFXDT(SG,TG)
      A22=DFYDT(SG,TG)
      F1=FX(SG,TG)-XB
      F2=FY(SG,TG)-YB
      DETA=A11*A22-A12*A21
      SNEW=SG-(A22*F1-A21*F2)/DETA
      TNEW=TG-(-A12*F1+A11*F2)/DETA
C
C     CHECK CONVERGENCE
C
      ICOUNT=ICOUNT+1
      DS=ABS(SNEW-SG)
      DT=ABS(TNEW-TG)
      IF (DS.LT.TOL.AND.DT.LT.TOL) GO TO 30
      SG=SNEW
      TG=TNEW
      IF (ICOUNT.EQ.IMAX) GO TO 40
      GO TO 20
C
   30 CONTINUE
      S=SNEW
      T=TNEW
      RETURN
C
   40 CONTINUE
      ICONV=1
C
      RETURN
      END


\ 2LOG with even less frills
\ Albert Nijhof 28apr2022
\ Unsigned argument as input
\ Please Note: For u=0 --> y=0

: B+B ( byte1 byte2 -- x ) 8 lshift or ; 	\ ( 12 34 --> 3412 )

: 2LOG ( u -- y )
    [ 8 cells ] literal     \ #bits/cell
    0 do  s>d
        if  2*
            [ 8 cells 8 - ] literal rshift  \ lineaire interpolatie
            [ 8 cells 1- ]  literal  i -    \ logaritmische klasse
            b+b leave
        then 2*
    loop ;

\ ------------------- some small jokes -------------------
\ and back... (antilog)
hex : -2LOG ( logx -- x )
    >r  r@ FF and 100 or
    r>  8 rshift 8 - s>d
    if abs rshift else lshift then ;
decimal

\ a very conveniant square
: SQRT ( u -- y ) 							\ y = sqrt( u ) (unexpectedly accururate)
    2log 2/ -2log ;

\ <><>


module test_operator
    use testdrive, only: new_unittest, unittest_type, error_type, check
    use auto_diff, only: operator(+), operator(-), operator(*), operator(/), operator(**)
    use auto_diff, only: rk, tree_t, assignment(=)
    implicit none
    private

    public :: collect_suite_operator

contains

    !> Collect all exported unit tests
    subroutine collect_suite_operator(testsuite)
        !> Collection of tests
        type(unittest_type), allocatable, intent(out) :: testsuite(:)

        testsuite = [ &
                    new_unittest("operator(+) valid", test_add_valid), &
                    new_unittest("operator(-) valid", test_sub_valid), &
                    new_unittest("operator(*) valid", test_mult_valid), &
                    new_unittest("operator(/) valid", test_div_valid), &
                    new_unittest("operator(**) valid", test_pow_valid) &
                    ]

    end subroutine collect_suite_operator

    subroutine test_add_valid(error)
        type(error_type), allocatable, intent(out) :: error

        type(tree_t) :: a, b
        type(tree_t) :: c

        a = 1.0_rk
        b = 2.0_rk

        c = a + b
        call c%backward()

        call check(error, c%get_value(), 3.0_rk); if (allocated(error)) return
        call check(error, a%get_grad(), 1.0_rk); if (allocated(error)) return
        call check(error, b%get_grad(), 1.0_rk); if (allocated(error)) return

        a = 1.0_rk
        c = a + 1.0_rk
        call c%backward()

        call check(error, c%get_value(), 2.0_rk); if (allocated(error)) return
        call check(error, a%get_grad(), 1.0_rk); if (allocated(error)) return

        a = 1.0_rk
        c = 1.0_rk + a
        call c%backward()

        call check(error, c%get_value(), 2.0_rk); if (allocated(error)) return
        call check(error, a%get_grad(), 1.0_rk)

    end subroutine test_add_valid

    subroutine test_sub_valid(error)
        type(error_type), allocatable, intent(out) :: error

        type(tree_t) :: a, b
        type(tree_t) :: c

        a = 1.0_rk
        b = 2.0_rk

        c = a - b
        call c%backward()

        call check(error, c%get_value(), -1.0_rk); if (allocated(error)) return
        call check(error, a%get_grad(), 1.0_rk); if (allocated(error)) return
        call check(error, b%get_grad(), -1.0_rk); if (allocated(error)) return

        a = 1.0_rk
        c = a - 1.0_rk
        call c%backward()

        call check(error, c%get_value(), 0.0_rk); if (allocated(error)) return
        call check(error, a%get_grad(), 1.0_rk); if (allocated(error)) return

        a = 1.0_rk
        c = 1.0_rk - a
        call c%backward()

        call check(error, c%get_value(), 0.0_rk); if (allocated(error)) return
        call check(error, a%get_grad(), -1.0_rk)

    end subroutine test_sub_valid

    subroutine test_mult_valid(error)
        type(error_type), allocatable, intent(out) :: error

        type(tree_t) :: a, b
        type(tree_t) :: c

        a = 1.0_rk
        b = 2.0_rk

        c = a * b
        call c%backward()

        call check(error, c%get_value(), 2.0_rk); if (allocated(error)) return
        call check(error, a%get_grad(), 2.0_rk); if (allocated(error)) return
        call check(error, b%get_grad(), 1.0_rk); if (allocated(error)) return

        a = 1.0_rk
        c = a * 1.0_rk
        call c%backward()

        call check(error, c%get_value(), 1.0_rk); if (allocated(error)) return
        call check(error, a%get_grad(), 1.0_rk); if (allocated(error)) return

        a = 1.0_rk
        c = 1.0_rk * a
        call c%backward()

        call check(error, c%get_value(), 1.0_rk); if (allocated(error)) return
        call check(error, a%get_grad(), 1.0_rk)

    end subroutine test_mult_valid

    subroutine test_div_valid(error)
        type(error_type), allocatable, intent(out) :: error

        type(tree_t) :: a, b
        type(tree_t) :: c

        a = 1.0_rk
        b = 2.0_rk

        c = a / b
        call c%backward()

        call check(error, c%get_value(), 0.5_rk); if (allocated(error)) return
        call check(error, a%get_grad(), 0.5_rk); if (allocated(error)) return
        call check(error, b%get_grad(), -0.25_rk); if (allocated(error)) return

        a = 1.0_rk
        c = a / 1.0_rk
        call c%backward()

        call check(error, c%get_value(), 1.0_rk); if (allocated(error)) return
        call check(error, a%get_grad(), 1.0_rk); if (allocated(error)) return

        a = 1.0_rk
        c = 1.0_rk / a
        call c%backward()

        call check(error, c%get_value(), 1.0_rk); if (allocated(error)) return
        call check(error, a%get_grad(), -1.0_rk)

    end subroutine test_div_valid

    subroutine test_pow_valid(error)
        type(error_type), allocatable, intent(out) :: error

        type(tree_t) :: a, b
        type(tree_t) :: c

        a = 1.0_rk
        b = 2.0_rk

        c = a ** b
        call c%backward()

        call check(error, c%get_value(), 1.0_rk); if (allocated(error)) return
        call check(error, a%get_grad(), 2.0_rk); if (allocated(error)) return
        call check(error, b%get_grad(), 2.0_rk); if (allocated(error)) return

        a = 1.0_rk
        c = a ** 1.0_rk
        call c%backward()

        call check(error, c%get_value(), 1.0_rk); if (allocated(error)) return
        call check(error, a%get_grad(), 1.0_rk); if (allocated(error)) return

        a = 1.0_rk
        c = 1.0_rk ** a
        call c%backward()

        call check(error, c%get_value(), 1.0_rk); if (allocated(error)) return
        call check(error, a%get_grad(), 0.0_rk)

    end subroutine test_pow_valid

end module test_operator


c  File: sfrenl.[for|f|c]
c  Contains procedures: SFRENC(), SFRENF(), SFRENG(), SFRENS()
c  and private low-level procedure: SFREN1().
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 2000-12-01 SFRENL Krogh Removed parameter PID2.
c>> 2000-09-07 SFRENL Krogh Changed text on x to one on ax.
c>> 1996-01-08 SFRENL WV Snyder Use SCSPXX for cos(Pi/2 x**2), etc.
C>> 1995-11-03 SFRENL Krogh  Removed blanks in numbers for C conversion.
c>> 1994-11-02 SFRENL Krogh  Changes to use M77CON
c>> 1994-10-18 SFRENL WV Snyder More specializing instructions
c>> 1993-02-25 SFRENL CLL. Edited to eliminate ENTRY and EQUIVALENCE.
c>> 1992-09-15 SFRENL WV Snyder Specializing instructions
c>> 1992-04-13 SFRENL WV Snyder Declare SFRENF, SFRENG, SFRENS
c>> 1992-03-18 SFRENL WV Snyder Move declarations for coefficient arrays
c>> 1992-01-24 SFRENL WV Snyder Original code
c--S replaces "?": ?FRENC, ?FREN1, ?FRENF, ?FRENG, ?FRENS, ?FRENL
c--&               ?CSPXX, ?SNPXX
c Subprograms in this file compute the Fresnel Cosine and Sine
c integrals C(x) and S(x), and the auxiliary functions f(x) and g(x),
c for any X:
c     SFRENC(X) for Fresnel integral C(X)
c     SFRENS(X) for Fresnel integral S(x)
c     SFRENF(X) for Fresnel integral auxiliary function f(x)
c     SFRENG(X) for Fresnel integral auxiliary function g(x).
c
c Developed by W. V. Snyder, Jet Propulsion Laboratory, 24 January 1992.
c
c Ref: W. J. Cody, "Chebyshev Approximations for the Fresnel Integrals",
c Mathematics of Computation, 1968, pp 450-453 plus Microfiche Suppl.
c W. V. Snyder, "Algorithm 723: Fresnel Integrals," ACM Trans. Math.
c Softw. 19, 4 (December 1993) 452-456.
c Accuracies of highest order formulae, where E is relative error:
c
c Range           Function   -log10(E)   Function   -log10(E)
c |X|<=1.2          C(x)       16.24       S(x)       17.26
c 1.2<|X|<=1.6      C(x)       17.47       S(x)       18.66
c 1.6<|X|<=1.9      f(x)       17.13       g(x)       16.25
c 1.9<|X|<=2.4      f(x)       16.64       g(x)       15.65
c 2.4<|X|           f(x)       16.89       g(x)       15.58
c
c Refer to Cody for accuracy of other approximations.
c
c     ==================================================================
      real             function SFRENC(X)
      external SFREN1
      real             X, SFREN1
      SFRENC = SFREN1(1,X)
      return
      end
c     ==================================================================
      real             function SFRENF(X)
      external SFREN1
      real             X, SFREN1
      SFRENF = SFREN1(3,X)
      return
      end
c     ==================================================================
      real             function SFRENG(X)
      external SFREN1
      real             X, SFREN1
      SFRENG = SFREN1(4,X)
      return
      end
c     ==================================================================
      real             function SFRENS(X)
      external SFREN1
      real             X, SFREN1
      SFRENS = SFREN1(2,X)
      return
      end
c     ==================================================================
      real             function SFREN1(MODE, X)
c     MODE = 1 means compute C.
c     MODE = 2 means compute S.
c     MODE = 3 means compute F.
c     MODE = 4 means compute G.
c     ------------------------------------------------------------------
c                        Internal variables.
c
c RPI is the reciprocal of PI.
c RPISQ is the reciprocal of PI squared.
c AX is abs(x).
c BIGX is 1/sqrt(round-off).  If X > BIGX then to the working
c         precision x**2 is an integer (which we assume to be a multiple
c         of four), so cos(pi/2 * x**2) = 1, and sin(pi/2 * x**2) = 0.
c C and S are values of C(x) and S(x), respectively.
c CX and SX are cos(pi/2 * ax**2) and sin(pi/2 * ax**2), respectively.
c F and G are used to compute f(x) and g(x) when X > 1.6.
c HAVEC, HAVEF, HAVEG, HAVES are logical variables that indicate
c         whether the values stored in C, F, G and S correspond to the
c         value stored in X.  HAVEF indicates we have both F and G when
c         XSAVE .le. 1.6, and HAVEC indicates we have both C and S when
c         XSAVE .gt. 1.6.
c LARGEF is 1/(pi * underflow).  If X > LARGEF then f ~ 0.
c LARGEG is cbrt(1/(pi**2 * underflow)).  If X > LARGEG then g ~ 0.
c LARGEX is 1/sqrt(sqrt(underflow)).  If X > LARGEX then f ~ 1/(pi * x)
c         and g ~ 1/(pi**2 * x**3).
c MODE indicates the function to be computed: 1 = C(x), 2 = S(x),
c         3 = f(x), 4 = g(x).
c NEEDC, NEEDF, NEEDG, NEEDS are arrays indexed by MODE (MODE+4 when
c         X .gt. 1.6) that indicate what functions are needed.
c WANTC indicates whether C and S must be computed from F and G.
c WANTF and WANTG indicate we computed F and G on the present call.
c XSAVE is the most recently provided value of X.
c X4 is either X ** 4 or (1.0/X) ** 4.
c     If you change the order of approximation, you must change the
c     declarations and DATA statements for the coefficient arrays,
c     and the executable statements that evaluate the approximations.
c     ------------------------------------------------------------------
      external R1MACH, SCSPXX, SSNPXX
      real             R1MACH, SCSPXX, SSNPXX
      real             RPI, RPISQ
      parameter (RPI = 0.3183098861837906715377675267450287240689e0)
      parameter (RPISQ = RPI * RPI)
      real             AX, BIGX, C, CX, F, G, LARGEF, LARGEG, LARGEX
      real             S, SX, X, XSAVE, X4
      integer MODE
      logical HAVEC, HAVEF, HAVEG, HAVES, WANTC, WANTF, WANTG
      logical NEEDC(8), NEEDF(8), NEEDG(8), NEEDS(8)
      save BIGX, C, F, G, LARGEF, LARGEG, LARGEX, S, XSAVE
      save HAVEC, HAVEF, HAVEG, HAVES
c++   default digits=16
c++   code for digits <= 3 is inactive
c      real             PC1(0:1), QC1(1:1)
c++   code for digits > 3 & digits <= 6 is inactive
c      real             PC1(0:2), QC1(1:2)
c++   code for digits > 6 & digits <= 11 is inactive
c      real             PC1(0:3), QC1(1:3)
c++   code for digits > 11 is active
      real             PC1(0:4), QC1(1:4)
c++   end
c++   code for digits <= 2 is inactive
c      real             PC2(0:1), QC2(1:1)
c++   code for digits > 2 & digits <= 5 is inactive
c      real             PC2(0:2), QC2(1:2)
c++   code for digits > 5 & digits <= 8 is inactive
c      real             PC2(0:3), QC2(1:3)
c++   code for digits > 8 & digits <= 12 is inactive
c      real             PC2(0:4), QC2(1:4)
c++   code for digits > 12 is active
      real             PC2(0:5), QC2(1:5)
c++   end
c++   code for digits <= 3 is inactive
c      real             PS1(0:1), QS1(1:1)
c++   code for digits > 3 & digits <= 7 is inactive
c      real             PS1(0:2), QS1(1:2)
c++   code for digits > 7 & digits <= 12 is inactive
c      real             PS1(0:3), QS1(1:3)
c++   code for digits > 12 is active
      real             PS1(0:4), QS1(1:4)
c++   end
c++   code for digits <= 2 is inactive
c      real             PS2(0:1), QS2(1:1)
c++   code for digits > 2 & digits <= 5 is inactive
c      real             PS2(0:2), QS2(1:2)
c++   code for digits > 5 & digits <= 9 is inactive
c      real             PS2(0:3), QS2(1:3)
c++   code for digits > 9 & digits <= 14 is inactive
c      real             PS2(0:4), QS2(1:4)
c++   code for digits > 14 is active
      real             PS2(0:5), QS2(1:5)
c++   end
c++   code for digits <= 5 is inactive
c      real             PF1(0:1), QF1(1:1)
c++   code for digits > 5 & digits <= 8 is inactive
c      real             PF1(0:2), QF1(1:2)
c++   code for digits > 8 & digits <= 11 is inactive
c      real             PF1(0:3), QF1(1:3)
c++   code for digits > 11 & digits <= 14 is inactive
c      real             PF1(0:4), QF1(1:4)
c++   code for digits > 14 is active
      real             PF1(0:5), QF1(1:5)
c++   end
c++   code for digits <= 5 is inactive
c      real             PF2(0:1), QF2(1:1)
c++   code for digits > 5 & digits <= 8 is inactive
c      real             PF2(0:2), QF2(1:2)
c++   code for digits > 8 & digits <= 11 is inactive
c      real             PF2(0:3), QF2(1:3)
c++   code for digits > 11 & digits <= 14 is inactive
c      real             PF2(0:4), QF2(1:4)
c++   code for digits > 14 is active
      real             PF2(0:5), QF2(1:5)
c++   end
c++   code for digits <= 3 is inactive
c      real             PF3(0:0)
c++   code for digits > 3 & digits <= 6 is inactive
c      real             PF3(0:1), QF3(1:1)
c++   code for digits > 6 & digits <= 9 is inactive
c      real             PF3(0:2), QF3(1:2)
c++   code for digits > 9 & digits <= 11 is inactive
c      real             PF3(0:3), QF3(1:3)
c++   code for digits > 11 & digits <= 13 is inactive
c      real             PF3(0:4), QF3(1:4)
c++   code for digits > 13 & digits <= 15 is inactive
c      real             PF3(0:5), QF3(1:5)
c++   code for digits > 15 is active
      real             PF3(0:6), QF3(1:6)
c++   end
c++   code for digits <= 4 is inactive
c      real             PG1(0:1), QG1(1:1)
c++   code for digits > 4 & digits <= 7 is inactive
c      real             PG1(0:2), QG1(1:2)
c++   code for digits > 7 & digits <= 10 is inactive
c      real             PG1(0:3), QG1(1:3)
c++   code for digits > 10 & digits <= 13 is inactive
c     real             PG1(0:4), QG1(1:4)
c++   code for digits > 13 is active
      real             PG1(0:5), QG1(1:5)
c++   end
c++   code for digits <= 4 is inactive
c      real             PG2(0:1), QG2(1:1)
c++   code for digits > 4 & digits <= 7 is inactive
c      real             PG2(0:2), QG2(1:2)
c++   code for digits > 7 & digits <= 10 is inactive
c      real             PG2(0:3), QG2(1:3)
c++   code for digits > 10 & digits <= 13 is inactive
c      real             PG2(0:4), QG2(1:4)
c++   code for digits > 13 is active
      real             PG2(0:5), QG2(1:5)
c++   end
c++   code for digits <= 3 is inactive
c      real             PG3(0:0)
c++   code for digits > 3 & digits <= 5 is inactive
c      real             PG3(0:1), QG3(r:1)
c++   code for digits > 5 & digits <= 8 is inactive
c      real             PG3(0:2), QG3(1:2)
c++   code for digits > 8 & digits <= 10 is inactive
c      real             PG3(0:3), QG3(1:3)
c++   code for digits > 10 & digits <= 12 is inactive
c      real             PG3(0:4), QG3(1:4)
c++   code for digits = 13 is inactive
c      real             PG3(0:5), QG3(1:5)
c++   code for digits > 13 is active
      real             PG3(0:6), QG3(1:6)
c++   end
c
      data BIGX /-1.0e0/
      data C /0.0e0/, F /0.5e0/, G /0.5e0/, S /0.0e0/, XSAVE /0.0e0/
      data HAVEC/.TRUE./, HAVEF/.TRUE./, HAVEG/.TRUE./, HAVES/.TRUE./
c        C(x)    S(x)    f(x)    g(x)    C(x)    S(x)    f(x)    g(x)
      data NEEDC
     1 /.TRUE., .FALSE.,.TRUE., .TRUE., .TRUE., .FALSE.,.FALSE.,.FALSE./
      data NEEDS
     1 /.FALSE.,.TRUE., .TRUE., .TRUE., .FALSE.,.TRUE., .FALSE.,.FALSE./
      data NEEDF
     1 /.FALSE.,.FALSE.,.TRUE., .FALSE.,.TRUE., .TRUE., .TRUE., .FALSE./
      data NEEDG
     1 /.FALSE.,.FALSE.,.FALSE.,.TRUE. ,.TRUE., .TRUE., .FALSE.,.TRUE. /
c
c     Coefficients for C(x), |X| <= 1.2
c++   code for digits <= 3 is inactive
c      data pc1 / 1.00053e0, -1.12353e-1/, qc1 /1.38937e-1/
c++   code for digits > 3 & digits <= 6 is inactive
c      data pc1 / 9.99999896e-1, -1.63090954e-1, 1.06388604e-2/
c      data qc1 / 8.36467414e-2,  3.10155884e-3/
c++   code for digits > 6 & digits <= 11 is inactive
c      data pc1 / 1.0000000000042e0,  -1.8651127631106e-1,
c     *           1.5065663274457e-2, -3.1058074693185e-4/
c      data qc1 / 6.0228833908128e-2,  1.7410300558198e-3,
c     *            .6308617899210e-5/
c++   code for digits > 11 is active
      data pc1 / 9.999999999999999421e-1 ,
     *          -1.994608988261842706e-1 ,
     *           1.761939525434914045e-2 ,
     *          -5.280796513726226960e-4 ,
     *           5.477113856826871660e-6/
      data qc1 / 4.727921120104532689e-2 ,
     *           1.099572150256418851e-3 ,
     *           1.552378852769941331e-5 ,
     *           1.189389014228757184e-7/
c++   end
c
c     Coefficients for C(x), 1.2 < |X| <= 1.6
c++   code for digits <= 2 is inactive
c      data pc2 / 1.3139e0, -5.8827e-2/, qc2 / 4.7324e-1/
c++   code for digits > 2 & digits <= 5 is inactive
c      data pc2 / 9.9790890e-1, -1.5391895e-1, 9.9817933e-3/
c      data qc2 / 8.9878647e-2,  5.6003071e-3/
c++   code for digits > 5 & digits <= 8 is inactive
c      data pc2 / 1.00000440109e0, -1.83413851908e-1,
c     *           1.45776170828e-2,-2.78980705270e-4/
c      data qc2 / 6.33347445637e-2, 2.01245738369e-3,
c     *           4.03949004646e-5/
c++   code for digits > 8 & digits <= 12 is inactive
c      data pc2 / 9.999999966496876e-1, -1.980300987022688e-1,
c     *           1.735518748450023e-2, -5.069442297935788e-4,
c     *           5.059962254678234e-6/
c      data qc2 / 4.871000308997918e-2,  1.188406974004084e-3,
c     *           1.824527635843850e-5,  1.678314257874103e-7/
c++   code for digits > 12 is active
      data pc2 / 1.00000000000111043640e0  ,
     *          -2.07073360335323894245e-1 ,
     *           1.91870279431746926505e-2 ,
     *          -6.71376034694922109230e-4 ,
     *           1.02365435056105864908e-5 ,
     *          -5.68293310121870728343e-8/
      data qc2 / 3.96667496952323433510e-2 ,
     *           7.88905245052359907842e-4 ,
     *           1.01344630866749406081e-5 ,
     *           8.77945377892369265356e-8 ,
     *           4.41701374065009620393e-10/
c++   end
c
c     Coefficients for S(x), |X| <= 1.2
c++   code for digits <= 3 is inactive
c      data ps1 / 5.23677e-1, -4.67900e-2/, qs1 / 8.81622e-2/
c++   code for digits > 3 & digits <= 7 is inactive
c      data ps1 / 5.235987665e-1,-5.837763961e-2, 2.165920196e-3/
c      data qs1 / 6.474944765e-2, 1.713287588e-3/
c++   code for digits > 7 & digits <= 12 is inactive
c      data ps1 / 5.23598775598566e-1, -6.59149581139046e-2,
c     *           3.21501649828293e-3, -4.88704436240178e-5/
c      data qs1 / 5.03546388670085e-2,  1.17835980356588e-3,
c     *           1.37089875826980e-5/
c++   code for digits > 12 is active
      data ps1 / 5.2359877559829887021e-1 ,
     *          -7.0748991514452302596e-2 ,
     *           3.8778212346368287939e-3 ,
     *          -8.4555728435277680591e-5 ,
     *           6.7174846662514086196e-7/
      data qs1 / 4.1122315114238422205e-2 ,
     *           8.1709194215213447204e-4 ,
     *           9.6269087593903403370e-6 ,
     *           5.9528122767840998345e-8/
c++   end
c
c     coefficients for S(x), 1.2 < |X| <= 1.6
c++   code for digits <= 2 is inactive
c      data ps2 / 5.4766e-1, -3.7151e-2/, qs2 / 1.4559e-1/
c++   code for digits > 2 & digits <= 5 is inactive
c      data ps2 / 5.2343994e-1, -5.4828347e-2, 1.9020881e-3/
c      data qs2 / 7.1104704e-2,  2.5596274e-3/
c++   code for digits > 5 & digits <= 9 is inactive
c      data ps2 / 5.23599040498e-1, -6.46593392426e-2,
c     *           3.08030794361e-3, -4.40800854418e-5/
c      data qs2 / 5.27536681685e-2,  1.34311026821e-3,
c     *           1.90476612849e-5/
c++   code for digits > 9 & digits <= 14 is inactive
c      data ps2 / 5.2359877543509178e-1,-7.0149076634833662e-2,
c     *           3.8031581605987038e-3,-8.0964948714408156e-5,
c     *           6.1908080210052772e-7/
c      data qs2 / 4.2268067370395487e-2, 8.7642753831073237e-4,
c     *           1.1088542889789282e-5, 7.8725829545478464e-8/
c++   code for digits > 14 is active
      data ps2 / 5.23598775598344165913e-1 ,
     *          -7.37766914010191323867e-2 ,
     *           4.30730526504366510217e-3 ,
     *          -1.09540023911434994566e-4 ,
     *           1.28531043742724820610e-6 ,
     *          -5.76765815593088804567e-9/
      data qs2 / 3.53398342767472162540e-2 ,
     *           6.18224620195473216538e-4 ,
     *           6.87086265718620117905e-6 ,
     *           5.03090581246612375866e-8 ,
     *           2.05539124458579596075e-10/
c++   end
c
c     coefficients for f(x), 1.6 < |X| <= 1.9
c++   code for digits <= 5 is inactive
c      data pf1 / 3.1803519e-1, 4.2352332e-1/, qf1 / 1.6015403e0/
c++   code for digits > 5 & digits <= 8 is inactive
c      data pf1 / 3.18285252094e-1,  2.02860275713e0,
c     *           1.08108136048e0 /
c      data qf1 / 6.67171548135e0,   4.52997553972e0 /
c++   code for digits > 8 & digits <= 11 is inactive
c      data pf1 / 3.1830646311448e-1,  4.6077249266684e0,
c     *           1.1914578438074e1,   3.5555073665830e0 /
c      data qf1 / 1.4778464938936e1,   4.0902971163705e1,
c     *           1.6130432784819e1 /
c++   code for digits > 11 & digits <= 14 is inactive
c      data pf1 / 3.1830926850490599e-1,  8.0358812280394156e0,
c     *           4.8034065557792487e1,   6.9853426160102065e1,
c     *           1.3530423554038784e1 /
c      data qf1 / 2.5549161843579529e1,   1.5761100558012250e2,
c     *           2.4956199380517229e2,   6.5563064008391554e1 /
c++   code for digits > 14 is active
      data pf1 / 3.1830975293580985290e-1 ,
     *           1.2226000551672961219e1  ,
     *           1.2924886131901657025e2  ,
     *           4.3886367156695547655e2  ,
     *           4.1466722177958961672e2  ,
     *           5.6771463664185116454e1 /
      data qf1 / 3.8713003365583442831e1  ,
     *           4.1674359830705629745e2  ,
     *           1.4740030733966610568e3  ,
     *           1.5371675584895759916e3  ,
     *           2.9113088788847831515e2 /
c++   end
c
c     coefficients for f(x), 1.9 < |X| <= 2.4
c++   code for digits <= 5 is inactive
c      data pf2 / 3.1825112e-1, 5.8395951e-1/, qf2 / 2.1243944e0 /
c++   code for digits > 5 & digits <= 8 is inactive
c      data pf2 / 3.1830699932e-1, 2.9993457087e0, 2.3956340010e0/
c      data qf2 / 9.7254517756e0,  9.4814077696e0 /
c++   code for digits > 8 & digits <= 11 is inactive
c      data pf2 / 3.1830963944521e-1,  7.0770431878327e0,
c     *           2.8756083262903e1,   1.3583685742326e1 /
c      data qf2 / 2.2536994405207e1,   9.6127568469278e1,
c     *           5.7407028004031e1 /
c++   code for digits > 11 & digits <= 14 is inactive
c      data pf2 / 3.183098568640159e-1,  1.265129469683175e1,
c     *           1.219467616498339e2,   2.910033655512762e2,
c     *           9.278397828631516e1/
c      data qf2 / 4.004915302781009e1,   3.942059697951583e2,
c     *           1.001368403495691e3,   4.142676224222433e2/
c++   code for digits > 14 is active
      data pf2 / 3.183098818220169217e-1 ,
     *           1.958839410219691002e1  ,
     *           3.398371349269842400e2  ,
     *           1.930076407867157531e3  ,
     *           3.091451615744296552e3  ,
     *           7.177032493651399590e2 /
      data qf2 / 6.184271381728873709e1  ,
     *           1.085350675006501251e3  ,
     *           6.337471558511437898e3  ,
     *           1.093342489888087888e4  ,
     *           3.361216991805511494e3 /
c++   end
c
c     coefficients for f(x), 2.4 < |X|
c++   code for digits <= 3 is inactive
c      data pf3 /-8.97969e-2/
c++   code for digits > 3 & digits <= 6 is inactive
c      data pf3 / -9.67122165e-2, -3.73565920e-1/
c      data qf3 / 7.29466572e0 /
c++   code for digits > 6 & digits <= 9 is inactive
c      data pf3 /-9.67541443648e-2, -2.26566293818e0,
c      *         -3.53429821084e0 /
c      data qf3 / 2.69596939977e1,   9.72883957469e1 /
c++   code for digits > 9 & digits <= 11 is inactive
c      data pf3 /-9.6754596389025e-2, -5.5254943840897e0,
c     *          -5.8606282086171e1,  -5.2235560918394e1 /
c      data qf3 / 6.0654483020979e1,   7.8528841711294e2,
c     *           1.8592498578831e3 /
c++   code for digits > 11 & digits <= 13 is inactive
c      data pf3 /-9.675460316952504e-2, -1.023876428129288e1,
c     *          -2.712579634037998e2,  -1.766119345282127e3,
c     *          -1.043464426656267e3 /
c      data qf3 / 1.093682244053459e2,   3.155843461920557e3,
c     *           2.625634316204420e4,   4.578252057246393e4 /
c++   code for digits > 13 & digits <= 15 is inactive
c      data pf3 /-9.67546032967090380e-2,-1.64797712841245767e1,
c     *          -8.16343401784374598e2, -1.34922028171857248e4,
c     *          -6.13547113614699772e4, -2.61294753225141779e4/
c      data qf3 / 1.73871690673649114e2,  9.01827596231524147e3,
c     *           1.65946462621853184e5,  1.00105478900791339e6,
c     *           1.37012364817225972e6 /
c++   code for digits > 15 is active
      data pf3 /-9.675460329952532343e-2 ,
     *          -2.431275407194161683e1  ,
     *          -1.947621998306889176e3  ,
     *          -6.059852197160773639e4  ,
     *          -7.076806952837779823e5  ,
     *          -2.417656749061154155e6  ,
     *          -7.834914590078317336e5 /
      data qf3 / 2.548289012949732752e2  ,
     *           2.099761536857815105e4  ,
     *           6.924122509827708985e5  ,
     *           9.178823229918143780e6  ,
     *           4.292733255630186679e7  ,
     *           4.803294784260528342e7 /
c++   end
c
c     coefficients for g(x), 1.6 < |X| <= 1.9
c++   code for digits <= 4 is inactive
c      data pg1 / 1.007011e-1, 1.457780e-1/, qg1 / 2.700253e0 /
c++   code for digits > 4 & digits <= 7 is inactive
c      data pg1 / 1.012500483e-1, 7.735207446e-1, 3.878282770e-1/
c      data qg1 / 9.101956178e0,  1.002234185e1 /
c++   code for digits > 7 & digits <= 10 is inactive
c      data pg1 / 1.013095436817e-1,  1.731937984173e0,
c     *           5.036588245265e0,   1.290707246507e0 /
c      data qg1 / 1.860077430076e1,   6.901951935725e1,
c     *           4.308918659989e1 /
c++   code for digits > 10 & digits <= 13 is inactive
c      data pg1 / 1.013188096509180e-1,  2.966220554725899e0,
c     *           2.015435299505393e1,   3.155605679387908e1,
c     *           4.916012830646366e0 /
c      data qg1 / 3.079178736724045e1,   2.362874318980473e2,
c     *           4.953861258248338e2,   2.026144493403599e2 /
c++   code for digits > 13 is active
      data pg1 / 1.013206188102747985e-1 ,
     *           4.445338275505123778e0  ,
     *           5.311228134809894481e1  ,
     *           1.991828186789025318e2  ,
     *           1.962320379716626191e2  ,
     *           2.054214324985006303e1 /
      data qg1 / 4.539250196736893605e1  ,
     *           5.835905757164290666e2  ,
     *           2.544731331818221034e3  ,
     *           3.481121478565452837e3  ,
     *           1.013794833960028555e3 /
c++   end
c
c     coefficients for g(x), 1.9 < |X| <= 2.4
c++   code for digits <= 4 is inactive
c      data pg2 / 1.011711e-1,  2.239630e-1/, qg2 / 3.609237e0 /
c++   code for digits > 4 & digits <= 7 is inactive
c      data pg2 / 1.013115463e-1,  1.182021191e0,  9.886315969e-1/
c      data qg2 / 1.317219285e1,   2.101104994e1 /
c++   code for digits > 7 & digits <= 10 is inactive
c      data pg2 / 1.013202025653e-1,  2.690767013770e0,
c     *           1.283624749271e1,   5.791337587723e0 /
c      data qg2 / 2.807457005500e1,   1.598704313522e2,
c     *           1.525630385045e2 /
c++   code for digits > 10 & digits <= 13 is inactive
c      data pg2 / 1.013210509409046e-1,  4.682769769757399e0,
c     *           5.241351613346472e1,   1.411735944550041e2,
c     *           4.019756012788710e1 /
c      data qg2 / 4.773652966704634e1,   5.802036967947208e2,
c     *           1.947179327244406e3,   1.266041236960445e3 /
c++   code for digits > 13 is active
      data pg2 / 1.01321161761804586e-1 ,
     *           7.11205001789782823e0  ,
     *           1.40959617911315524e2  ,
     *           9.08311749529593938e2  ,
     *           1.59268006085353864e3  ,
     *           3.13330163068755950e2 /
      data qg2 / 7.17128596939302198e1  ,
     *           1.49051922797329229e3  ,
     *           1.06729678030580897e4  ,
     *           2.41315567213369742e4  ,
     *           1.15149832376260604e4 /
c++   end
c
c     coefficients for g(x), 2.4 < |X|
c++   code for digits <= 3 is inactive
c      data pg3 /-1.3549e-1/
c++   code for digits > 3 & digits <= 5 is inactive
c      data pg3 /-1.5382824e-1, -6.4547464e-1/, qg3 / 1.0290328e1/
c++   code for digits > 5 & digits <= 8 is inactive
c      data pg3 /-1.5398760302e-1, -4.2772857997e0,
c     *          -6.5940181141e0 /
c      data qg3 / 3.4149986477e1,   1.7071708816e2 /
c++   code for digits > 8 & digits <= 10 is inactive
c      data pg3 /-1.539896971616e-1, -1.024638314446e1,
c     *          -1.252507402120e2,  -1.029189676144e2 /
c      data qg3 / 7.292229303754e1,   1.186528673248e3,
c     *           3.844430908476e3 /
c++   code for digits > 10 & digits <= 12 is inactive
c      data pg3 /-1.53989733057971e-1, -1.86483223831639e1,
c     *          -5.66882778026550e2,  -4.16714647017489e3,
c     *          -2.14678074364341e3 /
c      data qg3 / 1.27484298075273e2,   4.40258858159927e3,
c     *           4.57583830694684e4,   1.08207883281275e5 /
c++   code for digits = 13 is inactive
c      data pg3 /-1.539897338019247e-1, -2.959078231855258e1,
c     *          -1.661867087183632e3,  -3.112796454920657e4,
c     *          -1.573536286819766e5,  -5.574884113746041e4 /
c      data qg3 / 1.985439813544440e2,   1.196693134508007e4,
c     *           2.625573864512749e5,   1.969055829311119e6,
c     *           3.629081333313312e6 /
c++   code for digits > 13 is active
      data pg3 /-1.53989733819769316e-1 ,
     *          -4.31710157823357568e1  ,
     *          -3.87754141746378493e3  ,
     *          -1.35678867813756347e5  ,
     *          -1.77758950838029676e6  ,
     *          -6.66907061668636416e6  ,
     *          -1.72590224654836845e6 /
      data qg3 / 2.86733194975899483e2  ,
     *           2.69183180396242536e4  ,
     *           1.02878693056687506e6  ,
     *           1.62095600500231646e7  ,
     *           9.38695862531635179e7  ,
     *           1.40622441123580005e8 /
c++   end
c     ------------------------------------------------------------------
      if (bigx .lt. 0.0e0) then
         bigx = 1.0e0 / R1MACH(4)
         largef = rpi / R1MACH(1)
         largeg = (rpi * largef) ** (1.0e0 / 3.0e0)
         largex = 1.0e0/sqrt(sqrt(R1MACH(1)))
      end if
      if (x .ne. xsave) then
         havec = .false.
         havef = .false.
         haveg = .false.
         haves = .false.
      end if
      ax = abs(x)
      if (ax .le. 1.6e0) then
         x4 = ax**4
         if (needc(mode) .and. .not. havec) then
            if (ax .le. 1.2e0) then
c++             code for digits <= 3 is inactive
c               c = x * (pc1(1)*x4+pc1(0)) / (qc1(1)*x4+1.0e0)
c++             code for digits > 3 & digits <= 6 is inactive
c               c = x * ((pc1(2)*x4+pc1(1))*x4+pc1(0))
c     1               / ((qc1(2)*x4+qc1(1))*x4+1.0e0)
c++             code for digits > 6 & digits <= 11 is inactive
c               c = x * (((pc1(3)*x4+pc1(2))*x4+pc1(1))*x4+pc1(0))
c     1               / (((qc1(3)*x4+qc1(2))*x4+qc1(1))*x4+1.0e0)
c++             code for digits > 11 is active
               c = x * ((((pc1(4)*x4+pc1(3))*x4+pc1(2))*x4+pc1(1))*x4+
     1                     pc1(0))
     2           / ((((qc1(4)*x4+qc1(3))*x4+qc1(2))*x4+qc1(1))*x4+1.0e0)
c++             end
            else
c++             code for digits <= 2 is inactive
c               c = x * (pc2(1)*x4+pc2(0)) / (qc2(1)*x4+1.0e0)
c++             code for digits > 2 & digits <= 5 is inactive
c               c = x * ((pc2(2)*x4+pc2(1))*x4+pc2(0))
c     1               / ((qc2(2)*x4+qc2(1))*x4+1.0e0)
c++             code for digits > 5 & digits <= 8 is inactive
c               c = x * (((pc2(3)*x4+pc2(2))*x4+pc2(1))*x4+pc2(0))
c     1               / (((qc2(3)*x4+qc2(2))*x4+qc2(1))*x4+1.0e0)
c++             code for digits > 8 & digits <= 12 is inactive
c               c = x * ((((pc2(4)*x4+pc2(3))*x4+pc2(2))*x4+pc2(1))*x4+
c     1                   pc2(0))
c     2               / ((((qc2(4)*x4+qc2(3))*x4+qc2(2))*x4+qc2(1))*x4+
c     3                   1.0e0)
c++             code for digits > 12 is active
               c = x * (((((pc2(5)*x4+pc2(4))*x4+pc2(3))*x4+pc2(2))*x4+
     1                     pc2(1))*x4+pc2(0))
     2               / (((((qc2(5)*x4+qc2(4))*x4+qc2(3))*x4+qc2(2))*x4+
     3                   qc2(1))*x4+1.0e0)
c++             end
            end if
            havec = .true.
         end if
         if (needs(mode) .and. .not. haves) then
            if (ax .le. 1.2e0) then
c++             code for digits <= 3 is inactive
c               s = x**3*(ps1(1)*x4+ps1(0)) / (qs1(1)*x4+1.0e0)
c++             code for digits > 3 & digits <= 7 is inactive
c               s = x**3*((ps1(2)*x4+ps1(1))*x4+ps1(0))
c     1                / ((qs1(2)*x4+qs1(1))*x4+1.0e0)
c++             code for digits > 7 & digits <= 12 is inactive
c               s = x**3*(((ps1(3)*x4+ps1(2))*x4+ps1(1))*x4+ps1(0))
c     1                / (((qs1(3)*x4+qs1(2))*x4+qs1(1))*x4+1.0e0)
c++             code for digits > 12 is active
               s = x**3*((((ps1(4)*x4+ps1(3))*x4+ps1(2))*x4+ps1(1))*x4+
     1                      ps1(0))
     2           / ((((qs1(4)*x4+qs1(3))*x4+qs1(2))*x4+qs1(1))*x4+1.0e0)
c++             end
            else
c++             code for digits <= 2 is inactive
c               s = x**3*(ps2(1)*x4+ps2(0)) / (qs2(1)*x4+1.0e0)
c++             code for digits > 2 & digits <= 5 is inactive
c               s = x**3*((ps2(2)*x4+ps2(1))*x4+ps2(0))
c     1              /   ((qs2(2)*x4+qs2(1))*x4+1.0e0)
c++             code for digits > 5 & digits <= 9 is inactive
c               s = x**3*(((ps2(3)*x4+ps2(2))*x4+ps2(1))*x4+ps2(0))
c     1              /   (((qs2(3)*x4+qs2(2))*x4+qs2(1))*x4+1.0e0)
c++             code for digits > 9 & digits <= 14 is inactive
c               s = x**3*((((ps2(4)*x4+ps2(3))*x4+ps2(2))*x4+ps2(1))*x4+
c     1                      ps2(0))
c     2              /   ((((qs2(4)*x4+qs2(3))*x4+qs2(2))*x4+qs2(1))*x4+
c     3                      1.0e0)
c++             code for digits > 14 is active
               s = x**3*(((((ps2(5)*x4+ps2(4))*x4+ps2(3))*x4+ps2(2))*x4+
     1                      ps2(1))*x4+ps2(0))
     2              /   (((((qs2(5)*x4+qs2(4))*x4+qs2(3))*x4+qs2(2))*x4+
     3                      qs2(1))*x4+1.0e0)
c++             end
            end if
            haves = .true.
         end if
         if ((needf(mode) .or. needg(mode)) .and. .not. havef) then
            cx = scspxx (ax)
            sx = ssnpxx (ax)
            f = (0.5e0 - s) * cx - (0.5e0 - c) * sx
            g = (0.5e0 - c) * cx + (0.5e0 - s) * sx
            havef = .true.
         end if
      else
         if (ax .le. largex) then
            x4 = (1.0e0 / ax) ** 4
            wantf = needf(mode+4) .and. .not. havef
            if (wantf) then
               if (ax .le. 1.9e0) then
c++                code for digits <= 5 is inactive
c                  f = (pf1(1)*x4+pf1(0)) / ((qf1(1)*x4+1.0e0) * ax)
c++                code for digits > 5 & digits <= 8 is inactive
c                  f = ((pf1(2)*x4+pf1(1))*x4+pf1(0))
c     1             / (((qf1(2)*x4+qf1(1))*x4+1.0e0) * ax)
c++                code for digits > 8 & digits <= 11 is inactive
c                  f = (((pf1(3)*x4+pf1(2))*x4+pf1(1))*x4+pf1(0))
c     1             / ((((qf1(3)*x4+qf1(2))*x4+qf1(1))*x4+1.0e0) * ax)
c++                code for digits > 11 & digits <= 14 is inactive
c                  f = ((((pf1(4)*x4+pf1(3))*x4+pf1(2))*x4+pf1(1))*x4+
c     1                    pf1(0))
c     2             / (((((qf1(4)*x4+qf1(3))*x4+qf1(2))*x4+qf1(1))*x4+
c     3                    1.0e0) * ax)
c++                code for digits > 14 is active
                  f = (((((pf1(5)*x4+pf1(4))*x4+pf1(3))*x4+pf1(2))*x4+
     1                    pf1(1))*x4+pf1(0))
     2             / ((((((qf1(5)*x4+qf1(4))*x4+qf1(3))*x4+qf1(2))*x4+
     3                    qf1(1))*x4+1.0e0) * ax)
c++                end
               else if (ax .le. 2.4) then
c++                code for digits <= 5 is inactive
c                  f = (pf2(1)*x4+pf2(0)) / ((qf2(1))*x4+1.0e0) * ax)
c++                code for digits > 5 & digits <= 8 is inactive
c                  f = ((pf2(2)*x4+pf2(1))*x4+pf2(0))
c     1             / (((qf2(2)*x4+qf2(1))*x4+1.0e0) * ax)
c++                code for digits > 8 & digits <= 11 is inactive
c                  f = (((pf2(3)*x4+pf2(2))*x4+pf2(1))*x4+pf2(0))
c     1             / ((((qf2(3)*x4+qf2(2))*x4+qf2(1))*x4+1.0e0) * ax)
c++                code for digits > 11 & digits <= 14 is inactive
c                  f = ((((pf2(4)*x4+pf2(3))*x4+pf2(2))*x4+pf2(1))*x4+
c     1                    pf2(0))
c     2             / (((((qf2(4)*x4+qf2(3))*x4+qf2(2))*x4+qf2(1))*x4+
c     3                    1.0e0) * ax)
c++                code for digits > 14 is active
                  f = (((((pf2(5)*x4+pf2(4))*x4+pf2(3))*x4+pf2(2))*x4+
     1                    pf2(1))*x4+pf2(0))
     2             / ((((((qf2(5)*x4+qf2(4))*x4+qf2(3))*x4+qf2(2))*x4+
     3                    qf2(1))*x4+1.0e0) * ax)
c++                end
               else
c++                code for digits <= 3 is inactive
c                  f = (rpi + x4*pf3(0)) / ax
c++                code for digits > 3 & digits <= 6 is inactive
c                  f = (rpi + x4*(pf3(1)*x4+pf3(0)) / (qf3(1)*x4+1.0e0))
c                      / ax
c++                code for digits > 6 & digits <= 9 is inactive
c                  f = (rpi +
c     1              x4*((pf3(2)*x4+pf3(1))*x4+pf3(0))
c     2            /    ((qf3(2)*x4+qf3(1))*x4+1.0e0)) / ax
c++                code for digits > 9 & digits <= 11 is inactive
c                  f = (rpi +
c     1              x4*(((pf3(3)*x4+pf3(2))*x4+pf3(1))*x4+pf3(0))
c     2            /    (((qf3(3)*x4+qf3(2))*x4+qf3(1))*x4+1.0e0)) / ax
c++                code for digits > 11 & digits <= 13 is inactive
c                  f = (rpi +
c     1              x4*((((pf3(4)*x4+pf3(3))*x4+pf3(2))*x4+pf3(1))*x4+
c     2                   pf3(0))
c     3            /    ((((qf3(4)*x4+qf3(3))*x4+qf3(2))*x4+qf3(1))*x4+
c     4                   1.0e0)) / ax
c++                code for digits > 13 & digits <= 15 is inactive
c                  f = (rpi +
c     1              x4*(((((pf3(5)*x4+pf3(4))*x4+pf3(3))*x4+pf3(2))*x4+
c     2                   pf3(1))*x4+pf3(0))
c     3            /    (((((qf3(5)*x4+qf3(4))*x4+qf3(3))*x4+qf3(2))*x4+
c     4                   qf3(1))*x4+1.0e0)) / ax
c++                code for digits > 15 is active
                  f = (rpi +
     1              x4*((((((pf3(6)*x4+pf3(5))*x4+pf3(4))*x4+pf3(3))*x4+
     2                   pf3(2))*x4+pf3(1))*x4+pf3(0))
     3            /    ((((((qf3(6)*x4+qf3(5))*x4+qf3(4))*x4+qf3(3))*x4+
     4                   qf3(2))*x4+qf3(1))*x4+1.0e0)) / ax
c++                end
               end if
               havef = .true.
            end if
            wantg = needg(mode+4) .and. .not. haveg
            if (wantg) then
               if (ax .le. 1.9e0) then
c++                code for digits <=4 is inactive
c                  g = (pg1(1)*x4+pg1(0)) / ((qg1(1)*x4+1.0e0) * ax**3)
c++                code for digits > 4 & digits <= 7 is inactive
c                  g = ((pg1(2)*x4+pg1(1))*x4+pg1(0))
c     1             / (((qg1(2)*x4+qg1(1))*x4+1.0e0) * ax**3)
c++                code for digits > 7 & digits <= 10 is inactive
c                  g = (((pg1(3)*x4+pg1(2))*x4+pg1(1))*x4+pg1(0))
c     1             / ((((qg1(3)*x4+qg1(2))*x4+qg1(1))*x4+1.0e0) *ax**3)
c++                code for digits > 10 & digits <= 13 is inactive
c                  g = ((((pg1(4)*x4+pg1(3))*x4+pg1(2))*x4+pg1(1))*x4+
c     1                    pg1(0))
c     2             / (((((qg1(4)*x4+qg1(3))*x4+qg1(2))*x4+qg1(1))*x4+
c     3                    1.0e0) * ax**3)
c++                code for digits > 13 is active
                  g = (((((pg1(5)*x4+pg1(4))*x4+pg1(3))*x4+pg1(2))*x4+
     1                    pg1(1))*x4+pg1(0))
     2             / ((((((qg1(5)*x4+qg1(4))*x4+qg1(3))*x4+qg1(2))*x4+
     3                    qg1(1))*x4+1.0e0) * ax**3)
c++                end
               else if (ax .le. 2.4e0) then
c++                code for digits <=4 is inactive
c                  g = (pg2(1)*x4+pg2(0)) / ((qg2(1)*x4+1.0e0) * ax**3)
c++                code for digits > 4 & digits <= 7 is inactive
c                  g = ((pg2(2)*x4+pg2(1))*x4+pg2(0))
c     1             / (((qg2(2)*x4+qg2(1))*x4+1.0e0) * ax**3)
c++                code for digits > 7 & digits <= 10 is inactive
c                  g = (((pg2(3)*x4+pg2(2))*x4+pg2(1))*x4+pg2(0))
c     1             / ((((qg2(3)*x4+qg2(2))*x4+qg2(1))*x4+1.0e0) *ax**3)
c++                code for digits > 10 & digits <= 13 is inactive
c                  g = ((((pg2(4)*x4+pg2(3))*x4+pg2(2))*x4+pg2(1))*x4+
c     1                    pg2(0))
c     2             / (((((qg2(4)*x4+qg2(3))*x4+qg2(2))*x4+qg2(1))*x4+
c     3                    1.0e0) * ax**3)
c++                code for digits > 13 is active
                  g = (((((pg2(5)*x4+pg2(4))*x4+pg2(3))*x4+pg2(2))*x4+
     1                     pg2(1))*x4+pg2(0))
     2             / ((((((qg2(5)*x4+qg2(4))*x4+qg2(3))*x4+qg2(2))*x4+
     3                    qg2(1))*x4+1.0e0) * ax**3)
c++                end
               else
c++                code for digits <=3 is inactive
c                  g = (rpisq + x4*pg3(0)) / ax**3
c++                code for digits > 3 & digits <= 5 is inactive
c                  g = (rpisq + x4*(pg3(1)*x4+pg3(0))
c     1            /    (qg3(1)*x4+1.0e0)) / ax**3
c++                code for digits > 5 & digits <= 8 is inactive
c                  g = (rpisq + x4*((pg3(2)*x4+pg3(1))*x4+pg3(0))
c     1            /    ((qg3(2)*x4+qg3(1))*x4+1.0e0)) / ax**3
c++                code for digits > 8 & digits <= 10 is inactive
c                  g = (rpisq +
c     1              x4*(((pg3(3)*x4+pg3(2))*x4+pg3(1))*x4+pg3(0))
c     2            /    (((qg3(3)*x4+qg3(2))*x4+qg3(1))*x4+1.0e0))
c     3            / ax**3
c++                code for digits > 10 & digits <= 12 is inactive
c                  g = (rpisq +
c     1              x4*((((pg3(4)*x4+pg3(3))*x4+pg3(2))*x4+pg3(1))*x4+
c     2                     pg3(0))
c     3            /    ((((qg3(4)*x4+qg3(3))*x4+qg3(2))*x4+qg3(1))*x4+
c     4                     1.0e0)) / ax**3
c++                code for digits = 13 is inactive
c                  g = (rpisq +
c     1              x4*(((((pg3(5)*x4+pg3(4))*x4+pg3(3))*x4+pg3(2))*x4+
c     2                      pg3(1))*x4+pg3(0))
c     3            /    (((((qg3(5)*x4+qg3(4))*x4+qg3(3))*x4+qg3(2))*x4+
c     4                      qg3(1))*x4+1.0e0)) / ax**3
c++                code for digits > 13 is active
                  g = (rpisq +
     1              x4*((((((pg3(6)*x4+pg3(5))*x4+pg3(4))*x4+pg3(3))*x4+
     2                   pg3(2))*x4+pg3(1))*x4+pg3(0))
     3            /    ((((((qg3(6)*x4+qg3(5))*x4+qg3(4))*x4+qg3(3))*x4+
     4                   qg3(2))*x4+qg3(1))*x4+1.0e0)) / ax**3
c++                end
               end if
               haveg = .true.
            end if
         else
            wantf = needf(mode)
            if (wantf) then
               if (x .le. largef) then
                  f = rpi / ax
               else
                  f = 0.0e0
               end if
            end if
            wantg = needg(mode)
            if (wantg) then
               if (x .le. largeg) then
                  g = rpisq / ax**3
               else
                  g = 0.0e0
               end if
            end if
         end if
         wantc = (needc(mode+4) .or. needs(mode+4)) .and. .not. havec
         if (wantc .or. x.lt.0.0e0) then
            cx = scspxx (ax)
            sx = ssnpxx (ax)
            if (wantc) then
               c = 0.5e0 + f*sx - g*cx
               s = 0.5e0 - f*cx - g*sx
               if (x .lt. 0.0) then
                  c = -c
                  s = -s
               end if
               havec = .true.
            end if
            if (x .lt. 0.0) then
c              We COULD do the following before the preceeding, and then
c              not put in a test in the preceeding for x .lt. 0, but
c              even though the results are mathematically identical, we
c              would have some cancellation above if we did so.
               if (wantg) g = cx + sx - g
               if (wantf) f = cx - sx - f
            end if
          end if
      end if
      xsave = x
      go to (1, 2, 3, 4), MODE
    1    SFREN1 = c
         return
    2    SFREN1 = s
         return
    3    SFREN1 = f
         return
    4    SFREN1 = g
         return
      end


      SUBROUTINE DNORM(X,MAG)
C
C     DOUBLE PRECISION NORMALIZATION
C
      DOUBLE PRECISION        X(3)     ,MAG      ,A
C
      MAG= 0.D0
      A= X(1)*X(1) + X(2)*X(2) +X(3)*X(3)
      IF (A .GT. 0.D0) MAG= DSQRT(A)
      IF(MAG .EQ. 0.0D0) RETURN
      X(1) = X(1) / MAG
      X(2) = X(2) / MAG
      X(3) = X(3) / MAG
      RETURN
      END


  ! real(real_kind) :: donor(nx,ny,nz), upwind(nx,ny,nz), downwind(nx,ny,nz)
  ! integer :: donor(5,6,7), upwind(5,6,7), downwind(5,6,7)
  ! integer :: donor(5,6,7) ! , upwind(5,6,7)
  ! real(4)    :: donor_variability(5,6,7)
    real(4)    :: result(5,6,7)
    real(4)    :: upwind(5,6,7)
    real(4)    :: downwind(5,6,7)

  ! upwind = donor - upwind
  ! upwind = donor

  ! upwind = sign(donor_variability,downwind) * min(abs(upwind), abs(downwind), epsilon3*abs(upwind) + epsilon4*abs(downwind))
  ! upwind = sign(upwind,downwind) * min(abs(upwind),abs(downwind),abs(upwind)+abs(downwind))
  ! upwind = min(abs(upwind),abs(downwind))
  ! upwind = min(upwind,downwind)
    result = min(abs(upwind),downwind)
end


      subroutine exp1(l,u,n)
C     Input: n is number of iterations
C     Output: l,u are such that
C       l(1)/l(2) < exp(1) < u(1)/u(2)
C
Cf2py integer*4 :: n = 1
Cf2py intent(out) l,u
      integer*4 n,i
      real*8 l(2),u(2),t,t1,t2,t3,t4
      l(2) = 1
      l(1) = 0
      u(2) = 0
      u(1) = 1
      do 10 i=0,n
         t1 = 4 + 32*(1+i)*i
         t2 = 11 + (40+32*i)*i
         t3 = 3 + (24+32*i)*i
         t4 = 8 + 32*(1+i)*i
         t = u(1)
         u(1) = l(1)*t1 + t*t2
         l(1) = l(1)*t3 + t*t4
         t = u(2)
         u(2) = l(2)*t1 + t*t2
         l(2) = l(2)*t3 + t*t4
 10   continue
      end


c=======================================================================
c
c     subroutine CORM
c
c     Empirical Correlation matrix and mean vector:
c
c                        cov(i,j)
c     corr(i,j) = -----------------------, cov is the empirical covariance
c                 sqrt[cov(i,i)*cov(j,j)]
c
c                  n
c              1  ---
c     rho(j) = -  \   X(i,j) for j = 1,...,p
c              n  /
c                 ---
c                 i=1
c
c-----------------------------------------------------------------------
      SUBROUTINE corm ( n, p, X, dwork, corr, info)
c-----------------------------------------------------------------------
c
c     INPUT
c            n      : number of values (n > 1)                   integer
c            p      : number of asset(s) (n >= 1)                integer
c            X      : value(s) (n*p)                              double
c
c     WORKSPACE
c            dwork  : vector ( p*(n + p + 2) )                    double
c
c     OUTPUT
c            corr   : empirical correlation matrix (p*p)          double
c            info   : diagnostic argument                        integer
c
c     CALL
c            MCM    : mean of each column of a vectorized full matrix
c            EMPCOV : empiric covariance matrix
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, p, info
      DOUBLE PRECISION X(n, *), corr(p,*)
c
c     workspaces
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER pdwork, pcov, psqr, i, j, kij, kii, pdrho
      DOUBLE PRECISION val, myzero
      PARAMETER ( myzero = 1.E-30 )
c
c     external subroutines
      EXTERNAL MCM, empcov
c
c     intrinsic functions
      INTRINSIC sqrt
c
c-----------------------------------------------------------------------
c
c     initialization
      info = 0
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdrho = 1
c     prho: pointer ont the mean return rho, so p
      pdwork = pdrho + p
c     pdwork : pointer for relatives rents, so ( n*p ) more
      pcov = pdwork + ( n*p)
c     pcov   : pointer for vectorized matrix, so ( p*p ) more
      psqr = pcov + ( p*p )
c     psqr   : pointer for square root of diagonal, so ( p ) more
c     pdnext = psqr + ( p )
c     pdnext: pointer of the next dwork array
c
c     Total size of dwork array = p*(n + p + 1)
c
c-----------------------------------------------------------------------
c
c     mean returns
      CALL MCM ( n, p, X, dwork(pdrho))
c
c     empirical covariance matrix
      CALL empcov ( n, p, X, dwork(pdrho), dwork(pdwork), dwork(pcov),
     &  info )
      IF (info .LT. 0) RETURN
c
c     standard deviation:  square root of Diag(cov)
      DO i = 1,p
         kii = pcov + (i - 1)*(p + 1)
         val = dwork(kii)
         IF ( val .gt. myzero ) THEN
            dwork(psqr+i-1)= sqrt(val)
         ELSE
            info = -5
            RETURN
         ENDIF
      ENDDO
c
c     empirical correlation matrix
      corr(1,1) = 1.0
      DO j = 2,p
         DO i = 1,j
            kij       = pcov + (i - 1)*p + (j - 1)
            corr(i,j) = dwork(kij)/( dwork(psqr+i-1)*dwork(psqr+j-1) )
            IF ( i .ne. j ) corr(j, i) = corr(i, j)
         ENDDO
         corr(j,j) = 1.0
      ENDDO
c
      RETURN
      END


************************************************************************
*
*     Subroutine FACINV                       Called by: MATCALC, MATINV
*
*     factor and invert matrix A by gaussian elimination.
*
*     Based on Linpack routines DGECO and DGEDI (versions dated
*     08/14/78; Cleve Moler, U. of New Mexico, Argonne National Lab);
*     modified to eliminate computation of determinant.
*
*     local vars
*     ----------
*     IPVT    pivot indices
*     WORK    work space whose contents are usually unimportant. If A
*             is close to a singular matrix, then WORK is an approximate
*             null vector in the sense that norm(A*WORK) =
*             rcond*norm(A)*norm(WORK)
*
*     subroutine arguments
*     --------------------
*     A       matrix to be factored and inverted
*     LDA     leading dimension of A
*     NPAR    the order A
*
************************************************************************
      SUBROUTINE FACINV(A,LDA,NPAR)
*
*     dimensional parameters
*
      INCLUDE 'fmodules.inc'
*
*     subroutine arguments
*
      INTEGER*4 LDA,NPAR
      DOUBLE PRECISION A(LDA,*)
*
*     local vars
*
      INTEGER*4 I,J,K,KB,IPVT(MAXPARMS+1)
      DOUBLE PRECISION ANORM,EK,S,SM,T,WK,WKM,YNORM
      DOUBLE PRECISION WORK(MAXPARMS+1)
*
*     function declarations
*
      DOUBLE PRECISION DASUM,DDOT
*
*     compute 1-norm of A
*
      ANORM = 0.D0
      DO 10 I=1,NPAR
         ANORM = DMAX1(ANORM,DASUM(NPAR,A(1,I)))
   10 CONTINUE
*
*     factor
*
      CALL DGEFA(A,LDA,NPAR,IPVT)
*
*     rcond = 1/(norm(A)*(estimate of norm(inverse(A)))) .
*     estimate = norm(work)/norm(y) where a*work=y and trans(a)*y=e.
*     trans(a) is the transpose of A .  The components of e are chosen
*     to cause maximum local growth in the elements of w where
*     trans(u)*w = e .  The vectors are frequently rescaled to avoid
*     overflow.
*
*     solve trans(u)*w = e
*
      EK = 1.D0
      DO 20 I=1,NPAR
         WORK(I) = 0.D0
 20   CONTINUE

      DO 50 K=1,NPAR
         IF (WORK(K) .NE. 0.D0) EK = DSIGN(EK,-WORK(K))
         IF (DABS(EK-WORK(K)) .GT. DABS(A(K,K))) THEN
            S = DABS(A(K,K))/DABS(EK-WORK(K))
            CALL DSCAL(NPAR,S,WORK)
            EK = S*EK
         ENDIF
         WK = EK - WORK(K)
         WKM = -EK - WORK(K)
         S = DABS(WK)
         SM = DABS(WKM)
         IF (A(K,K) .NE. 0.D0) THEN
            WK = WK/A(K,K)
            WKM = WKM/A(K,K)
         ELSE
            WK = 1.D0
            WKM = 1.D0
         ENDIF

         DO 30 I=K+1,NPAR
            SM = SM + DABS(WORK(I)+WKM*A(K,I))
            WORK(I) = WORK(I) + WK*A(K,I)
            S = S + DABS(WORK(I))
 30      CONTINUE
         IF (S .LT. SM) THEN
            T = WKM - WK
            WK = WKM
            DO 40 I=K+1,NPAR
               WORK(I) = WORK(I) + T*A(K,I)
 40         CONTINUE
         ENDIF

         WORK(K) = WK
 50   CONTINUE

      S = 1.D0/DASUM(NPAR,WORK)
      CALL DSCAL(NPAR,S,WORK)
*
*     solve trans(l)*y = w
*
      DO 60 KB=1,NPAR
         K = NPAR + 1 - KB
         IF (K .LT. NPAR)
     &      WORK(K) = WORK(K) + DDOT(NPAR-K,A(K+1,K),WORK(K+1))
         IF (DABS(WORK(K)) .GT. 1.D0) THEN
            S = 1.D0/DABS(WORK(K))
            CALL DSCAL(NPAR,S,WORK)
         ENDIF
         T = WORK(IPVT(K))
         WORK(IPVT(K)) = WORK(K)
         WORK(K) = T
 60   CONTINUE
      S = 1.D0/DASUM(NPAR,WORK)
      CALL DSCAL(NPAR,S,WORK)
      YNORM = 1.D0
*
*     solve l*v = y
*
      DO 70 K=1,NPAR
         T = WORK(IPVT(K))
         WORK(IPVT(K)) = WORK(K)
         WORK(K) = T
         IF (K .LT. NPAR) CALL DAXPY(NPAR-K,T,A(K+1,K),WORK(K+1))
         IF (DABS(WORK(K)) .GT. 1.D0) THEN
            S = 1.D0/DABS(WORK(K))
            CALL DSCAL(NPAR,S,WORK)
            YNORM = S*YNORM
         ENDIF
 70   CONTINUE
      S = 1.D0/DASUM(NPAR,WORK)
      CALL DSCAL(NPAR,S,WORK)
      YNORM = S*YNORM
*
*     solve  u*work = v
*
      DO 80 KB=1,NPAR
         K = NPAR + 1 - KB
         IF (DABS(WORK(K)) .GT. DABS(A(K,K))) THEN
            S = DABS(A(K,K))/DABS(WORK(K))
            CALL DSCAL(NPAR,S,WORK)
            YNORM = S*YNORM
         ENDIF
         IF (A(K,K) .NE. 0.D0) THEN
            WORK(K) = WORK(K)/A(K,K)
         ELSE
            WORK(K) = 1.D0
         ENDIF
         T = -WORK(K)
         CALL DAXPY(K-1,T,A(1,K),WORK(1))
 80   CONTINUE
*
*     make znorm = 1.0
*
      S = 1.D0/DASUM(NPAR,WORK)
      CALL DSCAL(NPAR,S,WORK)
      YNORM = S*YNORM
*
*     rcond (=YNORM/ANORM) is an estimate of the reciprocal condition of
*     A.  For the system a*x = b , relative perturbations in a and b of
*     size epsilon may cause relative perturbations in x of size
*     epsilon/rcond.
*
*     check to see if matrix is singular. If rcond is
*     effectively zero, then XTX may be singular to working precision.
*     rcond is zero if exact singularity is detected or underflow
*     occurs.
*
      IF (ANORM .EQ. 0.D0 .OR. (1.D0+YNORM/ANORM.EQ.1.D0))
     &   CALL ERROR7(13)
*
*     compute matrix inverse using the factors computed above
*
*     at this point, A is an upper triangular matrix that includes the
*     multipliers which were used to obtain it.  The factorization can
*     be written A = l*u  where l  is a product of permutation and unit
*     lower triangular matrices and u is upper triangular.
*
*     error condition: division by zero will occur if the input
*     factor contains a zero on the diagonal and the inverse is
*     requested. It will not occur if the subroutines are called
*     correctly and if DGECO has set rcond .gt. 0.0.
*
*     compute inverse(u)
*
      DO 100 I=1,NPAR
         A(I,I) = 1.D0/A(I,I)
         T = -A(I,I)
         CALL DSCAL(I-1,T,A(1,I))
         DO 90 J=I+1,NPAR
            T = A(I,J)
            A(I,J) = 0.D0
            CALL DAXPY(I,T,A(1,I),A(1,J))
 90      CONTINUE
 100  CONTINUE
*
*     form inverse(u)*inverse(l)
*
      DO 130 I=1,NPAR-1
         K = NPAR - I
         DO 110 J=K+1,NPAR
            WORK(J) = A(J,K)
            A(J,K) = 0.D0
 110     CONTINUE
         DO 120 J=K+1,NPAR
            T = WORK(J)
            CALL DAXPY(NPAR,T,A(1,J),A(1,K))
 120     CONTINUE
         IF (IPVT(K) .NE. K) CALL DSWAP(NPAR,A(1,K),A(1,IPVT(K)))
 130   CONTINUE

      RETURN
      END


  subroutine sfint (sfname, flim1, flim2, bs, rs, fint, dataObj)

! ======================================================================
!
!    Gaussian quadrature; integral from flim2 to flim1 of fname.
!
!    CEM95 written by S. G. Mashnik
!    Edited by A. J. Sierk  LANL  T-2  February, 1996.
!    "Last" change: 14-AUG-2003 by NVMokhov
!    Edited by A. J. Sierk, LANL T-16, October, 2003.
!    Edited by AJS, LANL T-2, December, 2011.
!
! ======================================================================

    use, intrinsic:: iso_fortran_env, only: int32, real64
    use standardDCMDataParams, only: zro, hlf, gaussWgt, gaussAbsc, numQuads

    implicit none
    procedure(IntegralInterface), intent(in   ), pointer :: sfname
    real(real64), intent(in   ) :: flim1
    real(real64), intent(in   ) :: flim2
    real(real64), intent(in   ) :: bs
    real(real64), intent(in   ) :: rs
    real(real64), intent(  out) :: fint
    class(StandardDCMData), intent(inout) :: dataObj

    integer(int32) :: it
    real(real64)   :: fname, fy, t1, t2, temp

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

    temp = zro
    t1 = hlf*(flim1 - flim2)
    t2 = hlf*(flim1 + flim2)
    do it = 1, numQuads
       fy = t1*gaussAbsc(it) + t2
       call sfname (fy, bs, rs, fname, dataObj)
       temp = temp + gaussWgt(it)*fname
    end do
    fint = temp*t1
    return

! ======================================================================
  end subroutine sfint

  subroutine sfint1 (sfname, flim1, flim2, bs, rs, fint1, dataObj)

! ======================================================================
!
!   Gaussian quadrature; integral from flim2 to flim1 of fname.
!   Identical to FINT; Needed to prevent a recursion when FINT (FIS...)
!   is called, since FIS uses FINT1.
!
!    CEM95 written by S. G. Mashnik
!    Edited by A. J. Sierk  LANL  T-2  February-March, 1996.
!   "Last" change: 14-AUG-2003 by NVMokhov
!    Edited by A. J. Sierk, LANL T-16, October, 2003.
!    Edited by AJS, LANL T-2, December, 2011.
!
! ======================================================================

    use, intrinsic:: iso_fortran_env, only: int32, real64
    use standardDCMDataParams, only: zro, hlf, gaussWgt, gaussAbsc, numQuads

    implicit none
    procedure(IntegralInterface), intent(in   ), pointer :: sfname
    real(real64), intent(in   ) :: flim1
    real(real64), intent(in   ) :: flim2
    real(real64), intent(in   ) :: bs
    real(real64), intent(in   ) :: rs
    real(real64), intent(  out) :: fint1
    class(StandardDCMData), intent(inout) :: dataObj

    integer(int32) ::  it
    real(real64)   :: fname, fy, t1, t2, temp

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

    temp = zro
    t1 = hlf*(flim1 - flim2)
    t2 = hlf*(flim1 + flim2)
    do it = 1, numQuads
       fy = t1*gaussAbsc(it) + t2
       call sfname (fy, bs, rs, fname, dataObj)
       temp = temp + gaussWgt(it)*fname
    end do
    fint1 = temp*t1
    return

! ======================================================================
  end subroutine sfint1


!==============================================================================!
  subroutine Prec_Form(A, prec)
!------------------------------------------------------------------------------!
!   Forms preconditioning matrix "D" from provided matrix "A".                 !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use par_mod
  use Matrix_Mod
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Matrix_Type) :: A
  integer           :: prec
!-----------------------------------[Locals]-----------------------------------!
  real     :: sum1
  integer  :: i, j, k, N
!==============================================================================!

  N = A % pnt_grid % n_cells

  !---------------------------------!
  !   1) diagonal preconditioning   !
  !---------------------------------!
  if(prec == 1) then
    do i=1,N
      D % val(D % dia(i)) = A % val(A % dia(i))
    end do

  !--------------------------------------------!
  !   2) incomplete cholesky preconditioning   !
  !--------------------------------------------!
  else if(prec == 2) then
    do i = 1,N
      sum1 = A % val(A % dia(i))       ! take diaginal entry
      do j = A % row(i), A % dia(i)-1  ! only lower traingular
        k = A % col(j)
        sum1 = sum1 - D % val(D % dia(k)) * A % val(j) * A % val(j)
      end do
      D % val(D % dia(i)) = 1.0 / sum1
    end do

  !---------------------------!
  !   .) no preconditioning   !
  !---------------------------!
  else
    do i=1,N
      D % val(D % dia(i)) = 1.0
    end do
  end if

  end subroutine


module AUXILIARIES
! Description:
!    Contains auxiliary variables to be communicated between different
!    procedures.
!
! Author:
!    Davide Amato
!    Space Dynamics Group - Technical University of Madrid
!    davideamato@email.arizona.edu
!
! ==============================================================================

! VARIABLES
use KINDS, only: dk
implicit none
! Reference quantities for non-dimensionalization
real(dk)  ::  DU,TU
! Initial epoch, next epoch during integration, and final epoch (MJD-UT1)
real(dk)  ::  MJD0,MJDnext,MJDf

contains

subroutine SET_UNITS(R,GM)
! Description:
!    Contains reference units for non-dimensionalization. DU is a unit of
!    distance, while TU is a unit of frequency. With this choice of reference
!    units, GM = 1 (DU^3)*(TU^2).

implicit none
real(dk),intent(in)  :: R(1:3)
real(dk),intent(in)  :: GM

DU = sqrt(dot_product(R,R))
TU = sqrt(GM/DU**3)

end subroutine SET_UNITS

function T2MJD(t)
! Description:
!    Converts dimensionless time to MJD.

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

! MODULES
use PHYS_CONST, only: secsPerDay

! VARIABLES
implicit none
real(dk),intent(in)  ::  t
real(dk)  ::  T2MJD

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

T2MJD = t/TU/secsPerDay + MJD0

end function T2MJD

end module AUXILIARIES


  subroutine ekb_ribbon
     ! This subroutine caculates energy dispersion for
     ! 1D wire system with axial magnetic field
     ! Copyright (c) 2010 QuanSheng Wu. All rights reserved.

     use para
     implicit none

     integer :: mdim
     integer :: ndim1

     ! loop index
     integer :: i

     integer :: lwork

     ! the indices of the smallest and largest
     ! eigenvalues to be returned
     integer :: il,iu

     ! wave vector
     real(Dp) :: k

     real(Dp) :: kmax=0.5d0

     !the lower and upper bounds of the interval
     !to be searched for eigenvalues
     real(Dp) :: vl,vu

     !The absolute error tolerance for the eigenvalues
     real(Dp) :: abstol

     ! parameters for zheev
     integer :: info,ierr,ifail

     ! number of magnetic fields
     integer :: Nb

     ! magnetic field
     real(dp) :: Bmag
     real(dp), allocatable :: magnetic(:)

     ! energy dispersion
     real(Dp),allocatable :: ekbribbon(:,:)
     real(Dp),allocatable ::  rwork(:)
     integer,allocatable ::  iwork(:)
     complex(Dp),allocatable :: work(:)

     ! eigenvalue
     real(Dp),allocatable :: eigenvalue(:)

     ! hamiltonian slab
     complex(Dp),allocatable ::z(:,:)
     complex(Dp),allocatable ::CHamk(:,:)

     Nb= 400
     Ndim1=Num_wann*nslab1*nslab2
     lwork=64*Ndim1

     allocate(ekbribbon(Ndim1,Nb ))
     allocate(z(Ndim1,Ndim1))
     allocate(CHamk(Ndim1,Ndim1))
     allocate(rwork(7*Ndim1))
     allocate(work(lwork))
     allocate(iwork(5*Ndim1))
     allocate(eigenvalue(Ndim1))
     allocate(magnetic(Nb))

     ierr = 0

     ! sweep k
     ekbribbon=0.0d0

     kmax=0.5d0

     abstol=1e-10
     vl=-0.6/27.2114d0
     vu=0.5/27.2114d0
     il=17*Nslab1*Nslab2
     iu=20*Nslab1*Nslab2
     mdim=iu-il+1

     do i=1, Nb
        magnetic(i)= (i-1)*1.0d0/real(Nb)
     enddo

     do i=1,Nb
        Bmag= magnetic(i)
        k=0d0
        chamk=0.0d0
        call ham_ribbon_b(bmag, k,Chamk)
        eigenvalue=0.0d0

        ! diagonal Chamk
        call eigensystem_c('N', 'U', Ndim1, CHamk, eigenvalue)

        ! only eigenvalues are computed
        ! the eigenvalues with indices il through iu will be found

       !call zheevx('N','I','U',Ndim1,Chamk,Ndim1,vl,vu,il,iu,abstol,&
       !mdim,eigenvalue,z,Ndim1,work,lwork,rwork,iwork,ifail,info)

        ekbribbon(:,i)=eigenvalue

        write(stdout,'(a2,i4,f12.5,f10.2,a2)')'B, Nb', i, Nb, ekbribbon(1,i)
     enddo

    !open(unit=100, file='ribbonek.dat',status='unknown')
    !do i=1,Nk1
    !   k=-kmax*real(Nk1-i)/(Nk1-1)
    !   write(100,'(60000f15.7)')k,ekbribbon(:,Nk1-i+1)
    !enddo

    !do i=1,Nk1
    !   k=kmax*real(i-1)/(Nk1-1)
    !   write(100,'(60000f15.7)')k,ekbribbon(:,i)
    !enddo
    !close(100)

    open(unit=100, file='ribbonekb.dat',status='unknown')
    do i=1, Nb
       write(100, '(50000f15.7)')magnetic(i), ekbribbon(:, i)
    enddo
    !write(stdout,*) 'calculate energy band  done'

  return
  end subroutine ekb_ribbon


c     program DRDHINT
c>> 1996-05-28 DRDHINT  Krogh Added external statement.
c>> 1994-10-19 DRDHINT  Krogh  Changes to use M77CON
c>> 1987-12-09 DRDHINT  Lawson  Initial Code.
c--D replaces "?": DR?HINT, ?HINT
c
      integer I, J, NTAB
      double precision X, XTAB(3), YTAB(3), YPTAB(3), YINT, YPINT, YTRUE
      external DHINT
      double precision DHINT
c
      data XTAB / 0.D0, .5D0, .75D0 /
      data NTAB / 3 /
c
   10 format(1X,'Demonstration of DHINT by interpolating to the',
     *          ' exponential function,'/
     *          1X,'given values at X = 0.0, 0.5, and 0.75'//
     *          4X,'X',7X,'YTRUE',9X,
     *          'YINT',6X,'YINT-YTRUE',5X,'YPINT',6X,'YPINT-YTRUE'/1X)
   20 format(1X,F5.2,5F13.6)
c
      do 30 I = 1,3
        YTAB(I) = EXP(XTAB(I))
        YPTAB(I) = YTAB(I)
   30 continue
c
      print 10
c
      do 50 J = 10, 110, 5
        X = DBLE(J)/100.D0 - 0.1D0
        YINT = DHINT(X,0,NTAB,XTAB,YTAB,YPTAB)
        YPINT = DHINT(X,1,NTAB,XTAB,YTAB,YPTAB)
        YTRUE = EXP(X)
        print 20, X, YTRUE, YINT, YINT-YTRUE, YPINT, YPINT-YTRUE
   50 continue
c
      end


      SUBROUTINE clawpack5_qinit(meqn,mbc,mx,my,xlower,ylower,
     &                           dx,dy,q,maux,aux)
      implicit none

      integer meqn, mbc, mx, my, maux
      double precision xlower, ylower, dx, dy
      double precision q(meqn,1-mbc:mx+mbc, 1-mbc:my+mbc)
      double precision aux(maux,1-mbc:mx+mbc, 1-mbc:my+mbc)

      integer i, j, blockno, fc2d_clawpack5_get_block
      double precision xc,yc, xp, yp, zp, xlow, ylow, w
      double precision dxc,xm,ym

      double precision q0_physical

      integer*8 cont, get_context
      logical fclaw2d_map_is_used

      integer ii,jj

      integer initchoice
      common /initchoice_comm/ initchoice

      cont = get_context()

      blockno = fc2d_clawpack5_get_block()

      do i = 1-mbc,mx+mbc
          xc = xlower + (i-0.5d0)*dx
          do j = 1-mbc,my+mbc
              yc = ylower + (j-0.5d0)*dy

              if (initchoice .eq. 0) then
c                 # Discontinuous solution
                  xlow = xlower + (i-1)*dx
                  ylow = ylower + (j-1)*dy
                  call cellave2(blockno,xlow,ylow,dx,dy,w)
                  q(1,i,j) = w
              elseif (initchoice .eq. 1) then
                  call fclaw2d_map_c2m(cont,blockno,xc,yc,xp,yp,zp)
                  q(1,i,j) = q0_physical(xp,yp,zp)
              elseif (initchoice .eq. 2) then
                  q(1,i,j) = 1.d0
              elseif (initchoice .eq. 3) then
c                 # Not sure what this one is about
                  if (fclaw2d_map_is_used(cont)) then
                      call fclaw2d_map_c2m(cont,
     &                           blockno,xc,yc,xp,yp,zp)
                  else
                      xp = xc
                      yp = yc
                  endif
                  dxc = 1.d0/8.d0
                  xm = 0.25
                  ym = 0.25
                  w = dxc/2.d0
                  q(1,i,j) = 0
                  if (blockno .eq.2) then
                      do jj=7,8
                          do ii=1,2
                              q(1,ii,jj) = 1.d0
                          enddo
                      enddo
                  endif
                  if (blockno .eq. 1) then
                      do ii=5,7
c                         q(1,ii,my) = 1.d0
                      enddo
                  endif
              endif
          enddo
      enddo

      return
      end


      program opkdemo8
c-----------------------------------------------------------------------
c Demonstration program for the DLSOIBT package.
c This is the version of 14 June 2001.
c
c This version is in double precision.
c
c This program solves a semi-discretized form of the following system
c Of three PDEs (each similar to a Burgers equation):
c
c   u(i)   =  -(u(1)+u(2)+u(3)) u(i)   +  eta(i) u(i)    (i=1,2,3),
c       t                           x                xx
c
c on the interval  -1 .le. x .le. 1, and with time t .ge. 0.
c The diffusion coefficients are eta(*) = .1, .02, .01.
c The boundary conditions are u(i) = 0 at x = -1 and x = 1 for all i.
c The initial profile for each u(i) is a square wave:
c     u(i) = 0         on 1/2 .lt. abs(x) .le. 1
c     u(i) = amp(i)/2  on abs(x) = 1/2
c     u(i) = amp(i)    on 0 .le. abs(x) .lt. 1/2
c where the amplitudes are amp(*) = .2, .3, .5.
c
c A simplified Galerkin treatment of the spatial variable x is used,
c with piecewise linear basis functions on a uniform mesh of 100
c intervals.  The result is a system of ODEs in the discrete values
c u(i,k) approximating u(i)  (i=1,2,3) at the interior points
c (k = 1,...,99).  The ODEs are:
c
c    .            .        .
c   (u(i,k-1) + 4 u(i,k) + u(i,k+1))/6  =
c
c     -(1/6dx) (c(k-1)dul(i) + 2c(k)(dul(i)+dur(i)) + c(k+1)dur(i))
c
c     + (eta(i)/dx**2) (dur(i) - dul(i))     (i=1,2,3,  k=1,...,99),
c
c where
c     c(j) = u(1,j)+u(2,j)+u(3,j),   dx = .02 = the interval size,
c     dul(i) = u(i,k) - u(i,k-1),   dur(i) = u(i,k+1) - u(i,k).
c Terms involving boundary values (subscripts 0 or 100) are dropped
c from the equations for k = 1 and k = 99 above.
c
c The problem is run for each of the 4 values of mf, and for two values
c of the tolerances.  Output is taken at t = .1, .2, .3, .4.
c Output is on unit lout, set to 6 in a data statement below.
c-----------------------------------------------------------------------
      external res, addabt, jacbt
      integer ncomp, nip, nm1
      integer i, io, istate, itol, iwork, jtol, lout, liw, lrw,
     1   meth, miter, mf, neq, nerr, nint, nout
      double precision eodsq, r6d
      double precision abermx, atol, dx, errfac, eta, hun, one,
     1   rtol, rwork, six, t, tinit, tlast, tout, tols, two, y, ydoti
      dimension eta(3), y(297), ydoti(297), tout(4), tols(2)
      dimension rwork(7447), iwork(317)
      dimension neq(1), rtol(1), atol(1)
c Pass problem parameters in the common block par.
      common /par/ r6d, eodsq(3), ncomp, nip, nm1
c
c Set problem parameters and run parameters
      data eta/0.1d0,0.02d0,0.01d0/, tinit/0.0d0/, tlast/0.4d0/
      data one/1.0d0/, two/2.0d0/, six/6.0d0/, hun/100.0d0/
      data tout/.10d0,.20d0,.30d0,.40d0/
      data lout/6/, nout/4/, lrw/7447/, liw/317/
      data itol/1/, tols/1.0d-3, 1.0d-6/
c
c Set mesh parameters nint, dxc etc.
      nint = 100
      ncomp = 3
      dx = two/nint
      r6d = one/(six*dx)
      do 10 i = 1,ncomp
 10     eodsq(i) = eta(i)/dx**2
      nip = nint - 1
      neq(1) = ncomp*nip
      nm1 = nip - 1
      iwork(1) = ncomp
      iwork(2) = nip
c
      nerr = 0
c
c Set the initial conditions (for output purposes only).
      call setic (nint, ncomp, y)
c
      write (lout,1000)
      write (lout,1100) (eta(i),i=1,ncomp), tinit, tlast, nint,
     1      ncomp, nip, neq(1)
      write (lout,1200)
      call edit (y, ncomp, nip, lout)
c
c The jtol loop is over error tolerances.
      do 200 jtol = 1,2
      rtol(1) = tols(jtol)
      atol(1) = rtol(1)
c
c The meth/miter loops cover 4 values of method flag mf.
      do 100 meth = 1,2
       do 100 miter = 1,2
        mf = 10*meth + miter
c
c Set the initial conditions.
        call setic (nint, ncomp, y)
        t = tinit
        istate = 0
c
        write (lout,1500)  rtol(1), atol(1), mf
c
c Loop over output times for each case
        do 80 io = 1,nout
c
          call dlsoibt (res, addabt,jacbt, neq, y, ydoti, t, tout(io),
     1     itol,rtol,atol, 1, istate, 0, rwork,lrw,iwork,liw, mf)
c
          write (lout,2000) t, rwork(11), iwork(14), iwork(11)
          if (io .eq. nout) call edit (y, ncomp, nip, lout)
c
c If istate is not 2 on return, print message and go to next case.
          if (istate .ne. 2) then
            write (lout,4000) mf, t, istate
            nerr = nerr + 1
            go to 100
            endif
c
 80       continue
c
c Print final statistics.
        write (lout,3000) mf, iwork(11), iwork(12), iwork(13),
     1         iwork(17), iwork(18)
c
c Estimate final error and print result.
        call maxerr (y, ncomp, nip, abermx)
        errfac = abermx/tols(jtol)
        if (errfac .lt. hun) then
          write (lout,5000) errfac
        else
          write (lout,5100) errfac
          nerr = nerr + 1
          endif
 100    continue
 200  continue
c
      write (lout,6000) nerr
c      stop
c
 1000 format(/20x,' Demonstration Problem for DLSOIBT'//
     1   10x,'Galerkin method solution of system of 3 PDEs:'//
     2   10x,'  u(i)   =  -(u(1)+u(2)+u(3)) u(i)   +  eta(i) u(i)',
     3   5x,'(i=1,2,3)',/16x,'t',27x,'x',16x,'xx'//
     4   10x,'x interval is -1 to 1,  zero boundary conditions'/
     5   10x,'x discretized using piecewise linear basis functions')
 1100 format(/10x,'Fixed parameters are as follows:'/
     1       13x,'Diffusion coefficients are eta =',3d10.2/
     2       13x,'t0 = ',d12.5/13x,'tlast = ',d12.5/
     3       13x,'Uniform mesh, number of intervals =',i4/
     4       13x,'Block size mb =',i2/13x,'Number of blocks nb =',i4/
     5       13x,'ODE system size neq =',i5//)
c
 1200 format(/'Initial profiles:'/)
c
 1500 format(////90('*')//'Run with rtol =',d9.1,'  atol =',d9.1,
     1       '   mf =',i3///)
c
 2000 format(' At time t =',d12.5,'  current h =',d12.5,
     1       '  current order =',i2,'  current nst =',i5/)
c
 3000 format(//'Final statistics for mf = ',i2,':',
     1       i5,' steps,',i6,' res,',i6,' jacobians,'/
     2       30x,       'rwork size =',i6,',  iwork size =',i6)
c
 4000 format(//20x,'Final time reached for mf = ',i2,
     1       ' was t = ',d12.5/25x,'at which istate = ',i2//)
 5000 format('Final output is correct to within ',d9.2,
     1       '  times local error tolerance. ')
 5100 format('Final output is wrong by ',d9.2,
     1       '  times local error tolerance.')
 6000 format(//90('*')//'Run completed: ',i3,' errors encountered')
c
c end of main program for the DLSOIBT demonstration problem
      end