      SUBROUTINE SB02PD( JOB, TRANA, UPLO, N, A, LDA, G, LDG, Q, LDQ, X,
     $                   LDX, RCOND, FERR, WR, WI, IWORK, DWORK, LDWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To solve the real continuous-time matrix algebraic Riccati
C     equation
C
C        op(A)'*X + X*op(A) + Q - X*G*X = 0,
C
C     where op(A) = A or A' = A**T and G, Q are symmetric (G = G**T,
C     Q = Q**T). The matrices A, G and Q are N-by-N and the solution X
C     is an N-by-N symmetric matrix.
C
C     An error bound on the solution and a condition estimate are also
C     optionally provided.
C
C     It is assumed that the matrices A, G and Q are such that the
C     corresponding Hamiltonian matrix has N eigenvalues with negative
C     real parts.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies the computation to be performed, as follows:
C             = 'X':  Compute the solution only;
C             = 'A':  Compute all: the solution, reciprocal condition
C                     number, and the error bound.
C
C     TRANA   CHARACTER*1
C             Specifies the option op(A):
C             = 'N':  op(A) = A    (No transpose);
C             = 'T':  op(A) = A**T (Transpose);
C             = 'C':  op(A) = A**T (Conjugate transpose = Transpose).
C
C     UPLO    CHARACTER*1
C             Specifies which triangle of the matrices G and Q is
C             stored, as follows:
C             = 'U':  Upper triangles of G and Q are stored;
C             = 'L':  Lower triangles of G and Q are stored.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices A, G, Q, and X.  N >= 0.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array must contain the
C             coefficient matrix A of the equation.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,N).
C
C     G       (input) DOUBLE PRECISION array, dimension (LDG,N)
C             If UPLO = 'U', the leading N-by-N upper triangular part of
C             this array must contain the upper triangular part of the
C             matrix G.
C             If UPLO = 'L', the leading N-by-N lower triangular part of
C             this array must contain the lower triangular part of the
C             matrix G.
C
C     LDG     INTEGER
C             The leading dimension of the array G.  LDG >= max(1,N).
C
C     Q       (input) DOUBLE PRECISION array, dimension (LDQ,N)
C             If UPLO = 'U', the leading N-by-N upper triangular part of
C             this array must contain the upper triangular part of the
C             matrix Q.
C             If UPLO = 'L', the leading N-by-N lower triangular part of
C             this array must contain the lower triangular part of the
C             matrix Q.
C
C     LDQ     INTEGER
C             The leading dimension of the array Q.  LDQ >= max(1,N).
C
C     X       (output) DOUBLE PRECISION array, dimension (LDX,N)
C             If INFO = 0, INFO = 2, or INFO = 4, the leading N-by-N
C             part of this array contains the symmetric solution matrix
C             X of the algebraic Riccati equation.
C
C     LDX     INTEGER
C             The leading dimension of the array X.  LDX >= max(1,N).
C
C     RCOND   (output) DOUBLE PRECISION
C             If JOB = 'A', the estimate of the reciprocal condition
C             number of the Riccati equation.
C
C     FERR    (output) DOUBLE PRECISION
C             If JOB = 'A', the estimated forward error bound for the
C             solution X. If XTRUE is the true solution, FERR bounds the
C             magnitude of the largest entry in (X - XTRUE) divided by
C             the magnitude of the largest entry in X.
C
C     WR      (output) DOUBLE PRECISION array, dimension (N)
C     WI      (output) DOUBLE PRECISION array, dimension (N)
C             If JOB = 'A' and TRANA = 'N', WR and WI contain the real
C             and imaginary parts, respectively, of the eigenvalues of
C             the matrix A - G*X, i.e., the closed-loop system poles.
C             If JOB = 'A' and TRANA = 'T' or 'C', WR and WI contain the
C             real and imaginary parts, respectively, of the eigenvalues
C             of the matrix A - X*G, i.e., the closed-loop system poles.
C             If JOB = 'X', these arrays are not referenced.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (LIWORK), where
C             LIWORK >= 2*N,          if JOB = 'X';
C             LIWORK >= max(2*N,N*N), if JOB = 'A'.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0 or INFO = 2, DWORK(1) contains the
C             optimal value of LDWORK. If JOB = 'A', then DWORK(2:N*N+1)
C             and DWORK(N*N+2:2*N*N+1) contain a real Schur form of the
C             closed-loop system matrix, Ac = A - G*X (if TRANA = 'N')
C             or Ac = A - X*G (if TRANA = 'T' or 'C'), and the
C             orthogonal matrix which reduced Ac to real Schur form,
C             respectively.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             LDWORK >= 4*N*N + 8*N + 1,               if JOB = 'X';
C             LDWORK >= max( 4*N*N + 8*N + 1, 6*N*N ), if JOB = 'A'.
C             For good performance, LDWORK should be larger, e.g.,
C             LDWORK >= 4*N*N + 6*N +( 2*N+1 )*NB,     if JOB = 'X',
C             where NB is the optimal blocksize.
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
C
C     Error indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  the Hamiltonian matrix has eigenvalues on the
C                   imaginary axis, so the solution and error bounds
C                   could not be computed;
C             = 2:  the iteration for the matrix sign function failed to
C                   converge after 50 iterations, but an approximate
C                   solution and error bounds (if JOB = 'A') have been
C                   computed;
C             = 3:  the system of linear equations for the solution is
C                   singular to working precision, so the solution and
C                   error bounds could not be computed;
C             = 4:  the matrix A-G*X (or A-X*G) cannot be reduced to
C                   Schur canonical form and condition number estimate
C                   and forward error estimate have not been computed.
C
C     METHOD
C
C     The Riccati equation is solved by the matrix sign function
C     approach [1], [2], implementing a scaling which enhances the
C     numerical stability [4].
C
C     REFERENCES
C
C     [1] Bai, Z., Demmel, J., Dongarra, J., Petitet, A., Robinson, H.,
C         and Stanley, K.
C         The spectral decomposition of nonsymmetric matrices on
C         distributed memory parallel computers.
C         SIAM J. Sci. Comput., vol. 18, pp. 1446-1461, 1997.
C
C     [2] Byers, R., He, C., and Mehrmann, V.
C         The matrix sign function method and the computation of
C         invariant subspaces.
C         SIAM J. Matrix Anal. Appl., vol. 18, pp. 615-632, 1997.
C
C     [3] Higham, N.J.
C         Perturbation theory and backward error for AX-XB=C.
C         BIT, vol. 33, pp. 124-136, 1993.
C
C     [4] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V.,
C         DGRSVX and DMSRIC: Fortran 77 subroutines for solving
C         continuous-time matrix algebraic Riccati equations with
C         condition and accuracy estimates.
C         Preprint SFB393/98-16, Fak. f. Mathematik, Technical
C         University Chemnitz, May 1998.
C
C     NUMERICAL ASPECTS
C
C     The solution accuracy can be controlled by the output parameter
C     FERR.
C
C     FURTHER COMMENTS
C
C     The condition number of the Riccati equation is estimated as
C
C     cond = ( norm(Theta)*norm(A) + norm(inv(Omega))*norm(Q) +
C                 norm(Pi)*norm(G) ) / norm(X),
C
C     where Omega, Theta and Pi are linear operators defined by
C
C     Omega(W) = op(Ac)'*W + W*op(Ac),
C     Theta(W) = inv(Omega(op(W)'*X + X*op(W))),
C        Pi(W) = inv(Omega(X*W*X)),
C
C     and the matrix Ac (the closed-loop system matrix) is given by
C        Ac = A - G*X, if TRANA = 'N', or
C        Ac = A - X*G, if TRANA = 'T' or 'C'.
C
C     The program estimates the quantities
C
C     sep(op(Ac),-op(Ac)') = 1 / norm(inv(Omega)),
C
C     norm(Theta) and norm(Pi) using 1-norm condition estimator.
C
C     The forward error bound is estimated using a practical error bound
C     similar to the one proposed in [3].
C
C     CONTRIBUTOR
C
C     P. Petkov, Tech. University of Sofia, March 2000.
C
C     REVISIONS
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, June 2000; Aug. 2011.
C
C     KEYWORDS
C
C     Algebraic Riccati equation, continuous-time system,
C     optimal control, optimal regulator.
C
C     ******************************************************************
C
C     .. Parameters ..
      INTEGER            MAXIT
      PARAMETER          ( MAXIT = 50 )
      DOUBLE PRECISION   ZERO, HALF, ONE, TWO, TEN
      PARAMETER          ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0,
     $                     TWO  = 2.0D+0, TEN  = 10.0D+0 )
C     ..
C     .. Scalar Arguments ..
      CHARACTER          JOB, TRANA, UPLO
      INTEGER            INFO, LDA, LDG, LDQ, LDWORK, LDX, N
      DOUBLE PRECISION   FERR, RCOND
C     ..
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), DWORK( * ), G( LDG, * ),
     $                   Q( LDQ, * ), WI( * ), WR( * ), X( LDX, * )
C     ..
C     .. Local Scalars ..
      LOGICAL            ALL, LOWER, LQUERY, NOTRNA
      CHARACTER          EQUED, LOUP
      INTEGER            I, IAF, IB, IBR, IC, IFR, IJ, IJ1, IJ2, INFO2,
     $                   INI, IR, ISCL, ISV, IT, ITAU, ITER, IU, IWRK,
     $                   J, JI, LWAMAX, MINWRK, N2, SDIM
      DOUBLE PRECISION   CONV, GNORM2, EPS, HNORM, HINNRM, QNORM2,
     $                   SCALE, SEP, TEMP, TOL
C     ..
C     .. Local Arrays ..
      LOGICAL            BWORK( 1 )
C     ..
C     .. External Functions ..
      LOGICAL            LSAME, SELECT
      DOUBLE PRECISION   DLAMCH, DLANSY
      EXTERNAL           DLAMCH, DLANSY, LSAME, SELECT
C     ..
C     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEES, DGEQP3, DGESVX, DLACPY, DLASCL,
     $                   DLASET, DORMQR, DSCAL, DSWAP, DSYMM, DSYTRF,
     $                   DSYTRI, MA02AD, MA02ED, SB02QD, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          DBLE, INT, MAX, SQRT
C     ..
C     .. Executable Statements ..
C
C     Decode and Test input parameters.
C
      ALL    = LSAME( JOB,   'A' )
      NOTRNA = LSAME( TRANA, 'N' )
      LOWER  = LSAME( UPLO,  'L' )
      LQUERY = LDWORK.EQ.-1
C
      INFO = 0
      IF( .NOT.ALL .AND. .NOT.LSAME( JOB, 'X' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LSAME( TRANA, 'T' ) .AND.
     $         .NOT.LSAME( TRANA, 'C' ) .AND. .NOT.NOTRNA ) THEN
         INFO = -2
      ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDG.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -12
      ELSE
C
C        Compute workspace.
C
         N2 = 2*N
         IF( ALL ) THEN
            MINWRK = MAX( N2*N2 + 8*N + 1, 6*N*N )
         ELSE
            MINWRK = N2*N2 + 8*N + 1
         END IF
         ITAU = N2*N2
         IWRK = ITAU + N2
         IF ( LQUERY ) THEN
            CALL DSYTRF( UPLO, N2, DWORK, N2, IWORK, DWORK, -1, INFO2 )
            LWAMAX = INT( DWORK( 1 ) )
            CALL DGEQP3( N2, N2, DWORK, N2, IWORK, DWORK, DWORK, -1,
     $                   INFO2 )
            LWAMAX = MAX( INT( DWORK( 1 ) ), LWAMAX )
            CALL DORMQR( 'L', 'N', N2, N, N, DWORK, N2, DWORK, DWORK,
     $                   N2, DWORK, -1, INFO2 )
            LWAMAX = MAX( IWRK + MAX( INT( DWORK( 1 ) ), LWAMAX ),
     $                    MINWRK )
            IF( ALL ) THEN
               CALL DGEES( 'V', 'N', SELECT, N, DWORK, N, SDIM, WR, WI,
     $                     DWORK, N, DWORK, -1, BWORK, INFO2 )
               LWAMAX = MAX( N2*N + INT( DWORK( 1 ) ), LWAMAX )
               CALL SB02QD( 'B', 'F', TRANA, UPLO, 'O', N, A, LDA,
     $                      DWORK, N, DWORK, N, G, LDG, Q, LDQ, X, LDX,
     $                      SEP, RCOND, FERR, IWORK, DWORK, -1, INFO2 )
               LWAMAX = MAX( N2*N + INT( DWORK( 1 ) ), LWAMAX )
            END IF
         END IF
         IF( LDWORK.LT.MINWRK .AND. .NOT.LQUERY )
     $      INFO = -19
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SB02PD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = LWAMAX
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         IF( ALL ) THEN
            RCOND = ONE
            FERR  = ZERO
         END IF
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Set tol.
C
      EPS = DLAMCH( 'P' )
      TOL = TEN*DBLE( N )*EPS
C
C     Compute the square-roots of the norms of the matrices Q and G .
C
      QNORM2 = SQRT( DLANSY( '1', UPLO, N, Q, LDQ, DWORK ) )
      GNORM2 = SQRT( DLANSY( '1', UPLO, N, G, LDG, DWORK ) )
C
C     Construct the lower (if UPLO = 'L') or upper (if UPLO = 'U')
C     triangle of the symmetric block-permuted Hamiltonian matrix.
C     During iteration, both the current iterate corresponding to the
C     Hamiltonian matrix, and its inverse are needed. To reduce the
C     workspace length, the transpose of the triangle specified by UPLO
C     of the current iterate H is saved in the opposite triangle,
C     suitably shifted with one column, and then the inverse of H
C     overwrites H. The triangles of the saved iterate and its inverse
C     are stored together in an 2*N-by-(2*N+1) matrix. For instance, if
C     UPLO = 'U', then the upper triangle is built starting from the
C     location 2*N+1 of the array DWORK, so that its transpose can be
C     stored in the lower triangle of DWORK.
C     Workspace: need   4*N*N,        if UPLO = 'L';
C                       4*N*N + 2*N,  if UPLO = 'U'.
C
      IF ( LOWER ) THEN
         INI  = 0
         ISV  = N2
         LOUP = 'U'
C
         DO 40 J = 1, N
            IJ = ( J - 1 )*N2 + J
C
            DO 10 I = J, N
               DWORK(IJ) = -Q(I,J)
               IJ = IJ + 1
   10       CONTINUE
C
            IF( NOTRNA ) THEN
C
               DO 20 I = 1, N
                  DWORK( IJ ) = -A( I, J )
                  IJ = IJ + 1
   20          CONTINUE
C
            ELSE
C
               DO 30 I = 1, N
                  DWORK( IJ ) = -A( J, I )
                  IJ = IJ + 1
   30          CONTINUE
C
            END IF
   40    CONTINUE
C
         DO 60 J = 1, N
            IJ = ( N + J - 1 )*N2 + N + J
C
            DO 50 I = J, N
               DWORK( IJ ) = G( I, J )
               IJ = IJ + 1
   50       CONTINUE
C
   60    CONTINUE
C
      ELSE
         INI  = N2
         ISV  = 0
         LOUP = 'L'
C
         DO 80 J = 1, N
            IJ = J*N2 + 1
C
            DO 70 I = 1, J
               DWORK(IJ) = -Q(I,J)
               IJ = IJ + 1
   70       CONTINUE
C
   80    CONTINUE
C
         DO 120 J = 1, N
            IJ = ( N + J )*N2 + 1
C
            IF( NOTRNA ) THEN
C
               DO 90 I = 1, N
                  DWORK( IJ ) = -A( J, I )
                  IJ = IJ + 1
   90          CONTINUE
C
            ELSE
C
               DO 100 I = 1, N
                  DWORK( IJ ) = -A( I, J )
                  IJ = IJ + 1
  100          CONTINUE
C
            END IF
C
            DO 110 I = 1, J
               DWORK( IJ ) = G( I, J )
               IJ = IJ + 1
  110       CONTINUE
C
  120    CONTINUE
C
      END IF
C
C     Block-scaling.
C
      ISCL = 0
      IF( QNORM2.GT.GNORM2 .AND. GNORM2.GT.ZERO ) THEN
         CALL DLASCL( UPLO, 0, 0, QNORM2, GNORM2, N, N, DWORK( INI+1 ),
     $                N2, INFO2 )
         CALL DLASCL( UPLO, 0, 0, GNORM2, QNORM2, N, N,
     $                DWORK( N2*N+N+INI+1 ), N2, INFO2 )
         ISCL = 1
      END IF
C
C     Compute the matrix sign function.
C
      DO 230 ITER = 1, MAXIT
C
C        Save the transpose of the corresponding triangle of the
C        current iterate in the free locations of the shifted opposite
C        triangle.
C        Workspace: need   4*N*N + 2*N.
C
         IF( LOWER ) THEN
C
            DO 130 I = 1, N2
               CALL DCOPY( I, DWORK( I ), N2, DWORK( I*N2+1 ), 1 )
  130       CONTINUE
C
         ELSE
C
            DO 140 I = 1, N2
               CALL DCOPY( I, DWORK( I*N2+1 ), 1, DWORK( I ), N2 )
  140       CONTINUE
C
         END IF
C
C        Store the norm of the Hamiltonian matrix.
C
         HNORM = DLANSY( 'F', UPLO, N2, DWORK( INI+1 ), N2, DWORK )
C
C        Compute the inverse of the block-permuted Hamiltonian matrix.
C        Workspace: need   4*N*N + 2*N + 1;
C                   prefer 4*N*N + 2*N + 2*N*NB.
C
         CALL DSYTRF( UPLO, N2, DWORK( INI+1 ), N2, IWORK,
     $                DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 )
         IF( INFO2.GT.0 ) THEN
            INFO = 1
            RETURN
         END IF
         LWAMAX = MAX( LWAMAX, IWRK + INT( DWORK( IWRK+1 ) ) )
C
C        Workspace: need   4*N*N + 4*N.
C
         CALL DSYTRI( UPLO, N2, DWORK( INI+1 ), N2, IWORK,
     $                DWORK( IWRK+1 ), INFO2 )
C
C        Block-permutation of the inverse matrix.
C
         IF( LOWER ) THEN
C
            DO 160 J = 1, N
               IJ2 = ( N + J - 1 )*N2 + N + J
C
               DO 150 IJ1 = ( J - 1 )*N2 + J, ( J - 1 )*N2 + N
                  TEMP = DWORK( IJ1 )
                  DWORK( IJ1 ) = -DWORK( IJ2 )
                  DWORK( IJ2 ) = -TEMP
                  IJ2 = IJ2 + 1
  150          CONTINUE
C
               CALL DSWAP( J-1, DWORK( N+J ), N2, DWORK( (J-1)*N2+N+1 ),
     $                     1 )
  160       CONTINUE
C
         ELSE
C
            DO 180 J = 1, N
               IJ2 = ( N + J )*N2 + N + 1
C
               DO 170 IJ1 = J*N2 + 1, J*N2 + J
                  TEMP = DWORK( IJ1 )
                  DWORK( IJ1 ) = -DWORK( IJ2 )
                  DWORK( IJ2 ) = -TEMP
                  IJ2 = IJ2 + 1
  170          CONTINUE
C
               CALL DSWAP( J-1, DWORK( (N+1)*N2+J ), N2,
     $                     DWORK( (N+J)*N2+1 ), 1 )
  180       CONTINUE
C
         END IF
C
C        Scale the Hamiltonian matrix and its inverse and compute
C        the next iterate.
C
         HINNRM = DLANSY( 'F', UPLO, N2, DWORK( INI+1 ), N2, DWORK )
         SCALE  = SQRT( HINNRM / HNORM )
C
         IF( LOWER ) THEN
C
            DO 200 J = 1, N2
               JI = ( J - 1 )*N2 + J
C
               DO 190 IJ = JI, J*N2
                  JI = JI + N2
                  DWORK( IJ ) = ( DWORK( IJ ) / SCALE +
     $                            DWORK( JI )*SCALE ) / TWO
                  DWORK( JI ) =   DWORK( JI ) - DWORK( IJ )
  190          CONTINUE
C
  200       CONTINUE
C
         ELSE
C
            DO 220 J = 1, N2
               JI = J
C
               DO 210 IJ = J*N2 + 1, J*N2 + J
                  DWORK( IJ ) = ( DWORK( IJ ) / SCALE +
     $                            DWORK( JI )*SCALE ) / TWO
                  DWORK( JI ) =   DWORK( JI ) - DWORK( IJ )
                  JI = JI + N2
  210          CONTINUE
C
  220       CONTINUE
C
         END IF
C
C        Test for convergence.
C
         CONV = DLANSY( 'F', LOUP, N2, DWORK( ISV+1 ), N2, DWORK )
         IF( CONV.LE.TOL*HNORM ) GO TO 240
  230 CONTINUE
C
C     No convergence after MAXIT iterations, but an approximate solution
C     has been found.
C
      INFO = 2
C
  240 CONTINUE
C
C     If UPLO = 'U', shift the upper triangle one column to the left.
C
      IF( .NOT.LOWER )
     $   CALL DLACPY( 'U', N2, N2, DWORK( INI+1 ), N2, DWORK, N2 )
C
C     Divide the triangle elements by -2 and then fill-in the other
C     triangle by symmetry.
C
      IF( LOWER ) THEN
C
         DO 250 I = 1, N2
            CALL DSCAL( N2-I+1, -HALF, DWORK( (I-1)*N2+I ), 1 )
  250    CONTINUE
C
      ELSE
C
         DO 260 I = 1, N2
            CALL DSCAL( I, -HALF, DWORK( (I-1)*N2+1 ), 1 )
  260    CONTINUE
C
      END IF
      CALL MA02ED( UPLO, N2, DWORK, N2 )
C
C     Back block-permutation.
C
      DO 280 J = 1, N2
C
         DO 270 I = ( J - 1 )*N2 + 1, ( J - 1 )*N2 + N
            TEMP = DWORK( I )
            DWORK( I )   = -DWORK( I+N )
            DWORK( I+N ) = TEMP
  270    CONTINUE
C
  280 CONTINUE
C
C     Compute the QR decomposition of the projector onto the stable
C     invariant subspace.
C     Workspace: need   4*N*N + 8*N + 1.
C                prefer 4*N*N + 6*N + ( 2*N+1 )*NB.
C
      DO 290 I = 1, N2
         IWORK( I ) = 0
         DWORK( ( I-1 )*N2 + I ) = DWORK( ( I-1 )*N2 + I ) + HALF
  290 CONTINUE
C
      CALL DGEQP3( N2, N2, DWORK, N2, IWORK, DWORK( ITAU+1 ),
     $             DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 )
      LWAMAX = MAX( LWAMAX, IWRK + INT( DWORK( IWRK+1 ) ) )
C
C     Accumulate the orthogonal transformations. Note that only the
C     first N columns of the array DWORK, returned by DGEQP3, are
C     needed, so that the last N columns of DWORK are used to get the
C     orthogonal basis for the stable invariant subspace.
C     Workspace: need   4*N*N + 3*N.
C                prefer 4*N*N + 2*N + N*NB.
C
      IB  = N*N
      IAF = N2*N
      CALL DLASET( 'F', N2, N, ZERO, ONE, DWORK( IAF+1 ), N2 )
      CALL DORMQR( 'L', 'N', N2, N, N, DWORK, N2, DWORK( ITAU+1 ),
     $             DWORK( IAF+1 ), N2, DWORK( IWRK+1 ), LDWORK-IWRK,
     $             INFO2 )
      LWAMAX = MAX( LWAMAX, IWRK + INT( DWORK( IWRK+1 ) ) )
C
C     Store the matrices V11 and V21' .
C
      CALL DLACPY( 'F', N, N, DWORK( IAF+1 ), N2, DWORK, N )
      CALL MA02AD( 'F', N, N, DWORK( IAF+N+1 ), N2, DWORK( IB+1 ), N )
C
      IR   = IAF + IB
      IC   = IR  + N
      IFR  = IC  + N
      IBR  = IFR + N
      IWRK = IBR + N
C
C     Compute the solution matrix X .
C     Workspace: need   3*N*N + 8*N.
C
      CALL DGESVX( 'E', 'T', N, N, DWORK, N, DWORK( IAF+1 ), N,
     $             IWORK, EQUED, DWORK( IR+1 ), DWORK( IC+1 ),
     $             DWORK( IB+1 ), N, X, LDX, RCOND, DWORK( IFR+1 ),
     $             DWORK( IBR+1 ), DWORK( IWRK+1 ), IWORK( N+1 ),
     $             INFO2 )
      IF( INFO2.GT.0 ) THEN
         INFO = 3
         RETURN
      END IF
C
C     Symmetrize the solution.
C
      DO 310 I = 1, N - 1
C
         DO 300 J = I + 1, N
            TEMP = ( X( I, J ) + X( J, I ) ) / TWO
            X( I, J ) = TEMP
            X( J, I ) = TEMP
  300    CONTINUE
C
  310 CONTINUE
C
C     Undo scaling for the solution matrix.
C
      IF( ISCL.EQ.1 ) THEN
         CALL DLASCL( 'G', 0, 0, GNORM2, QNORM2, N, N, X, LDX, INFO2 )
      END IF
C
      IF( ALL ) THEN
C
C        Compute the estimates of the reciprocal condition number and
C        error bound.
C        Workspace usage.
C
         IT   = 0
         IU   = IT + N*N
         IWRK = IU + N*N
C
         CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IT+1 ), N )
         IF( NOTRNA ) THEN
C
C           Compute Ac = A-G*X .
C
            CALL DSYMM( 'L', UPLO, N, N, -ONE, G, LDG, X, LDX, ONE,
     $                  DWORK( IT+1 ), N )
         ELSE
C
C           Compute Ac = A-X*G .
C
            CALL DSYMM( 'R', UPLO, N, N, -ONE, G, LDG, X, LDX, ONE,
     $                  DWORK( IT+1 ), N )
         END IF
C
C        Compute the Schur factorization of Ac .
C        Workspace: need   2*N*N + 5*N;
C                   prefer larger.
C
         CALL DGEES( 'V', 'N', SELECT, N, DWORK( IT+1 ), N, SDIM, WR,
     $               WI, DWORK( IU+1 ), N, DWORK( IWRK+1 ), LDWORK-IWRK,
     $               BWORK, INFO2 )
         IF( INFO2.GT.0 ) THEN
            INFO = 4
            RETURN
         END IF
         LWAMAX = MAX( LWAMAX, IWRK + INT( DWORK( IWRK+1 ) ) )
C
C        Estimate the reciprocal condition number and the forward error.
C        Workspace: need   6*N*N;
C                   prefer larger.
C
         CALL SB02QD( 'B', 'F', TRANA, UPLO, 'O', N, A, LDA,
     $                DWORK( IT+1 ), N, DWORK( IU+1 ), N, G, LDG, Q,
     $                LDQ, X, LDX, SEP, RCOND, FERR, IWORK,
     $                DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 )
         LWAMAX = MAX( LWAMAX, IWRK + INT( DWORK( IWRK+1 ) ) )
      END IF
C
      DWORK( 1 ) = DBLE( LWAMAX )
      RETURN
C *** Last line of SB02PD
      END


C A very simple implementation of a 2D wave equation solver,
C aimed at testing high-performance computing techniques.
C To make the code as simple as possible, the initial condition
C is implemented in a rough way.

      PROGRAM wave2D
      INTEGER n, nsteps
      PARAMETER (n=501)
C      PARAMETER (n=101)

      REAL*8 up(n,n), u(n,n), um(n,n), lambda(n,n)
      REAL*8 dt, tstop, delta
C     domain has size 10x10 in x and y direction
C     delta is the cell size:
      delta = 10.0/(n-1)

      dt = SQRT(1.0/(1.0/(delta*delta) + 1.0/(delta*delta)))
C     dt = delta
      write(*,*) 'Give number of time steps:'
      read(*,*) nsteps
      tstop = nsteps*dt
      write(*,*) 'time step =',dt
      call timeloop(up, u, um, lambda, n, tstop, dt)

      END

C     function for coefficient in the wave equation ("lambda"):
      REAL*8 FUNCTION h(x, y)
      REAL*8 x,y
      h = 1.0
      RETURN
      END

C     initial surface shape:
      REAL*8 FUNCTION bell(x, y)
      REAL*8 x,y
      bell = exp(-x*x - y*y)
      RETURN
      END

      SUBROUTINE setIC(u, um, lambda, n)
C     set initial conditions (rough approximations)
C     set lambda values as well
      INTEGER n
      REAL*8 u(n,n), um(n,n), lambda(n,n)
      INTEGER i, j
      REAL*8 x, y, delta, bell, h
C     domain has size 10x10 in x and y direction
C     delta is the cell size:
      delta = 10.0/(n-1)

      DO 20 j=1,n
         DO 10 i=1,n
            x = (i-1)*delta
            y = (j-1)*delta
            u(i,j) = bell(x,y)
C           this is a rough approximation to du/dt=0:
            um(i,j) = u(i,j)

C           initialize the variable coefficient as an array:
            lambda(i,j) = h(x,y)
 10      CONTINUE
 20   CONTINUE
      RETURN
      END

      SUBROUTINE timeloop(up, u, um, lambda, n, tstop, dt)
      INTEGER n
      REAL*8 up(n,n), u(n,n), um(n,n), lambda(n,n)
      REAL*8 tstop, dt, t
      INTEGER nsteps, timelevel
      REAL*8 x, y, delta, bell, h, a, b, c
C     domain has size 10x10 in x and y direction
C     delta is the cell size:
      delta = 10.0/(n-1)
      nsteps = int(tstop/dt)

      t = 0
      call setIC(u, um, lambda, n)
      call dump(u, n, 0)
      a = 1.0
      b = 1.0
      c = 1.0

      DO 30 timelevel=1,nsteps
         t = t + dt
         write(*,*) 'time level', timelevel
         call F77WAVE(up, u, um, lambda, a, b, c, n, n, dt,
     &                delta, delta)
C        update for next step:
         DO 20 j=1,n
            DO 10 i=1,n
               um(i,j) = u(i,j)
               u(i,j) = up(i,j)
 10         CONTINUE
 20      CONTINUE
         call dump(u, n, timelevel)
 30   CONTINUE
      RETURN
      END

C     dump solution in plotmtv format:
      SUBROUTINE dump(u, n, timelevel)
      INTEGER n, i, j, timelevel, iunit
      REAL*8 u(n,n)
      CHARACTER*40 filename
      WRITE(filename,1000) 'tmp_',timelevel,'.mtv'
 1000 FORMAT(A,I5.5,A)
      iunit = 20
      OPEN(iunit, FILE=filename, STATUS='UNKNOWN', FORM='FORMATTED')
      WRITE(iunit,*) '$ DATA=CONTOUR'
      WRITE(iunit,*) '% contstyle=2 nsteps=30 nx=',n,' ny=',n,
     & ' xmin=0 xmax=10 ymin=0 ymax=10'
      WRITE(iunit,*) '% cmin=-0.2 cmax=0.4 zmin=-0.2 zmax=0.6'
      WRITE(iunit,*) '% leftworld=False'
      WRITE(iunit,*) '% eyepos.x=0.5 eyepos.y=-1.5 eyepos.z=0.5'
      DO 20 j=1,n
         DO 10 i=1,n
            WRITE(iunit,*) u(i,j)
 10      CONTINUE
 20   CONTINUE
      CLOSE(iunit)
      RETURN
      END


      Program fpgrid

c     Creates a grid for a laminar boundary layer on a flat plate.

      parameter ( nimax = 200 )
      parameter ( njmax = 100 )

      dimension x (nimax,njmax)
      dimension y (nimax,njmax)

      dimension eta (njmax)

c.....Get grid parameters.

      fplen = 1.0
      xin   = - 0.25

      write(*,*) ' '
      write(*,*) 'Enter axial grid spacing (ft)' !0.025
      read(*,*) spax

      write(*,*) ' '
      write(*,*) 'Enter wall spacing (in terms of eta)' !0.4
      read (*,*) spwall

c.....Create an evenly-spaced axial grid.

      nia = 0.25 / spax + 1
      nib = 4 * nia - 3
      ni  = nia + nib - 1

      write(*,*) ' '
      write(*,*) 'Number of axial grid points: ', ni
      write(*,*) 'Leading edge is at i = ', nia

      x(1,1) = xin
      do  i = 2, nia
        x(i,1) = x(i-1,1) + spax
      enddo
      x(nia,1) = 0.0

      do  i = 2, nib
        ix = nia + i - 1
        x(ix,1) = x(ix-1,1) + spax
      enddo
      x(ni,1) = fplen

      do  i = 1, ni
        write(*,*) i, x(i,1)
      enddo

c.....Create the eta distribution.

      eta(1) = 0.0
      ibl    = 0

      do  j = 2, njmax
        if ( ibl .eq. 0 ) then
          eta(j) = eta(j-1) + spwall
          if ( eta(j) .ge. 4.0 )  ibl = 1
        else
          eta(j) = eta(j-1) + 1.1 * ( eta(j-1) - eta(j-2) )
        endif
        if ( eta(j) .gt. 50 )  go to 10
      enddo

      write(*,*) ' '
      write(*,*) 'Warning: njmax reached'

   10 continue

      nj = j

      write(*,*) ' '
      write(*,*) 'Number of wall normal grid points: ', nj

      do  j = 1, nj
        write(*,*) j, eta(j)
      enddo

c.....Create the x-coordinates for entire grid.

      do  i = 1, ni
        do  j = 2, nj
          x(i,j) = x(i,1)
        enddo
      enddo

c.....Create the y grid coordinates starting at about x = 0.25.

      istart = ni * 2 / 5 + 1

      ufs    = 129.6974
      dynvis = 6.4849819E-04

      do  i = istart, ni
        do  j = 1, nj
          y(i,j) = eta(j) / sqrt( 0.5 * ufs / ( dynvis * x(i,j) ) )
        enddo
      enddo

c.....For i = 1, istart-1, use the y-coordinates at istart.

      do  i = 1, istart
        do  j = 1, nj
          y(i,j) = y(istart,j)
        enddo
      enddo

c.....Write out the grid to a Plot3d file.

c.....open ( unit=7, file='fplam.d', form='formatted', status='unknown' )
      open ( unit=7, file='fplam.txt', form='formatted' )
      write(7, *) ni, nj
      write(7, *) (( x(i,j), i=1,ni), j=1,nj),
     &         (( y(i,j), i=1,ni), j=1,nj)

      stop
      end


*DECK DGBCO
      SUBROUTINE DGBCO (ABD, LDA, N, ML, MU, IPVT, RCOND, Z)
C***BEGIN PROLOGUE  DGBCO
C***PURPOSE  Factor a band matrix by Gaussian elimination and
C            estimate the condition number of the matrix.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2A2
C***TYPE      DOUBLE PRECISION (SGBCO-S, DGBCO-D, CGBCO-C)
C***KEYWORDS  BANDED, CONDITION NUMBER, LINEAR ALGEBRA, LINPACK,
C             MATRIX FACTORIZATION
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     DGBCO factors a double precision band matrix by Gaussian
C     elimination and estimates the condition of the matrix.
C
C     If  RCOND  is not needed, DGBFA is slightly faster.
C     To solve  A*X = B , follow DGBCO by DGBSL.
C     To compute  INVERSE(A)*C , follow DGBCO by DGBSL.
C     To compute  DETERMINANT(A) , follow DGBCO by DGBDI.
C
C     On Entry
C
C        ABD     DOUBLE PRECISION(LDA, N)
C                contains the matrix in band storage.  The columns
C                of the matrix are stored in the columns of  ABD  and
C                the diagonals of the matrix are stored in rows
C                ML+1 through 2*ML+MU+1 of  ABD .
C                See the comments below for details.
C
C        LDA     INTEGER
C                the leading dimension of the array  ABD .
C                LDA must be .GE. 2*ML + MU + 1 .
C
C        N       INTEGER
C                the order of the original matrix.
C
C        ML      INTEGER
C                number of diagonals below the main diagonal.
C                0 .LE. ML .LT.  N .
C
C        MU      INTEGER
C                number of diagonals above the main diagonal.
C                0 .LE. MU .LT.  N .
C                More efficient if  ML .LE. MU .
C
C     On Return
C
C        ABD     an upper triangular matrix in band storage and
C                the multipliers which were used to obtain it.
C                The factorization can be written  A = L*U  where
C                L  is a product of permutation and unit lower
C                triangular matrices and  U  is upper triangular.
C
C        IPVT    INTEGER(N)
C                an integer vector of pivot indices.
C
C        RCOND   DOUBLE PRECISION
C                an estimate of the reciprocal condition of  A .
C                For the system  A*X = B , relative perturbations
C                in  A  and  B  of size  EPSILON  may cause
C                relative perturbations in  X  of size  EPSILON/RCOND .
C                If  RCOND  is so small that the logical expression
C                           1.0 + RCOND .EQ. 1.0
C                is true, then  A  may be singular to working
C                precision.  In particular,  RCOND  is zero  if
C                exact singularity is detected or the estimate
C                underflows.
C
C        Z       DOUBLE PRECISION(N)
C                a work vector whose contents are usually unimportant.
C                If  A  is close to a singular matrix, then  Z  is
C                an approximate null vector in the sense that
C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
C
C     Band Storage
C
C           If  A  is a band matrix, the following program segment
C           will set up the input.
C
C                   ML = (band width below the diagonal)
C                   MU = (band width above the diagonal)
C                   M = ML + MU + 1
C                   DO 20 J = 1, N
C                      I1 = MAX(1, J-MU)
C                      I2 = MIN(N, J+ML)
C                      DO 10 I = I1, I2
C                         K = I - J + M
C                         ABD(K,J) = A(I,J)
C                10    CONTINUE
C                20 CONTINUE
C
C           This uses rows  ML+1  through  2*ML+MU+1  of  ABD .
C           In addition, the first  ML  rows in  ABD  are used for
C           elements generated during the triangularization.
C           The total number of rows needed in  ABD  is  2*ML+MU+1 .
C           The  ML+MU by ML+MU  upper left triangle and the
C           ML by ML  lower right triangle are not referenced.
C
C     Example:  If the original matrix is
C
C           11 12 13  0  0  0
C           21 22 23 24  0  0
C            0 32 33 34 35  0
C            0  0 43 44 45 46
C            0  0  0 54 55 56
C            0  0  0  0 65 66
C
C      then  N = 6, ML = 1, MU = 2, LDA .GE. 5  and ABD should contain
C
C            *  *  *  +  +  +  , * = not used
C            *  * 13 24 35 46  , + = used for pivoting
C            * 12 23 34 45 56
C           11 22 33 44 55 66
C           21 32 43 54 65  *
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  DASUM, DAXPY, DDOT, DGBFA, DSCAL
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DGBCO
      INTEGER LDA,N,ML,MU,IPVT(*)
      DOUBLE PRECISION ABD(LDA,*),Z(*)
      DOUBLE PRECISION RCOND
C
      DOUBLE PRECISION DDOT,EK,T,WK,WKM
      DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM
      INTEGER IS,INFO,J,JU,K,KB,KP1,L,LA,LM,LZ,M,MM
C
C     COMPUTE 1-NORM OF A
C
C***FIRST EXECUTABLE STATEMENT  DGBCO
      ANORM = 0.0D0
      L = ML + 1
      IS = L + MU
      DO 10 J = 1, N
         ANORM = MAX(ANORM,DASUM(L,ABD(IS,J),1))
         IF (IS .GT. ML + 1) IS = IS - 1
         IF (J .LE. MU) L = L + 1
         IF (J .GE. N - ML) L = L - 1
   10 CONTINUE
C
C     FACTOR
C
      CALL DGBFA(ABD,LDA,N,ML,MU,IPVT,INFO)
C
C     RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  TRANS(A)*Y = E .
C     TRANS(A)  IS THE TRANSPOSE OF A .  THE COMPONENTS OF  E  ARE
C     CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W  WHERE
C     TRANS(U)*W = E .  THE VECTORS ARE FREQUENTLY RESCALED TO AVOID
C     OVERFLOW.
C
C     SOLVE TRANS(U)*W = E
C
      EK = 1.0D0
      DO 20 J = 1, N
         Z(J) = 0.0D0
   20 CONTINUE
      M = ML + MU + 1
      JU = 0
      DO 100 K = 1, N
         IF (Z(K) .NE. 0.0D0) EK = SIGN(EK,-Z(K))
         IF (ABS(EK-Z(K)) .LE. ABS(ABD(M,K))) GO TO 30
            S = ABS(ABD(M,K))/ABS(EK-Z(K))
            CALL DSCAL(N,S,Z,1)
            EK = S*EK
   30    CONTINUE
         WK = EK - Z(K)
         WKM = -EK - Z(K)
         S = ABS(WK)
         SM = ABS(WKM)
         IF (ABD(M,K) .EQ. 0.0D0) GO TO 40
            WK = WK/ABD(M,K)
            WKM = WKM/ABD(M,K)
         GO TO 50
   40    CONTINUE
            WK = 1.0D0
            WKM = 1.0D0
   50    CONTINUE
         KP1 = K + 1
         JU = MIN(MAX(JU,MU+IPVT(K)),N)
         MM = M
         IF (KP1 .GT. JU) GO TO 90
            DO 60 J = KP1, JU
               MM = MM - 1
               SM = SM + ABS(Z(J)+WKM*ABD(MM,J))
               Z(J) = Z(J) + WK*ABD(MM,J)
               S = S + ABS(Z(J))
   60       CONTINUE
            IF (S .GE. SM) GO TO 80
               T = WKM - WK
               WK = WKM
               MM = M
               DO 70 J = KP1, JU
                  MM = MM - 1
                  Z(J) = Z(J) + T*ABD(MM,J)
   70          CONTINUE
   80       CONTINUE
   90    CONTINUE
         Z(K) = WK
  100 CONTINUE
      S = 1.0D0/DASUM(N,Z,1)
      CALL DSCAL(N,S,Z,1)
C
C     SOLVE TRANS(L)*Y = W
C
      DO 120 KB = 1, N
         K = N + 1 - KB
         LM = MIN(ML,N-K)
         IF (K .LT. N) Z(K) = Z(K) + DDOT(LM,ABD(M+1,K),1,Z(K+1),1)
         IF (ABS(Z(K)) .LE. 1.0D0) GO TO 110
            S = 1.0D0/ABS(Z(K))
            CALL DSCAL(N,S,Z,1)
  110    CONTINUE
         L = IPVT(K)
         T = Z(L)
         Z(L) = Z(K)
         Z(K) = T
  120 CONTINUE
      S = 1.0D0/DASUM(N,Z,1)
      CALL DSCAL(N,S,Z,1)
C
      YNORM = 1.0D0
C
C     SOLVE L*V = Y
C
      DO 140 K = 1, N
         L = IPVT(K)
         T = Z(L)
         Z(L) = Z(K)
         Z(K) = T
         LM = MIN(ML,N-K)
         IF (K .LT. N) CALL DAXPY(LM,T,ABD(M+1,K),1,Z(K+1),1)
         IF (ABS(Z(K)) .LE. 1.0D0) GO TO 130
            S = 1.0D0/ABS(Z(K))
            CALL DSCAL(N,S,Z,1)
            YNORM = S*YNORM
  130    CONTINUE
  140 CONTINUE
      S = 1.0D0/DASUM(N,Z,1)
      CALL DSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
C     SOLVE  U*Z = W
C
      DO 160 KB = 1, N
         K = N + 1 - KB
         IF (ABS(Z(K)) .LE. ABS(ABD(M,K))) GO TO 150
            S = ABS(ABD(M,K))/ABS(Z(K))
            CALL DSCAL(N,S,Z,1)
            YNORM = S*YNORM
  150    CONTINUE
         IF (ABD(M,K) .NE. 0.0D0) Z(K) = Z(K)/ABD(M,K)
         IF (ABD(M,K) .EQ. 0.0D0) Z(K) = 1.0D0
         LM = MIN(K,M) - 1
         LA = M - LM
         LZ = K - LM
         T = -Z(K)
         CALL DAXPY(LM,T,ABD(LA,K),1,Z(LZ),1)
  160 CONTINUE
C     MAKE ZNORM = 1.0
      S = 1.0D0/DASUM(N,Z,1)
      CALL DSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
      IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM
      IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0
      RETURN
      END


! =====================================================
subroutine rpn2(ixy,maxm,meqn,mwaves,maux,mbc,mx,ql,qr,auxl,auxr,wave,s,amdq,apdq)
! =====================================================

! Aproximate Riemann solver for the nonlinear KPP system:

! q_t + sin(q)_x + cos(q)_y = 0

! waves: 1
! equations: 1

! Conserved quantities:
!       1 q

! Solve Riemann problems along one slice of data:
!  in the x-direction if ixy=1
!  in the y-direction if ixy=2.

! On input, ql contains the state vector at the left edge of each cell
!           qr contains the state vector at the right edge of each cell

! On output, wave contains the waves,
!            s the speeds,
!            amdq the  left-going fluctuation
!            apdq the right-going fluctuation

! Note that the i'th Riemann problem has left state qr(i-1,:)
!                                    and right state ql(i,:)
! From the basic clawpack routines, this routine is called with ql = qr

!      implicit none

    double precision :: ul, ur, fl, fr, fedge, pi, reml, remr
    integer :: i, ixy, maxm, meqn, mwaves, mbc, mx

    double precision :: wave(meqn,mwaves,1-mbc:maxm+mbc)
    double precision ::    s(mwaves,     1-mbc:maxm+mbc)
    double precision ::   ql(meqn,       1-mbc:maxm+mbc)
    double precision ::   qr(meqn,       1-mbc:maxm+mbc)
    double precision :: apdq(meqn,       1-mbc:maxm+mbc)
    double precision :: amdq(meqn,       1-mbc:maxm+mbc)

    pi=4.d0*datan(1.d0)

    do i=2-mbc,mx+mbc

        ul = qr(1,i-1)
        ur = ql(1,i  )

        if (ixy == 1) then
            fl = dsin(ul)
            fr = dsin(ur)

        ! The flux fedge at the cell interface is obtained by
        ! minimizing or maximizing the function sin(q) over the
        ! interval between the left and right states.

            if (ul < ur) then
            ! inimum
                fedge = dmin1(fl,fr)
                if (ur-ul > 2.d0*pi) then
                    fedge=-1.d0
                else
                    reml = dmod(ul,2.d0*pi)
                    remr = dmod(ur,2.d0*pi)
                    if (remr > 1.5d0*pi .AND. reml < 1.5d0*pi) then
                        fedge=-1.d0
                    elseif (ur-ul > remr+0.5d0*pi) then
                        fedge=-1.d0
                    endif
                endif
            else
            ! aximum
                fedge = dmax1(fl,fr)
                if (ul-ur > 2.d0*pi) then
                    fedge=1.d0
                else
                    reml = dmod(ul,2.d0*pi)
                    remr = dmod(ur,2.d0*pi)
                    if (reml > 0.5d0*pi .AND. remr < 0.5d0*pi) then
                        fedge=1.d0
                    elseif (ul-ur > reml+1.5d0*pi) then
                        fedge=1.d0
                    endif
                endif
            endif
        else ! ixy == 2
            fl = dcos(ul)
            fr = dcos(ur)

        ! The flux fedge at the cell interface is obtained by
        ! minimizing or maximizing the function cos(q) over the
        ! interval between the left and right states.

            if (ul < ur) then
            ! inimum
                fedge = dmin1(fl,fr)
                if (ur-ul > 2.d0*pi) then
                    fedge=-1.d0
                else
                    reml = dmod(ul,2.d0*pi)
                    remr = dmod(ur,2.d0*pi)
                    if (remr > 1.d0*pi .AND. reml < 1.d0*pi) then
                        fedge=-1.d0
                    elseif (ur-ul > remr+1.d0*pi) then
                        fedge=-1.d0
                    endif
                endif
            else
            ! aximum
                fedge = dmax1(fl,fr)
                if (ul-ur > 2.d0*pi) then
                    fedge=1.d0
                else
                    reml = dmod(ul,2.d0*pi)
                    remr = dmod(ur,2.d0*pi)
                    if (reml < remr) then
                        fedge=1.d0
                    endif
                endif
            endif
        endif

        if (ul /= ur) then
        ! ecant approximation
            s(1,i) = (fr-fl)/(ur-ul)
        else
            s(1,i) = 0.d0
        endif

        wave(1,1,i) = ur-ul

        amdq(1,i)= fedge - fl
        apdq(1,i)= fr - fedge

    enddo

    return
    end subroutine rpn2


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cc                                                                    cc
cc                mncurf : curfit test program                        cc
cc                                                                    cc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      real x(25),y(25),w(25),t(35),c(35),wrk(1000),sp(25)
      integer iwrk(35)
      real ai,fp,s,xb,xe
      integer i,ier,iopt,is,j,k,l,lwrk,l1,l2,m,n,nest,nk1
c  the ordinate values of the data points
      data y(1),y(2),y(3),y(4),y(5),y(6),y(7),y(8),y(9),y(10),y(11),
     * y(12),y(13),y(14),y(15),y(16),y(17),y(18),y(19),y(20),y(21),
     * y(22),y(23),y(24),y(25)/1.0,1.0,1.4,1.1,1.0,1.0,4.0,9.0,13.0,
     * 13.4,12.8,13.1,13.0,14.0,13.0,13.5,10.0,2.0,3.0,2.5,2.5,2.5,
     * 3.0,4.0,3.5/
c  m denotes the number of data points
      m = 25
c  we set up the abscissae and weights of the data points
      do 10 i=1,m
         ai = i-1
         x(i) = ai
         w(i) = 1.0
  10  continue
c  we set up the boundaries of the approximation interval
      xb = x(1)
      xe = x(m)
c  we set up the dimension information.
      nest = 35
      lwrk = 1000
c  loop for the different spline degrees.
      do 400 k=3,5,2
c  loop for the different spline approximations of degree k
         do 300 is=1,7
            go to (110,120,130,140,150,160,170),is
c  we start computing the least-squares polynomial (large value for s).
 110        iopt = 0
            s = 1000.
            go to 200
c  iopt=1 from the second call on
 120        iopt = 1
            s = 60.
            go to 200
c  a smaller value for s to get a closer approximation
 130        s = 10.
            go to 200
c  a larger value for s to get a smoother approximation
 140        s = 30.
            go to 200
c  if a satisfactory fit is obtained  we can calculate a spline of equal
c  quality of fit ( same value for s ) but possibly with fewer knots by
c  specifying iopt=0
 150        s = 30.
            iopt = 0
            go to 200
c  we calculate an interpolating spline
 160        s = 0.
            go to 200
c  finally, we also calculate a least-squares spline function with
c  specified knots
 170        iopt = -1
            j = k+2
            do 180 l=1,7
               ai =3*l
               t(j) = ai
               j = j+1
 180        continue
            n = 9+2*k
 200        call curfit(iopt,m,x,y,w,xb,xe,k,s,nest,n,t,c,fp,wrk,lwrk,
     *       iwrk,ier)
c  printing of the results.
            if(iopt.ge.0) go to 210
            write(6,910) k
            go to 220
 210        write(6,915) k
            write(6,920) s
 220        write(6,925) fp,ier
            write(6,930) n
            write(6,935)
            write(6,940) (t(i),i=1,n)
            nk1 = n-k-1
            write(6,945)
            write(6,950) (c(i),i=1,nk1)
            write(6,955)
c  evaluation of the spline approximation
            call splev(t,n,c,k,x,sp,m,ier)
            do 230 i=1,5
               l1 = (i-1)*5+1
               l2 = l1+4
               write(6,960) (x(l),y(l),sp(l),l=l1,l2)
 230        continue
 300     continue
 400  continue
      stop
 910  format(32h0least-squares spline of degree ,i1)
 915  format(28h0smoothing spline of degree ,i1)
 920  format(20h smoothing factor s=,f5.0)
 925  format(1x,23hsum squared residuals =,e15.6,5x,11herror flag=,i2)
 930  format(1x,24htotal number of knots n=,i3)
 935  format(1x,22hposition of the knots )
 940  format(5x,12f6.1)
 945  format(23h0b-spline coefficients )
 950  format(5x,8f9.4)
 955  format(1h0,5(1x,2hxi,3x,2hyi,2x,5hs(xi),1x))
 960  format(1h ,5(f4.1,1x,f4.1,1x,f4.1,2x))
      end


	subroutine sub_expav2l(time_const1,time_const2,srate,isize,
     $                                  rarray,outmax)

c sub_expav2 without the output array

c Based on graf::dkb0:[sullivan.boom3]expav2c.pro - July 20 1994
c
c; 2-time-constant exponential average - Averaging pressure of A-weighted boom?!
c; one (time_const1) for rising signals, another (time_const2) for decaying.
c; Version 3 = Feb 1 1994
c; Method courtesy of B&K - 2131 Instruction Manual - but they only have one!
c;
c input variables
c    time_const1 = time constant for averaging increasing (abs.) signals
c    time_const2 = time constant for averaging decaying (abs.) signals
c    srate = sample rate of signal array
c               make sure these three are in the same units!
c    isize = number of points in input array
c    rarray = signal array
c output variables
c    outmax = maximum value
c
	real rarray(1),output(2),konstant1,konstant2,normf,normf2,
     $                                 outmax
c
c;time interval between samples is 1/srate (eg 0.000026 secs = .026 msecs)
	tinterval = 1./srate
c
c;time constant = Konstant * tinterval  (according to B&K) (eg 2 msec)
c;              = Konstant / srate
c;     Konstant = time constant * srate = time constant / tinterval
c;             ~= number of samples per Averaging Time
c
	konstant1 = time_const1/tinterval
	konstant2 = time_const2/tinterval
c;
c; apparently I need some kind of normalization factor - squared or not?
c	normf = max(abs(rarray))
	normf = abs(rarray(1))
	do i=2,isize
	   normf = max(normf,rarray(i))
	enddo
	normf2 = normf*normf
c	array = rarray**2/normf2

c;present average=previous average+("volts squared"-previous average)/Konstant
c	output(1) = array(1)**2/konstant1
	output(1) = (rarray(1)**2/normf2)/konstant1
	outmax = output(1)
	do i=2,isize
           valnow=rarray(i)**2/normf2
	   if (valnow .gt. output(1)) then
	      output(2) = output(1) + (valnow - output(1))/konstant1
	   else
	      output(2) = output(1) + (valnow - output(1))/konstant2
	   endif
	   outmax = max(outmax,output(2))
	   output(1) = output(2)
	enddo

	outmax = outmax*normf2

	return
	end


      subroutine axafs(em, emu, xsec,ne1,ik0)
c     extract axafs from xsec
c     written by a.l.ankudinov Dec. 1998

c     the file axafs.dat (format as in xmu.dat) will be written if
c     you use PRINT 0 1 0 0 0 0 (ipr2 > 0), and ran the second module.

c     the code draws a parabola using least mean square method
c     through xsec(i) * ee (i)**xn
c     the weight for each point i, is defined as (ee(i)-E_F)**mm*
c     (ee(i+1)- ee(i-1)), where the last multiplier is used since the
c     grid is not regular in energy.
c     E_F - energy that corresponds to Fermi level.

      implicit double precision (a-h, o-z)
      include '../HEADERS/dim.h'
      include '../HEADERS/const.h'

      complex*16 em(nex), xsec(nex)
      dimension ee(nex), xmu(nex), wt(nex)
      dimension xx(0:4), yy(0:2), xm(3,3)

c     empirically I found that the best curve is drawn if xn=0 and mm=1
c     alex ankudinov, january 1999.
      xn = 0
      mm = 1
      np = ne1 - ik0
      ef = emu

      do 10 ie = 1, np
        ee(ie) = dble(em(ik0+ie)-em(ik0)) +emu
        xmu(ie) = dimag(xsec(ik0+ie)) * ee(ie)**xn
  10  continue
      do 20 ie = 1, np
        if (ie.eq.1) then
          wt(ie) = (ee(ie+1)-ef) * (abs(ee(ie)-ef))**mm
        elseif (ie.eq.np) then
          wt(ie) = (ee(ie)-ee(ie-1)) * (ee(ie)-ef)**mm
        else
          wt(ie) = (ee(ie+1)-ee(ie-1)) * (ee(ie)-ef)**mm
        endif
  20  continue
      do 30 i = 0, 4
  30  xx(i) = 0
      do 40 i = 0, 2
  40  yy(i) = 0

      do 100 ie = 1, np
         do 80 i = 0,4
  80     xx(i) = xx(i) + wt(ie)*ee(ie)**i
         do 90 i = 0,2
  90     yy(i) = yy(i) + wt(ie)*xmu(ie)*ee(ie)**i
 100  continue

      do 105 i=1,3
      do 105 j=1,3
 105  xm(i,j) = xx(i+j-2)
      denom = determ (xm, 3, 3)

      do 110 i=1,3
      do 110 j=1,3
 110  xm(i,j) = xx(i+j-2)
      do 120 i=1,3
 120  xm(i,1) = yy (i-1)
      aa = determ (xm,3,3)
      aa = aa / denom

      do 210 i=1,3
      do 210 j=1,3
 210  xm(i,j) = xx(i+j-2)
      do 220 i=1,3
 220  xm(i,2) = yy (i-1)
      bb = determ (xm,3,3)
      bb = bb / denom

      do 310 i=1,3
      do 310 j=1,3
 310  xm(i,j) = xx(i+j-2)
      do 320 i=1,3
 320  xm(i,3) = yy (i-1)
      cc = determ (xm,3,3)
      cc = cc / denom

c     find normalization at edge+100 eV
      eee = ee(1) + 100/hart
      xnorm = (aa+bb*eee+cc*eee**2) / eee**xn

      open (unit=1,file='axafs.dat', status='unknown')
      write (1,*) '# File contains AXAFS. See manual for details.'
      write (1,*)
     1 '#--------------------------------------------------------------'
      write(1,*) '#  e, e(wrt edge), k,',
     1           ' mu_at=(1+chi_at)*mu0_at, mu0_at, chi_at @#'
      do 400 ie = 1, np
        xmu(ie) = dimag(xsec(ie+ik0))
        xmu0 = (aa+bb*ee(ie)+cc*ee(ie)**2) / ee(ie)**xn
        chiat = (xmu(ie) - xmu0) / xmu0
        eee = ee(ie) -ef
        if (eee.ge.0.d0) then
           xk = sqrt(2*eee) /bohr
        else
           xk = -sqrt(-2*eee) /bohr
        endif
        write (1, 410) ee(ie)*hart, (ee(ie)-emu)*hart, xk,
     1              xmu(ie)/xnorm, xmu0/xnorm, chiat
 410    format (1x, 2f11.3, f8.3, 1p, 3e13.5)
 400  continue
      close (unit=1)

      return
      end


program modEuler
implicit none
integer n,i
double precision a,b,alpha,h,t,y,e,f,g
e=dexp(1.d0)
write(*,*)'enter n'
read(*,*) n
write(*,*)'enter a'
read(*,*) a
write(*,*)'enter b'
read(*,*) b
write(*,*)'enter alpha'
read(*,*) alpha
h=(b-a)/n
t=a
y=alpha
write(8,*) t,y
write(*,*) h
do i=1,n
	y=y+ h/2.d0*(f(t,y)+f(t+h,y+h*f(t,y)))
	write(*,*)'Y=', y
	t=a + i*h
	write(8,*) t,y,g(t),'error:', dabs(y - g(t))
enddo
write(9,*) h, dabs(y-g(t))
stop
end program modEuler

function f(t,y)
implicit none
double precision t,x,y,f,z
x=2*t
z=2*t*y
f=(1/(t**2))*(dsin(x) - z)
return
end function f

function g(t)
implicit none
double precision t,g,x
x=2.d0*t
g=(.5d0)*(1/(t**2.d0))*(4+dcos(2.d0)-dcos(x))
return
end function g


      SUBROUTINE POTMP(PRESS,TEMP,S,RP,POTEMP)
!SOURCE: http://www.ncl.ucar.edu/Support/talk_archives/2011/att-1609/potmp.f
C
C     TITLE:
C     *****
C
C       POTMP  -- CALCULATE POTENTIAL TEMPERATURE FOR AN ARBITRARY
C                 REFERENCE PRESSURE
C
C     PURPOSE:
C     *******
C
C       TO CALCULATE POTENTIAL TEMPERATURE
C
C       REF: N.P. FOFONOFF
C            DEEP SEA RESEARCH
C            IN PRESS NOV 1976
C
C     PARAMETERS:
C     **********
C
C       PRESS  -> PRESSURE IN DECIBARS
C       TEMP   -> TEMPERATURE IN CELSIUS DEGREES
C       S      -> SALINITY PSS 78
C       RP     -> REFERENCE PRESSURE IN DECIBARS
C                 (0.0 FOR THE QUANTITY THETA)
C       POTEMP <- POTENTIAL TEMPERATURE (DEG C)
C
        REAL PRESS,TEMP,S,RP,POTEMP
C
C     VARIABLES:
C     *********
C
         INTEGER I,J,N
         REAL*4 DP,P,Q,R1,R2,R3,R4,R5,S1,T,X
C
C     CODE:
C     ****
C
      S1 = S-35.0
      P  = PRESS
      T  = TEMP
C
      DP = RP - P
      N  = IFIX(ABS(DP)/1000.) + 1
      DP = DP/FLOAT(N)
C
      DO 10 I=1,N
         DO 20 J=1,4
C
            R1 = ((-2.1687E-16*T+1.8676E-14)*T-4.6206E-13)*P
            R2 = (2.7759E-12*T-1.1351E-10)*S1
            R3 = ((-5.4481E-14*T+8.733E-12)*T-6.7795E-10)*T
            R4 = (R1+(R2+R3+1.8741E-8))*P+(-4.2393E-8*T+1.8932E-6)*S1
            R5 = R4+((6.6228E-10*T-6.836E-8)*T+8.5258E-6)*T+3.5803E-5
C
            X  = DP*R5
C
            GO TO (100,200,300,400),J
C
  100       CONTINUE
            T = T+.5*X
            Q = X
            P = P + .5*DP
            GO TO 20
C
  200       CONTINUE
            T = T + .29298322*(X-Q)
            Q = .58578644*X + .121320344*Q
            GO TO 20
C
  300       CONTINUE
            T = T + 1.707106781*(X-Q)
            Q = 3.414213562*X - 4.121320344*Q
            P = P + .5*DP
            GO TO 20
C
  400       CONTINUE
            T = T + (X-2.0*Q)/6.0
  20      CONTINUE
  10    CONTINUE
C
        POTEMP = T
        RETURN
C
C       END POTMP
C
        END


cdis    Forecast Systems Laboratory
cdis    NOAA/OAR/ERL/FSL
cdis    325 Broadway
cdis    Boulder, CO     80303
cdis
cdis    Forecast Research Division
cdis    Local Analysis and Prediction Branch
cdis    LAPS
cdis
cdis    This software and its documentation are in the public domain and
cdis    are furnished "as is."  The United States government, its
cdis    instrumentalities, officers, employees, and agents make no
cdis    warranty, express or implied, as to the usefulness of the software
cdis    and documentation for any purpose.  They assume no responsibility
cdis    (1) for the use of the software and documentation; or (2) to provide
cdis     technical support to users.
cdis
cdis    Permission to use, copy, modify, and distribute this software is
cdis    hereby granted, provided that the entire disclaimer notice appears
cdis    in all copies.  All modifications to this software must be clearly
cdis    documented, and are solely the responsibility of the agent making
cdis    the modifications.  If significant modifications or enhancements
cdis    are made to this software, the FSL Software Policy Manager
cdis    (softwaremgr@fsl.noaa.gov) should be notified.
cdis
cdis
cdis
cdis
cdis
cdis
cdis

        function sind(x)

        real x,sind,pi,rpd

        parameter (pi = 3.1415926535897932)
        parameter (rpd = pi / 180.)

        sind = sin(x*rpd)

        return
        end

        function cosd(x)

        real x,cosd,pi,rpd

        parameter (pi = 3.1415926535897932)
        parameter (rpd = pi / 180.)

        cosd = cos(x*rpd)

        return
        end

        function tand(x)

        real x,tand,pi,rpd

        parameter (pi = 3.1415926535897932)
        parameter (rpd = pi / 180.)

        tand = tan(x*rpd)

        return
        end

        function asind(x)

        real x,asind,pi,rpd

        parameter (pi = 3.1415926535897932)
        parameter (rpd = pi / 180.)

        asind = asin(x) / rpd

        return
        end

        function acosd(x)

        real x,acosd,pi,rpd

        parameter (pi = 3.1415926535897932)
        parameter (rpd = pi / 180.)

        acosd = acos(x) / rpd

        return
        end

        function atan2d(x,y)

        real x,y,atan2d,pi,rpd

        parameter (pi = 3.1415926535897932)
        parameter (rpd = pi / 180.)

        atan2_deg = atan2(x,y) / rpd

        return
        end


program main
    use iso_fortran_env
    implicit none

    real(real64),allocatable :: NodCoord(:,:)
    integer(int32),allocatable :: ElemNod(:,:)
    integer(int32),allocatable :: ElemMat(:)

    integer(int32) :: num_dim =2 ! 2-dimensional
    integer(int32) :: num_node=9 ! 9 nodes
    integer(int32) :: num_elem=4 ! 4 elements
    integer(int32) :: num_node_per_elem=4 ! 4 nodes per 1 element

    allocate(NodCoord(num_node,num_dim) )
    allocate(ElemNod(num_elem,num_node_per_elem) )
    allocate(ElemMat(num_elem))

    NodCoord(1,1) = 0.0d0; NodCoord(1,2) = 0.0d0;
    NodCoord(2,1) = 1.0d0; NodCoord(2,2) = 0.0d0;
    NodCoord(3,1) = 2.0d0; NodCoord(3,2) = 0.0d0;
    NodCoord(4,1) = 0.0d0; NodCoord(4,2) = 1.0d0;
    NodCoord(5,1) = 1.0d0; NodCoord(5,2) = 1.0d0;
    NodCoord(6,1) = 2.0d0; NodCoord(6,2) = 1.0d0;
    NodCoord(7,1) = 0.0d0; NodCoord(7,2) = 2.0d0;
    NodCoord(8,1) = 1.0d0; NodCoord(8,2) = 2.0d0;
    NodCoord(9,1) = 2.0d0; NodCoord(9,2) = 2.0d0;

    ElemNod(1,1) = 1; ElemNod(1,2) = 2; ElemNod(1,3) = 5; ElemNod(1,4) = 4;
    ElemNod(2,1) = 2; ElemNod(2,2) = 3; ElemNod(2,3) = 6; ElemNod(2,4) = 5;
    ElemNod(3,1) = 4; ElemNod(3,2) = 5; ElemNod(3,3) = 8; ElemNod(3,4) = 7;
    ElemNod(4,1) = 5; ElemNod(4,2) = 6; ElemNod(4,3) = 9; ElemNod(4,4) = 8;

    ElemMat(1) = 1;
    ElemMat(2) = 1;
    ElemMat(3) = 1;
    ElemMat(4) = 2;

    ! export
    ! ...略

end program main


************************************************************************
*                          ARITH.FOR                                   *
*                                                                      *
*                                                                      *
*  PROGRAMMER:                                                         *
*     RALPH F. MILES, JR.                                              *
*     SYSTEMS DIVISION                                                 *
*     JET PROPULSION LABORATORY                                        *
*     PASADENA, CA 91109                                               *
*                                                                      *
*  VERSION: 1.00X1                                                     *
*  DATE:    06/13/85                                                   *
*                                                                      *
*----------------------------------------------------------------------*
*  THE PROGRAM "ARITH.FOR" TESTS THE FOUR FORTRAN DOUBLE-PRECISION     *
*  ARITHMETICAL OPERATIONS (+,-,*,/) AND THE FORTRAN DOUBLE-PRECISION  *
*  FUNCTIONS MODULO (DMOD) AND TRUNCATION (DINT).                      *
*                                                                      *
*----------------------------------------------------------------------*
*                      CONFIGURATION CHANGES                           *
*                                                                      *
*   VER.    DATE                   CHANGES                             *
*                                                                      *
*  1.0X01  06/13/85  * ORIGINAL.                                       *
*                                                                      *
************************************************************************

$TITLE:'RANDOM.LST'
$DEBUG
$NOFLOATCALLS
$STORAGE:4

************************************************************************

      PROGRAM ARITH

************************************************************************

***** INITIALIZE PROGRAM.  {MODULE 1}

      CHARACTER*1      MENU
      DOUBLE PRECISION ARITH1,ARITH2,ARITH3

***   {END MODULE 1}

***** MENU DISPLAY.  {MODULE 2}

100   CONTINUE

      WRITE  (*,110)
110   FORMAT (1X,/////////////////////////
     *        24X,'****** THE ARITH MENU ****** '/
     *        /
     *        24X,'+    :    Addition            '/
     *        24X,'-    :    Subtraction         '/
     *        24X,'*    :    Multiplication      '/
     *        24X,'/    :    Division            '/
     *        24X,'M    :    Modulo     (DMOD)   '/
     *        24X,'T    :    Truncation (DINT)   '/
     *        24X,'Q    :    Quit                '/
     *        /
     *        24X,'----------------------------- '/
     *        //)

      WRITE (*,'(20X,A\)') 'Enter a Menu Character & <RETURN>:  '
      READ  (*,'(BN,A1)') MENU

***   {END MODULE 2}

***** QUIT THE PROGRAM.  {MODULE 3}

      IF (MENU .EQ. 'Q') THEN

         WRITE  (*,120)
120      FORMAT (1X,/////////////////////////)

         GOTO 999

      ENDIF

***   {END MODULE 3}

***** PERFORM ADDITION.  {MODULE 4}

      IF (MENU .EQ. '+') THEN

         WRITE  (*,130)
130      FORMAT (1X,/////////////////////////
     *           30X,'****** ADDITION ******  ')

         WRITE  (*,140)
140      FORMAT (/////1X,5X,'Enter the first number for addition:  '\)
         READ   (*,150) ARITH1
150      FORMAT (BN,F20.0)

         WRITE  (*,160)
160      FORMAT (   //1X,5X,'Enter the second number for addition: '\)
         READ   (*,170) ARITH2
170      FORMAT (BN,F20.0)

         ARITH3 = ARITH1 + ARITH2

         WRITE  (*,180) ARITH3
180      FORMAT (   //1X,5X,'The addition of the two numbers is:   ',
     *           F20.0)

         WRITE (*,'(//1X,A\)') 'Enter <RETURN> to continue: '
         READ  (*,'(BN,A1)') MENU

      ENDIF

***   {END MODULE 4}

***** PERFORM SUBTRACTION.  {MODULE 5}

      IF (MENU .EQ. '-') THEN

         WRITE  (*,190)
190      FORMAT (1X,/////////////////////////
     *           30X,'****** SUBTRACTION ****** ')

         WRITE  (*,200)
200      FORMAT (/////1X,5X,
     *           'Enter the first number for subtraction:  '\)
         READ   (*,210) ARITH1
210      FORMAT (BN,F20.0)

         WRITE  (*,220)
220      FORMAT (//1X,5X,'Enter the second number for subtraction: '\)
         READ   (*,230) ARITH2
230      FORMAT (BN,F20.0)

         ARITH3 = ARITH1 - ARITH2

         WRITE  (*,240) ARITH3
240      FORMAT (//1X,5X,'The subtraction of the two numbers is:   ',
     *           F20.0)

         WRITE (*,'(//1X,A\)') 'Enter <RETURN> to continue: '
         READ  (*,'(BN,A1)') MENU

      ENDIF

***   {END MODULE 5}

***** PERFORM MULTIPLICATION.  {MODULE 6}

      IF (MENU .EQ. '*') THEN

         WRITE  (*,250)
250      FORMAT (1X,/////////////////////////
     *           30X,'****** MULTIPLICATION ****** ')

         WRITE  (*,260)
260      FORMAT (/////1X,5X,
     *           'Enter the first number for multiplication:  '\)
         READ   (*,270) ARITH1
270      FORMAT (BN,F20.0)

         WRITE  (*,280)
280      FORMAT (   //1X,5X,
     *           'Enter the second number for multiplication: '\)
         READ   (*,290) ARITH2
290      FORMAT (BN,F20.0)

         ARITH3 = ARITH1 * ARITH2

         WRITE  (*,300) ARITH3
300      FORMAT (   //1X,5X,
     *           'The multiplication of the two numbers is: ',F20.0)

         WRITE (*,'(//1X,A\)') 'Enter <RETURN> to continue: '
         READ  (*,'(BN,A1)') MENU

      ENDIF

***   {END MODULE 6}

***** PERFORM DIVISION.  {MODULE 7}

      IF (MENU .EQ. '/') THEN

         WRITE  (*,310)
310      FORMAT (1X,/////////////////////////
     *           30X,'****** DIVISION ****** ')

         WRITE  (*,320)
320      FORMAT (/////1X,5X,'Enter the first number for division:  '\)
         READ   (*,330) ARITH1
330      FORMAT (BN,F20.0)

         WRITE  (*,340)
340      FORMAT (   //1X,5X,'Enter the second number for division: '\)
         READ   (*,350) ARITH2
350      FORMAT (BN,F20.0)

         ARITH3 = ARITH1 / ARITH2

         WRITE  (*,360) ARITH3
360      FORMAT (   //1X,5X,'The division of the two numbers is: ',
     *           F30.10)

         WRITE (*,'(//1X,A\)') 'Enter <RETURN> to continue: '
         READ  (*,'(BN,A1)') MENU

      ENDIF

***   {END MODULE 7}

***** PERFORM MODULO FUNCTION.  {MODULE 8}

      IF (MENU .EQ. 'M') THEN

         WRITE  (*,370)
370      FORMAT (1X,/////////////////////////
     *           30X,'****** MODULO ****** ')

         WRITE  (*,380)
380      FORMAT (/////1X,5X,
     *           'Enter the argument of the modulo function: '\)
         READ   (*,390) ARITH1
390      FORMAT (BN,F20.0)

         WRITE  (*,400)
400      FORMAT (   //1X,5X,
     *           'Enter the modulus of the modulo function:  '\)
         READ   (*,410) ARITH2
410      FORMAT (BN,F20.0)

         ARITH3 = DMOD(ARITH1,ARITH2)

         WRITE  (*,420) ARITH3
420      FORMAT (   //1X,5X,'The remainder is: ',F20.0)

         WRITE (*,'(//1X,A\)') 'Enter <RETURN> to continue: '
         READ  (*,'(BN,A1)') MENU

      ENDIF

***   {END MODULE 8}

***** PERFORM TRUNCATION.  {MODULE 9}

      IF (MENU .EQ. 'T') THEN

         WRITE  (*,430)
430      FORMAT (1X,/////////////////////////
     *           30X,'****** TRUNCATION ****** ')

         WRITE  (*,440)
440      FORMAT (/////1X,5X,
     *           'Enter the decimal number for truncation: '\)
         READ   (*,450) ARITH1
450      FORMAT (BN,F30.10)

         ARITH3 = DINT(ARITH1)

         WRITE  (*,460) ARITH3
460      FORMAT (   //1X,5X,
     *           'The truncation of the decimal number is: ',F30.10)

         WRITE (*,'(//1X,A\)') 'Enter <RETURN> to continue: '
         READ  (*,'(BN,A1)') MENU

      ENDIF

***   {END MODULE 9}

***** GO TO MENU.  {MODULE 10}

      GOTO 100

***   {END MODULE 10}

***** STOP PROGRAM.  {MODULE 11}

999   CONTINUE

      STOP

      END

***   {END MODULE 11}

****************************** ARITH.FOR *******************************


module m_searching
  !! Contains routines to perform a simple binary search on a vector
  !!
  !! Example usage
  !!```fortran
  !!program binarySearch_test
  !!use variableKind, only: i32, r64
  !!use m_BinarySearch, only: binarySearch
  !!
  !!implicit none
  !!
  !!real(r64) :: arr(20)
  !!integer(i32) :: i
  !!integer(i32) :: j
  !!arr=[(dble(i), i = 1, 20)]
  !!j = binarySearch(arr, 10.d0, 1, 20)
  !!write(*,*) 'Location of 10.0 in arr is 10? ',j == 10
  !!end program
  !!```
  !! Perform a binary search but also return the neighbouring interval if the actual value is not found.
  !! This is useful if you need to find a number that is not contained in the array and you want the interval
  !!
  !! Example usage
  !!```fortran
  !!use variableKind
  !!use m_BinarySearch, only: intervalSearch
  !!real(r64) :: arr(20)
  !!integer(i32) :: i
  !!integer(i32) :: j(3)
  !!arr=[(dble(i), i = 1, 20)]
  !!j = intervalSearch(arr, 10.5d0, 1, 20)
  !!write(*,*) 'Location of 10.5 in arr is -1? ',j(1) == -1
  !!write(*,*) 'The interval containing 10.5 is [10,11]? ',j(2:3) == [10,11]
  !!```

use variableKind
implicit none

private

public :: binarySearch
public :: intervalSearch
public :: simpleSearch

interface binarySearch
  !! Perform a binary search.  See [[m_searching]] for more information on how to use this interface
  !====================================================================!
  module recursive function binarySearch_i1D(this,v,imin,imax) result(iout)
    !! Search for the value i in an integer vector
    !! Assumes this is sorted!
  !====================================================================!
  integer(i32) :: this(:)
    !! Vector to search within
  integer(i32) :: v
    !! Number to find in the vector
  integer(i32) :: imin
    !! Left integer
  integer(i32) :: imax
    !! Right integer
  integer(i32) :: iout
    !! Location of i in this. Returns -1 if not present
  end function
  !====================================================================!
  !====================================================================!
  module recursive function binarySearch_id1D(this,v,imin,imax) result(iout)
    !! Search for the value i in an integer vector
    !! Assumes this is sorted!
  !====================================================================!
  integer(i64) :: this(:)
    !! Vector to search within
  integer(i64) :: v
    !! Number to find in the vector
  integer(i32) :: imin
    !! Left integer
  integer(i32) :: imax
    !! Right integer
  integer(i32) :: iout
    !! Location of i in this. Returns -1 if not present
  end function
  !====================================================================!
  !====================================================================!
  module recursive function binarySearch_r1D(this,v,imin,imax) result(iout)
    !! Search for the value i in an integer vector
    !! Assumes this is sorted!
  !====================================================================!
  real(r32) :: this(:)
    !! Vector to search within
  real(r32) :: v
    !! Number to find in the vector
  integer(i32) :: imin
    !! Left integer
  integer(i32) :: imax
    !! Right integer
  integer(i32) :: iout
    !! Location of i in this. Returns -1 if not present
  end function
  !====================================================================!
  !====================================================================!
  module recursive function binarySearch_d1D(this,v,imin,imax) result(iout)
    !! Search for the value i in an integer vector
    !! Assumes this is sorted!
  !====================================================================!
  real(r64) :: this(:)
    !! Vector to search within
  real(r64) :: v
    !! Number to find in the vector
  integer(i32) :: imin
    !! Left integer
  integer(i32) :: imax
    !! Right integer
  integer(i32) :: iout
    !! Location of i in this. Returns -1 if not present
  end function
  !====================================================================!
end interface

interface intervalSearch
  !! Perform an interval search on an array
  !! Returns a length 3 integer(i32) array where the last two entries are the left and right neighbours
  !! The first entry of iout is -1 if the value is not present in the vector
  !! Assumes this is sorted!See [[m_searching]] for more information on how to use this interface
  !====================================================================!
  module recursive function intervalSearch_i1D(this,v,imin,imax) result(iout)
    !! interfaced with [[intervalSearch]]
  !====================================================================!
  integer(i32) :: this(:)
    !! Vector to search within
  integer(i32) :: v
    !! Number to find in the vector
  integer(i32) :: imin
    !! Left integer
  integer(i32) :: imax
    !! Right integer
  integer(i32) :: iout(3)
    !! Location of i in this. iout(1) = -1 if not present with iout(2-3) as the interval
  end function
  !====================================================================!
  !====================================================================!
  module recursive function intervalSearch_id1D(this,v,imin,imax) result(iout)
    !! interfaced with [[intervalSearch]]
  !====================================================================!
  integer(i64) :: this(:)
    !! Vector to search within
  integer(i64) :: v
    !! Number to find in the vector
  integer(i32) :: imin
    !! Left integer
  integer(i32) :: imax
    !! Right integer
  integer(i32) :: iout(3)
    !! Location of i in this. iout(1) = -1 if not present with iout(2-3) as the interval
  end function
  !====================================================================!
  !====================================================================!
  module recursive function intervalSearch_r1D(this,v,imin,imax) result(iout)
    !! interfaced with [[intervalSearch]]
  !====================================================================!
  real(r32) :: this(:)
    !! Vector to search within
  real(r32) :: v
    !! Number to find in the vector
  integer(i32) :: imin
    !! Left integer
  integer(i32) :: imax
    !! Right integer
  integer(i32) :: iout(3)
    !! Location of i in this. iout(1) = -1 if not present with iout(2-3) as the interval
  end function
  !====================================================================!
  !====================================================================!
  module recursive function intervalSearch_d1D(this,v,imin,imax) result(iout)
    !! interfaced with [[intervalSearch]]
  !====================================================================!
  real(r64) :: this(:)
    !! Vector to search within
  real(r64) :: v
    !! Number to find in the vector
  integer(i32) :: imin
    !! Left integer
  integer(i32) :: imax
    !! Right integer
  integer(i32) :: iout(3)
    !! Location of i in this. iout(1) = -1 if not present with iout(2-3) as the interval
  end function
  !====================================================================!
end interface

interface simpleSearch
  !! Carry out a brute force search on an array for a given number. Returns -1 if the value is not found.
  !====================================================================!
  module function simpleSearch_i1D(this, val) result(iout)
    !! Interfaced with [[simpleSearch]]
  !====================================================================!
  integer(i32) :: this(:)
    !! Search this vector
  integer(i32) :: val
    !! Number to find in the vector
  integer(i32) :: iout
    !! Location of i in this
  end function
  !====================================================================!
  !====================================================================!
  module function simpleSearch_id1D(this, val) result(iout)
    !! Interfaced with [[simpleSearch]]
  !====================================================================!
  integer(i64) :: this(:)
    !! Search this vector
  integer(i64) :: val
    !! Number to find in the vector
  integer(i32) :: iout
    !! Location of i in this
  end function
  !====================================================================!
  !====================================================================!
  module function simpleSearch_r1D(this, val) result(iout)
    !! Interfaced with [[simpleSearch]]
  !====================================================================!
  real(r32) :: this(:)
    !! Search this vector
  real(r32) :: val
    !! Number to find in the vector
  integer(i32) :: iout
    !! Location of i in this
  end function
  !====================================================================!
  !====================================================================!
  module function simpleSearch_d1D(this, val) result(iout)
    !! Interfaced with [[simpleSearch]]
  !====================================================================!
  real(r64) :: this(:)
    !! Search this vector
  real(r64) :: val
    !! Number to find in the vector
  integer(i32) :: iout
    !! Location of i in this
  end function
  !====================================================================!
end interface

end module


! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!
! Tests "generic procedure interfaces named the same as a type in the same
! module", a.k.a. "Type Overloading"

! This is a slightly modified version of Figure 17.1 in
! Fortran 95/2003 Explained by Metcalf, Reid & Cohen.
! All modifications are marked.
!

module mycomplex_module        ! Not in Figure 17.1
    private                     ! Not in Figure 17.1
    public :: mycomplex         ! Not in Figure 17.1
    type mycomplex
       private                  ! Not in Figure 17.1
       real :: argument, modulus
       real :: x, y
       contains
       procedure :: getx
       procedure :: gety
    end type
    interface mycomplex
       module procedure complex_to_mycomplex, two_reals_to_mycomplex
    end interface
    contains
       type(mycomplex) function complex_to_mycomplex(c)
          complex, intent(in) :: c
	  complex_to_mycomplex%x = 0.0
	  complex_to_mycomplex%y = 0.0
       end function complex_to_mycomplex
       type(mycomplex) function two_reals_to_mycomplex(x,y)
          real, intent(in)           :: x
          real, intent(in), optional :: y
	  two_reals_to_mycomplex%x = x
	  if (present(y)) then
	     two_reals_to_mycomplex%y = y
	  else
	     two_reals_to_mycomplex%y = 0.0
	  endif
        end function two_reals_to_mycomplex
       real function getx(this)
        class(mycomplex) :: this
	getx = this%x
       end function getx
       real function gety(this)
	class(mycomplex) :: this
	gety = this%y
       end function gety
end module mycomplex_module    ! Not in Figure 17.1

program myuse                  ! Not in Figure 17.1
     use mycomplex_module       ! Not in Figure 17.1
     logical rslt(4), expect(4)
     type(mycomplex) :: c       ! Not in Figure 17.1
     rslt = .false.
     expect = .true.
     c = mycomplex(x=1.0, y=2.0)! This should invoke two_reals_tomycomplex()
     rslt(1) = c%getx() .eq. 1.0
     rslt(2) = c%gety() .eq. 2.0
     c = mycomplex(3.0, 4.0)    ! This should invoke two_reals_tomycomplex()
     rslt(3) = c%getx() .eq. 3.0
     rslt(4) = c%gety() .eq. 4.0

     call check(rslt,expect,4)

end program myuse


module armstrong_numbers
  implicit none
contains

  logical function isArmstrongNumber(i)
    integer, intent(in) :: i
    integer :: slen, idx, j, sum
    character(len=100) :: s

    isArmstrongNumber = .false.
    sum = 0
    write(s,'(i100)') i
    s=adjustl(s)
    slen = len_trim(s)
    do idx =1,slen
      read(s(idx:idx),*) j
      sum = sum + j**slen
    enddo
    if (sum == i) then
      isArmstrongNumber = .true.
    endif
  end function

end module


MODULE func_psi
USE use_func
USE ParamModule
IMPLICIT NONE
!INTEGER,PARAMETER::SGL=SELECTED_REAL_KIND(p=6)
!INTEGER,PARAMETER::DBL=SELECTED_REAL_KIND(p=13)
!REAL(KIND=DBL),PARAMETER::pi=3.1415926535897932385d0
!REAL(KIND=DBL),PARAMETER::EulerGamma=0.57721566490153286061d0
INTERFACE unit_step
   MODULE PROCEDURE unit_step_d
   MODULE PROCEDURE unit_step_s
   MODULE PROCEDURE unit_step_i
END INTERFACE unit_step
INTERFACE Arg
   MODULE PROCEDURE ArgI
   MODULE PROCEDURE ArgR
   MODULE PROCEDURE ArgC
END INTERFACE Arg
INTERFACE Log2
   MODULE PROCEDURE LogR
   MODULE PROCEDURE LogI
   MODULE PROCEDURE LogC
END INTERFACE Log2
INTERFACE CSQRT2
   MODULE PROCEDURE CSQRTC
   MODULE PROCEDURE CSQRTR
   MODULE PROCEDURE CSQRTI
END INTERFACE CSQRT2
INTERFACE li2
   MODULE PROCEDURE li2I
   MODULE procedure li2R
   MODULE procedure li2C
END INTERFACE li2
CONTAINS
FUNCTION lamda_func(a,b,c)
REAL(KIND=DBL)::lamda_func
REAL(KIND=DBL),INTENT(IN)::a,b,c
lamda_func=a**2+b**2+c**2-2*a*b-2*a*c-2*b*c
END FUNCTION lamda_func

FUNCTION unit_step_d(x)
REAL(KIND=DBL)::unit_step_d
REAL(KIND=DBL)::x
IF(x.LT.0d0) THEN
   unit_step_d=0d0
ELSE
   unit_step_d=1d0
END IF
END FUNCTION unit_step_d

FUNCTION unit_step_s(x)
REAL(KIND=DBL)::unit_step_s
REAL(KIND=SGL)::x
IF(x.LT.0.0) THEN
   unit_step_s=0d0
ELSE
   unit_step_s=1d0
END IF
END FUNCTION unit_step_s

FUNCTION unit_step_i(x)
REAL(KIND=DBL)::unit_step_i
INTEGER::x
IF(x.LT.0) THEN
   unit_step_i=0d0
ELSE
   unit_step_i=1d0
END IF
END FUNCTION unit_step_i

FUNCTION ACosh_p(x)
REAL(KIND=DBL),INTENT(IN)::x
REAL(KIND=DBL)::ACosh_p
IF(DABS(x).LT.1d0) THEN
  WRITE(*,*)"Error in ACosh_p!"
  ACosh_p=0
ELSE
  ACosh_p=DLOG(x+DSQRT(x**2-1d0))
END IF
END FUNCTION ACosh_p
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Li2 function
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
FUNCTION li2R(x)
  COMPLEX(KIND=DBL)::li2R
  REAL(KIND=DBL),INTENT(IN)::x
  REAL(KIND=DBL)::y
  y=1d0-x
  IF(y.GT.0d0) THEN
     !   IF(y.GT.1d0)WRITE(*,*)"ATTENTION!"
     li2R=func_li2a(y,0)
  ELSEIF(y.LT.0d0)THEN
     li2R=func_li2a(-y,1)
  ELSE
     li2R=DCMPLX(0d0)
  END IF
  RETURN
END FUNCTION li2R

FUNCTION li2I(x)
  COMPLEX(KIND=DBL)::li2I
  INTEGER,INTENT(IN)::x
  REAL(KIND(1d0))::xx
  REAL(KIND=DBL)::y
  xx=x
  y=1d0-xx
  IF(y.GT.0d0) THEN
     li2I=func_li2a(y,0)
  ELSEIF(y.LT.0d0)THEN
     li2I=func_li2a(-y,1)
  ELSE
     li2I=DCMPLX(0d0)
  END IF
  RETURN
END FUNCTION li2I

FUNCTION li2C(x)
  COMPLEX(KIND=DBL)::li2C
  COMPLEX(KIND=DBL),INTENT(IN)::x
  COMPLEX(KIND=DBL)::y,newy
  REAL(KIND=DBL)::yr,yi
  INTEGER::iphi
  y=DCMPLX(1d0)-x
  yr=DBLE(y)
  yi=DIMAG(y)
  IF(yr.EQ.0d0.AND.yi.EQ.0d0)THEN
     li2C=DCMPLX(0d0)
     RETURN
  ENDIF
  IF(yr.GE.0d0.AND.yi.GE.0d0)THEN
     iphi=0
     newy=y
  ELSEIF(yr.GE.0d0.AND.yi.LT.0d0)THEN
     iphi=0
     newy=y
  ELSEIF(yr.LT.0d0.AND.yi.GE.0d0)THEN
     iphi=1
     newy=DCMPLX(-yr,-yi)
  ELSEIF(yr.LT.0d0.AND.yi.LT.0d0)THEN
     iphi=-1
     newy=DCMPLX(-yr,-yi)
  END IF
  li2C=func_li2c(newy,iphi)
  RETURN
END FUNCTION li2C

FUNCTION PolyLog(n,x)
  COMPLEX(KIND=DBL)::PolyLog
  REAL(KIND=DBL),INTENT(IN)::x
  INTEGER,INTENT(IN)::n
  IF(n.NE.2)THEN
     WRITE(*,*)"ERROR:Don't know n = ",n
     STOP
  ENDIF
  PolyLog=li2R(x)
  RETURN
END FUNCTION PolyLog
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! DLOG2
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
FUNCTION DLOG2(x)
REAL(KIND=DBL)::DLOG2
REAL(KIND=DBL),INTENT(IN)::x
IF(x.LT.0d0)THEN
   DLOG2=DLOG(-x)
ELSE
   DLOG2=DLOG(x)
ENDIF
END FUNCTION DLOG2

FUNCTION LogI(x)
  COMPLEX(KIND(1d0))::LogI
  INTEGER,INTENT(IN)::x
  REAL(KIND(1d0))::xx
  xx=x
  LogI=DLOG(xx)
  RETURN
END FUNCTION LogI

FUNCTION LogR(x)
  COMPLEX(KIND(1d0))::LogR
  REAL(KIND(1d0)),INTENT(IN)::x
  LogR=DLOG(x)
  RETURN
END FUNCTION LogR

FUNCTION LogC(x)
  COMPLEX(KIND(1d0))::LogC
  COMPLEX(KIND(1d0)),INTENT(IN)::x
  LogC=CDLOG(x)
  RETURN
END FUNCTION LogC
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Arg
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
FUNCTION ArgR(x)
  IMPLICIT NONE
  REAL(KIND=DBL),INTENT(IN)::x
  REAL(KIND=DBL)::ArgR
  IF(x.GE.0d0)THEN
     ArgR=0d0
  ELSE
     ArgR=pi
  ENDIF
  RETURN
END FUNCTION ArgR

FUNCTION ArgI(x)
  IMPLICIT NONE
  INTEGER,INTENT(IN)::x
  REAL(KIND=DBL)::ArgI
  IF(x.GE.0)THEN
     ArgI=0d0
  ELSE
     ArgI=pi
  ENDIF
  RETURN
END FUNCTION ArgI

FUNCTION ArgC(x)
  IMPLICIT NONE
  COMPLEX(KIND=DBL),INTENT(IN)::x
  REAL(KIND=DBL)::ArgC
  REAL(KIND=DBL)::xr,xi
  REAL(KIND=DBL)::add,time
  xr=DBLE(x)
  xi=DIMAG(x)
  IF(xr.EQ.0d0)THEN
     IF(xi.GT.0d0)THEN
        ArgC=pi/2d0
        RETURN
     ENDIF
     IF(xi.LT.0d0)THEN
        ArgC=-pi/2d0
        RETURN
     ENDIF
     IF(xi.EQ.0d0)THEN
        ArgC=0d0
        RETURN
     ENDIF
  ENDIF
  IF(xr.GE.0d0.AND.xi.GE.0d0)THEN
     add=0d0
     time=1d0
  ELSEIF(xr.GE.0d0.AND.xi.LT.0d0)THEN
     add=0d0
     time=-1d0
  ELSEIF(xr.LT.0d0.AND.xi.GE.0d0)THEN
     add=pi
     time=-1d0
  ELSEIF(xr.LT.0d0.AND.xi.LE.0d0)THEN
     add=-pi
     time=1d0
  ENDIF
  ArgC=time*atan(abs(xi/xr))+add
  RETURN
END FUNCTION ArgC
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! CSQRT2
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
FUNCTION CSQRTI(x)
  IMPLICIT NONE
  COMPLEX(KIND(1d0))::CSQRTI
  INTEGER,INTENT(IN)::x
  REAL(KIND(1d0))::xx
  COMPLEX(KIND(1d0))::xxx
  IF(x.GE.0)THEN
     xx=x
     CSQRTI=DCMPLX(DSQRT(xx))
  ELSE
     xxx=x
     CSQRTI=CDSQRT(xxx)
  ENDIF
  RETURN
END FUNCTION CSQRTI

FUNCTION CSQRTR(x)
  IMPLICIT NONE
  COMPLEX(KIND(1d0))::CSQRTR
  REAL(KIND(1d0)),INTENT(IN)::x
  COMPLEX(KIND(1d0))::xx
  IF(x.GE.0d0)THEN
     CSQRTR=DCMPLX(DSQRT(x))
  ELSE
     xx=x
     CSQRTR=CDSQRT(xx)
  ENDIF
  RETURN
END FUNCTION CSQRTR

FUNCTION CSQRTC(x)
  IMPLICIT NONE
  COMPLEX(KIND(1d0))::CSQRTC
  COMPLEX(KIND(1d0)),INTENT(IN)::x
  CSQRTC=CDSQRT(x)
  RETURN
END FUNCTION CSQRTC
END MODULE func_psi


! Fundamental constants taken from NIST's 2010 CODATA recommended values

module fundamental_constants_module

  use amrex_fort_module, only : rt => amrex_real

  implicit none

  ! Pi
  real(rt), parameter :: pi = 3.141592653589793238d0

  ! newton's gravitational constant
  real(rt), parameter :: Gconst = 6.67428e-8_rt      ! cm^3/g/s^2
  ! new value; if uncommented initial models will need to be re-HSE'ed
  !real(rt), parameter :: Gconst = 6.67384e-8_rt      ! cm^3/g/s^2

  ! boltzmann's constant
  real(rt), parameter :: k_B = 1.3806488e-16_rt   ! erg/K

  ! planck's constant over 2pi
  real(rt), parameter :: hbar = 1.054571726e-27_rt ! erg s

  ! planck's constant
  real(rt), parameter :: hplanck = 6.62606957e-27_rt ! erg s

  ! avogradro's Number
  real(rt), parameter :: n_A = 6.02214129e23_rt   ! mol^-1

  ! Thomson cross section [cm^2]
  real(rt), parameter :: sigma_T =  6.6524587158e-25_rt

  ! convert eV to erg
  real(rt), parameter :: ev2erg = 1.602176487e-12_rt

  ! convert MeV to eV
  real(rt), parameter :: MeV2eV = 1.0e6_rt

  ! mass of proton
  real(rt), parameter :: m_proton = 1.672621777e-24_rt ! g

  ! mass of neutron
  real(rt), parameter :: m_n = 1.674927351e-24_rt ! g

  ! mass of electron
  real(rt), parameter :: m_e = 9.10938291e-28_rt  ! g

  ! speed of light in vacuum
  real(rt), parameter :: c_light = 2.99792458e10_rt   ! cm/s

  real(rt), parameter :: mp_over_kb = m_proton/k_B

  ! electron charge
  ! NIST: q_e = 1.602176565e-19 C
  !
  ! C is the SI unit Coulomb; in cgs we have the definition:
  !     1 C = 0.1 * |c_light| * 1 statC
  ! where statC is the cgs unit statCoulomb; 1 statC = 1 erg^1/2 cm^1/2
  ! and |c_light| is the speed of light in cgs (but without units)
  real(rt), parameter :: q_e     = 4.80320451e-10_rt  ! erg^1/2 cm^1/2

  ! stefan-boltzmann constant
  real(rt), parameter :: sigma_SB = 5.670373e-5_rt    ! erg/s/cm^2/K^4

  ! radiation constant
  real(rt), parameter :: a_rad = 4.0_rt*sigma_SB/c_light

  ! Hubble constant (in s^{-1}, converted from 100 (km/s)/Mpc by dividing by 3.08568025e19km/Mpc)
  real(rt), parameter :: Hubble_const = 32.407764868e-19

  !!! conversion factors

  ! conversion factor for density from cosmo to cgs units.
  real(rt), parameter :: density_to_cgs = 1

  ! converstion factor for "heat" from cgs to cosmo units.
  real(rt), parameter :: heat_from_cgs = 1

  ! conversion factor for energy from cosmo to cgs units.
  real(rt), parameter :: e_to_cgs = 1

  ! For AGN accretion rate
  real(rt), parameter :: eddington_const = 4.0d0*pi * Gconst * m_proton / (sigma_T * c_light)

end module fundamental_constants_module


PROGRAM F003

    ! Copyright 2021 Melwyn Francis Carlo
    ! FILE REFERENCE: http://www.naturalnumbers.org/primes.html

    IMPLICIT NONE

    INTEGER :: PRIME_NUM
    REAL (KIND=8), PARAMETER :: N = 600851475143.D0
    REAL (KIND=8), PARAMETER :: PRIME_NUM_MAX = SQRT(N)
    REAL (KIND=8) :: PRIME_NUM_LARGEST
    CHARACTER (LEN=50), PARAMETER :: FILENAME = "problems/003/PrimeNumbers_Upto_1000000"

    OPEN (2, FILE = FILENAME, STATUS = 'OLD')

    PRIME_NUM_LARGEST = N
    DO
        READ(2, *, END=10) PRIME_NUM
        IF (PRIME_NUM <= PRIME_NUM_MAX) THEN
            IF (MOD(INT(N, 8), INT(PRIME_NUM, 8)) == 0) THEN
                PRIME_NUM_LARGEST = PRIME_NUM
            END IF
        ELSE
            EXIT
        END IF
    END DO

    10 CLOSE(2)

    PRINT ('(I0)'), INT(PRIME_NUM_LARGEST)

END PROGRAM F003


MODULE PolynomialBasisModuleX_Legendre

  USE KindModule, ONLY: &
    DP
  USE QuadratureModule, ONLY: &
    InitializeQuadratures, &
    xG5, wG5
  USE ProgramHeaderModule, ONLY: &
    nDOFX, nNodesX, nDimsX, nNodes

  IMPLICIT NONE
  PRIVATE

  INTERFACE
    PURE REAL(DP) FUNCTION Basis( X )
      USE KindModule, ONLY: DP
      REAL(DP), INTENT(IN) :: X
    END FUNCTION Basis
  END INTERFACE

  TYPE :: PolynomialBasisType
    PROCEDURE (Basis), POINTER, NOPASS :: P
  END TYPE PolynomialBasisType

  INTEGER,                   DIMENSION(:,:), ALLOCATABLE, PUBLIC :: IndPX_Q
  REAL(DP),                  DIMENSION(:),   ALLOCATABLE, PUBLIC :: MassPX
  TYPE(PolynomialBasisType), DIMENSION(:),   ALLOCATABLE, PUBLIC :: P_X1
  TYPE(PolynomialBasisType), DIMENSION(:),   ALLOCATABLE, PUBLIC :: P_X2
  TYPE(PolynomialBasisType), DIMENSION(:),   ALLOCATABLE, PUBLIC :: P_X3

  PUBLIC :: InitializePolynomialBasisX_Legendre
  PUBLIC :: evalPX

CONTAINS

  SUBROUTINE InitializePolynomialBasisX_Legendre

    CALL InitializeQuadratures

    ALLOCATE( P_X1(nNodesX(1)) )
    CALL InitializeBasis( P_X1 )

    ALLOCATE( P_X2(nNodesX(2)) )
    CALL InitializeBasis( P_X2 )

    ALLOCATE( P_X3(nNodesX(3)) )
    CALL InitializeBasis( P_X3 )

    ALLOCATE( IndPX_Q(1:3,nDOFX) )
    CALL InitializeIndices_TensorProductBasis

    ALLOCATE( MassPX(nDOFX) )
    CALL ComputeMassMatrix

  END SUBROUTINE InitializePolynomialBasisX_Legendre

  SUBROUTINE InitializeBasis( P )

    TYPE(PolynomialBasisType), DIMENSION(:) :: P

    SELECT CASE ( SIZE( P ) )

      CASE ( 1 )

        P(1) % P => Legendre_0

      CASE ( 2 )

        P(1) % P => Legendre_0
        P(2) % P => Legendre_1

      CASE ( 3 )

        P(1) % P => Legendre_0
        P(2) % P => Legendre_1
        P(3) % P => Legendre_2

      CASE ( 4 )

        P(1) % P => Legendre_0
        P(2) % P => Legendre_1
        P(3) % P => Legendre_2
        P(4) % P => Legendre_3

      CASE DEFAULT

        WRITE(*,*)
        WRITE(*,*) "  Invalid Basis Size  "
        STOP

    END SELECT

  END SUBROUTINE InitializeBasis

  SUBROUTINE InitializeIndices_TensorProductBasis

    INTEGER :: i, ik, kMax, ik_X1, ik_X2, ik_X3

    kMax = nDimsX * nNodes

    i = 0
    DO ik    = 0, kMax
    DO ik_X3 = 0, nNodesX(3) - 1
    DO ik_X2 = 0, nNodesX(2) - 1
    DO ik_X1 = 0, nNodesX(1) - 1

      IF( SUM( [ ik_X1, ik_X2, ik_X3 ] ) == ik )THEN

        i = i + 1

        IndPX_Q(1:3,i) = [ ik_X1+1, ik_X2+1, ik_X3+1 ]

      END IF

    END DO
    END DO
    END DO
    END DO

  END SUBROUTINE InitializeIndices_TensorProductBasis

  SUBROUTINE ComputeMassMatrix

    INTEGER :: i, j
    INTEGER :: qX1, qX2, qX3

    MassPX = 0.0_DP
    DO j = 1, nDOFX
    DO i = 1, nDOFX

      IF( i /= j ) cycle ! --- Diagonal Mass Matrix

      DO qX3 = 1, SIZE( xG5 )
      DO qX2 = 1, SIZE( xG5 )
      DO qX1 = 1, SIZE( xG5 )

        MassPX(i) &
          = MassPX(i) &
              + wG5(qX1) * wG5(qX2) * wG5(qX3) &
                  * P_X1(IndPX_Q(1,i)) % P( xG5(qX1) ) &
                  * P_X2(IndPX_Q(2,i)) % P( xG5(qX2) ) &
                  * P_X3(IndPX_Q(3,i)) % P( xG5(qX3) ) &
                  * P_X1(IndPX_Q(1,j)) % P( xG5(qX1) ) &
                  * P_X2(IndPX_Q(2,j)) % P( xG5(qX2) ) &
                  * P_X3(IndPX_Q(3,j)) % P( xG5(qX3) )

      END DO
      END DO
      END DO

    END DO
    END DO

    MassPX = 1.0_DP / MassPX ! --- Store as Inverse

  END SUBROUTINE ComputeMassMatrix

  PURE REAL(DP) FUNCTION evalPX( u, X1, X2, X3 )

    REAL(DP), INTENT(in) :: u(1:nDOFX), X1, X2, X3

    INTEGER :: i

    evalPX = 0.0_DP
    DO i = 1, nDOFX

      evalPX &
        = evalPX &
            + P_X1(IndPX_Q(1,i)) % P( X1 ) &
            * P_X2(IndPX_Q(2,i)) % P( X2 ) &
            * P_X3(IndPX_Q(3,i)) % P( X3 ) &
            * u(i)

    END DO

    RETURN
  END FUNCTION evalPX

  !***************************************************************************
  !  Elements of Legendre Polynomial Basis
  !***************************************************************************

  PURE REAL(DP) FUNCTION Legendre_0( x )
    REAL(DP), INTENT(IN) :: x
    Legendre_0 = 1.0_DP
    RETURN
  END FUNCTION Legendre_0

  PURE REAL(DP) FUNCTION Legendre_1( x )
    REAL(DP), INTENT(IN) :: x
    Legendre_1 = x
    RETURN
  END FUNCTION Legendre_1

  PURE REAL(DP) FUNCTION Legendre_2( x )
    REAL(DP), INTENT(IN) :: x
    Legendre_2 = x**2 - 1.0_DP / 12.0_DP
    RETURN
  END FUNCTION Legendre_2

  PURE REAL(DP) FUNCTION Legendre_3( x )
    REAL(DP), INTENT(IN) :: x
    Legendre_3 = x * ( x**2 - 3.0_DP / 20.0_DP )
    RETURN
  END FUNCTION Legendre_3

END MODULE PolynomialBasisModuleX_Legendre


      FUNCTION CANG (Z)
C
C     CANG RETURNS THE PHASE ANGLE OF A COMPLEX NUMBER IN DEGREES.
C
      COMPLEX Z
      CANG=ATGN2(AIMAG(Z),REAL(Z))*57.29577951
      RETURN
      END


program rhop

  use omp_lib

  real(kind=8), allocatable, dimension (:,:,:) :: t, p, qv, qc, qi, rho
  integer:: isize, jsize, ksize
  integer :: i,j,k, cnt

  real :: pc_r_d, pc_rvd_o
  real(kind=8) :: startt, endt
  real(kind=8) :: mean

  pc_r_d = 287.05
  pc_rvd_o = 461.51 / pc_r_d - 1.0

  isize = 1024
  jsize = 1024
  ksize = 80
  allocate(t(isize, jsize, ksize))
  allocate(p(isize, jsize, ksize))
  allocate(qv(isize, jsize, ksize))
  allocate(qc(isize, jsize, ksize))
  allocate(qi(isize, jsize, ksize))
  allocate(rho(isize, jsize, ksize))

  do k=1, ksize
    do i=1, isize
      do j=1, jsize
        p(i,j,k) = 1+i
        t(i,j,k) = 0.1*i
        qv(i,j,k) = 0.02*j
        qc(i,j,k) = p(i,j,k)*1.1
        qi(i,j,k) = 0.3*i
        rho(i,j,k) = 1.1*k
      enddo
    enddo
  enddo
  mean = 0
  do cnt=1, 100
    startt = omp_get_wtime()
!$omp parallel do
    do k=1, ksize
      do i=2, isize-1
        do j=2, jsize-1
          rho(i,j,k) = p(i,j,k) * (t(i+1,j,k) + t(i-1,j,k) + t(i,j-1,k) + t(i,j+1,k))*0.25
        enddo
      enddo
    enddo
!$omp end parallel do
    endt = omp_get_wtime()
    write(*,*) "KK" , endt-startt, rho(cnt,cnt,4)
    mean = mean + (endt-startt)
  enddo

  write(*,*) "Mean ", mean/100.0
end program

!def rho(t, p, qv, qc, qi):
!  return p / ( pc_r_d * t * (1.0 + pc_rvd_o * qv - qc - qi) )