      SUBROUTINE MB02MD( JOB, M, N, L, RANK, C, LDC, S, X, LDX, TOL,
     $                   IWORK, DWORK, LDWORK, IWARN, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To solve the Total Least Squares (TLS) problem using a Singular
C     Value Decomposition (SVD) approach.
C     The TLS problem assumes an overdetermined set of linear equations
C     AX = B, where both the data matrix A as well as the observation
C     matrix B are inaccurate. The routine also solves determined and
C     underdetermined sets of equations by computing the minimum norm
C     solution.
C     It is assumed that all preprocessing measures (scaling, coordinate
C     transformations, whitening, ... ) of the data have been performed
C     in advance.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Determines whether the values of the parameters RANK and
C             TOL are to be specified by the user or computed by the
C             routine as follows:
C             = 'R':  Compute RANK only;
C             = 'T':  Compute TOL only;
C             = 'B':  Compute both RANK and TOL;
C             = 'N':  Compute neither RANK nor TOL.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows in the data matrix A and the
C             observation matrix B.  M >= 0.
C
C     N       (input) INTEGER
C             The number of columns in the data matrix A.  N >= 0.
C
C     L       (input) INTEGER
C             The number of columns in the observation matrix B.
C             L >= 0.
C
C     RANK    (input/output) INTEGER
C             On entry, if JOB = 'T' or JOB = 'N', then RANK must
C             specify r, the rank of the TLS approximation [A+DA|B+DB].
C             RANK <= min(M,N).
C             Otherwise, r is computed by the routine.
C             On exit, if JOB = 'R' or JOB = 'B', and INFO = 0, then
C             RANK contains the computed (effective) rank of the TLS
C             approximation [A+DA|B+DB].
C             Otherwise, the user-supplied value of RANK may be
C             changed by the routine on exit if the RANK-th and the
C             (RANK+1)-th singular values of C = [A|B] are considered
C             to be equal, or if the upper triangular matrix F (as
C             defined in METHOD) is (numerically) singular.
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N+L)
C             On entry, the leading M-by-(N+L) part of this array must
C             contain the matrices A and B. Specifically, the first N
C             columns must contain the data matrix A and the last L
C             columns the observation matrix B (right-hand sides).
C             On exit, the leading (N+L)-by-(N+L) part of this array
C             contains the (transformed) right singular vectors,
C             including null space vectors, if any, of C = [A|B].
C             Specifically, the leading (N+L)-by-RANK part of this array
C             always contains the first RANK right singular vectors,
C             corresponding to the largest singular values of C. If
C             L = 0, or if RANK = 0 and IWARN <> 2, the remaining
C             (N+L)-by-(N+L-RANK) top-right part of this array contains
C             the remaining N+L-RANK right singular vectors. Otherwise,
C             this part contains the matrix V2 transformed as described
C             in Step 3 of the TLS algorithm (see METHOD).
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= max(1,M,N+L).
C
C     S       (output) DOUBLE PRECISION array, dimension (min(M,N+L))
C             If INFO = 0, the singular values of matrix C, ordered
C             such that S(1) >= S(2) >= ... >= S(p-1) >= S(p) >= 0,
C             where p = min(M,N+L).
C
C     X       (output) DOUBLE PRECISION array, dimension (LDX,L)
C             If INFO = 0, the leading N-by-L part of this array
C             contains the solution X to the TLS problem specified
C             by A and B.
C
C     LDX     INTEGER
C             The leading dimension of array X.  LDX >= max(1,N).
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             A tolerance used to determine the rank of the TLS
C             approximation [A+DA|B+DB] and to check the multiplicity
C             of the singular values of matrix C. Specifically, S(i)
C             and S(j) (i < j) are considered to be equal if
C             SQRT(S(i)**2 - S(j)**2) <= TOL, and the TLS approximation
C             [A+DA|B+DB] has rank r if S(i) > TOL*S(1) (or S(i) > TOL,
C             if TOL specifies sdev (see below)), for i = 1,2,...,r.
C             TOL is also used to check the singularity of the upper
C             triangular matrix F (as defined in METHOD).
C             If JOB = 'R' or JOB = 'N', then TOL must specify the
C             desired tolerance. If the user sets TOL to be less than or
C             equal to 0, the tolerance is taken as EPS, where EPS is
C             the machine precision (see LAPACK Library routine DLAMCH).
C             Otherwise, the tolerance is computed by the routine and
C             the user must supply the non-negative value sdev, i.e. the
C             estimated standard deviation of the error on each element
C             of the matrix C, as input value of TOL.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (L)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK, and DWORK(2) returns the reciprocal of the
C             condition number of the matrix F.
C             If INFO > 0, DWORK(1:min(M,N+L)-1) contain the unconverged
C             non-diagonal elements of the bidiagonal matrix whose
C             diagonal is in S (see LAPACK Library routine DGESVD).
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK = max(2, 3*(N+L) + M, 5*(N+L)),       if M >= N+L;
C             LDWORK = max(2, M*(N+L) + max( 3M+N+L, 5*M), 3*L),
C                                                          if M <  N+L.
C             For optimum performance LDWORK should be larger.
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     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warnings;
C             = 1:  if the rank of matrix C has been lowered because a
C                   singular value of multiplicity greater than 1 was
C                   found;
C             = 2:  if the rank of matrix C has been lowered because the
C                   upper triangular matrix F is (numerically) singular.
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             > 0:  if the SVD algorithm (in LAPACK Library routine
C                   DBDSQR) has failed to converge. In this case, S(1),
C                   S(2), ..., S(INFO) may not have been found
C                   correctly and the remaining singular values may
C                   not be the smallest. This failure is not likely
C                   to occur.
C
C     METHOD
C
C     The method used is an extension (see [3,4,5]) of the classical
C     TLS algorithm proposed by Golub and Van Loan [1].
C
C     Let [A|B] denote the matrix formed by adjoining the columns of B
C     to the columns of A on the right.
C
C     Total Least Squares (TLS) definition:
C     -------------------------------------
C
C       Given matrices A and B, find a matrix X satisfying
C
C            (A + DA) X = B + DB,
C
C       where A and DA are M-by-N matrices, B and DB are M-by-L matrices
C       and X is an N-by-L matrix.
C       The solution X must be such that the Frobenius norm of [DA|DB]
C       is a minimum and each column of B + DB is in the range of
C       A + DA. Whenever the solution is not unique, the routine singles
C       out the minimum norm solution X.
C
C     Define matrix C = [A|B] and s(i) as its i-th singular value for
C     i = 1,2,...,min(M,NL), where NL = N + L. If M < NL, then s(j) = 0
C     for j = M+1,...,NL.
C
C     The Classical TLS algorithm proceeds as follows (see [3,4,5]):
C
C     Step 1: Compute part of the singular value decomposition (SVD)
C             USV' of C = [A|B], namely compute S and V'. (An initial
C             QR factorization of C is used when M is larger enough
C             than NL.)
C
C     Step 2: If not fixed by the user, compute the rank r0 of the data
C             [A|B] based on TOL as follows: if JOB = 'R' or JOB = 'N',
C
C                s(1) >= ... >= s(r0) > TOL*s(1) >= ... >= s(NL).
C
C             Otherwise, using [2], TOL can be computed from the
C             standard deviation sdev of the errors on [A|B]:
C
C                TOL = SQRT(2 * max(M,NL)) * sdev,
C
C             and the rank r0 is determined (if JOB = 'R' or 'B') using
C
C                s(1) >= ... >= s(r0) > TOL >= ... >= s(NL).
C
C             The rank r of the approximation [A+DA|B+DB] is then equal
C             to the minimum of N and r0.
C
C     Step 3: Let V2 be the matrix of the columns of V corresponding to
C             the (NL - r) smallest singular values of C, i.e. the last
C             (NL - r) columns of V.
C             Compute with Householder transformations the orthogonal
C             matrix Q such that:
C
C                       |VH   Y|
C              V2 x Q = |      |
C                       |0    F|
C
C             where VH is an N-by-(N - r) matrix, Y is an N-by-L matrix
C             and F is an L-by-L upper triangular matrix.
C             If F is singular, then lower the rank r with the
C             multiplicity of s(r) and repeat this step.
C
C     Step 4: If F is nonsingular then the solution X is obtained by
C             solving the following equations by forward elimination:
C
C                X F = -Y.
C
C     Notes :
C     The TLS solution is unique if r = N, F is nonsingular and
C     s(N) > s(N+1).
C     If F is singular, however, then the computed solution is infinite
C     and hence does not satisfy the second TLS criterion (see TLS
C     definition). For these cases, Golub and Van Loan [1] claim that
C     the TLS problem has no solution. The properties of these so-called
C     nongeneric problems are described in [4] and the TLS computations
C     are generalized in order to solve them. As proven in [4], the
C     proposed generalization satisfies the TLS criteria for any
C     number L of observation vectors in B provided that, in addition,
C     the solution | X| is constrained to be orthogonal to all vectors
C                  |-I|
C     of the form |w| which belong to the space generated by the columns
C                 |0|
C     of the submatrix |Y|.
C                      |F|
C
C     REFERENCES
C
C     [1] Golub, G.H. and Van Loan, C.F.
C         An Analysis of the Total Least-Squares Problem.
C         SIAM J. Numer. Anal., 17, pp. 883-893, 1980.
C
C     [2] Staar, J., Vandewalle, J. and Wemans, M.
C         Realization of Truncated Impulse Response Sequences with
C         Prescribed Uncertainty.
C         Proc. 8th IFAC World Congress, Kyoto, I, pp. 7-12, 1981.
C
C     [3] Van Huffel, S.
C         Analysis of the Total Least Squares Problem and its Use in
C         Parameter Estimation.
C         Doctoral dissertation, Dept. of Electr. Eng., Katholieke
C         Universiteit Leuven, Belgium, June 1987.
C
C     [4] Van Huffel, S. and Vandewalle, J.
C         Analysis and Solution of the Nongeneric Total Least Squares
C         Problem.
C         SIAM J. Matr. Anal. and Appl., 9, pp. 360-372, 1988.
C
C     [5] Van Huffel, S. and Vandewalle, J.
C         The Total Least Squares Problem: Computational Aspects and
C         Analysis.
C         Series "Frontiers in Applied Mathematics", Vol. 9,
C         SIAM, Philadelphia, 1991.
C
C     NUMERICAL ASPECTS
C
C     The algorithm consists in (backward) stable steps.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997.
C     Supersedes Release 2.0 routine MB02AD by S. Van Huffel, Katholieke
C     University, Leuven, Belgium.
C
C     REVISIONS
C
C     June 24, 1997, Feb. 27, 2000, Oct. 19, 2003, Feb. 21, 2004,
C     June 13, 2012.
C
C     KEYWORDS
C
C     Least-squares approximation, singular subspace, singular value
C     decomposition, singular values, total least-squares.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, TWO
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         JOB
      INTEGER           INFO, IWARN, L, LDC, LDWORK, LDX, M, N, RANK
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      INTEGER           IWORK(*)
      DOUBLE PRECISION  C(LDC,*), DWORK(*), S(*), X(LDX,*)
C     .. Local Scalars ..
      LOGICAL           CRANK, CTOL, LJOBN, LJOBR, LJOBT, LQUERY
      INTEGER           ITAU, J, JWORK, LDW, K, MINMNL, MINWRK, N1, NL,
     $                  P, R1, WRKOPT
      DOUBLE PRECISION  FNORM, RCOND, SMAX, TOLTMP
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, DLANGE, DLANTR
      EXTERNAL          DLAMCH, DLANGE, DLANTR, LSAME
C     .. External Subroutines ..
      EXTERNAL          DGERQF, DGESVD, DLACPY, DLASET, DORMRQ, DSWAP,
     $                  DTRCON, DTRSM, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, INT, MAX, MIN, SQRT
C     .. Executable Statements ..
C
      IWARN = 0
      INFO = 0
      NL = N + L
      K = MAX( M, NL )
      P = MIN( M, N )
      MINMNL = MIN( M, NL )
      LDW = MAX( 3*MINMNL + K, 5*MINMNL )
      LJOBR = LSAME( JOB, 'R' )
      LJOBT = LSAME( JOB, 'T' )
      LJOBN = LSAME( JOB, 'N' )
C
C     Determine whether RANK or/and TOL is/are to be computed.
C
      CRANK = .NOT.LJOBT .AND. .NOT.LJOBN
      CTOL  = .NOT.LJOBR .AND. .NOT.LJOBN
C
C     Test the input scalar arguments.
C
      IF( CTOL .AND. CRANK .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( L.LT.0 ) THEN
         INFO = -4
      ELSE IF( .NOT.CRANK .AND. RANK.GT.P ) THEN
         INFO = -5
      ELSE IF( LDC.LT.MAX( 1, K ) ) THEN
         INFO = -7
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( CTOL .AND. TOL.LT.ZERO ) THEN
         INFO = -11
      ELSE
         IF( M.GE.NL ) THEN
            MINWRK = MAX( 2, LDW )
         ELSE
            MINWRK = MAX( 2, M*NL + LDW, 3*L )
         END IF
         WRKOPT = MINWRK
         LQUERY = LDWORK.EQ.-1
         IF( LQUERY ) THEN
            IF ( M.GE.NL ) THEN
               CALL DGESVD( 'N', 'O', M, NL, C, LDC, S, DWORK, 1, DWORK,
     $                      1, DWORK, -1, INFO )
               WRKOPT = MAX( MINWRK, INT( DWORK(1) ) )
            ELSE
               CALL DGESVD( 'N', 'A', M, NL, DWORK, M, S, DWORK, 1, C,
     $                      LDC, DWORK, -1, INFO )
               WRKOPT = MAX( MINWRK, INT( DWORK(1) ) + M*NL )
            END IF
C
            IF ( L.GT.0 ) THEN
               CALL DGERQF( L, NL-1, C, LDC, DWORK, DWORK, -1, INFO )
               WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + L )
               CALL DORMRQ( 'R', 'T', N, NL-1, L, C, LDC, DWORK, C, LDC,
     $                      DWORK, -1, INFO )
               WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + L )
            END IF
         END IF
         IF( LDWORK.LT.MINWRK .AND. .NOT.LQUERY )
     $       INFO = -14
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB02MD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = WRKOPT
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( CRANK )
     $   RANK = P
      IF ( MIN( M, NL ).EQ.0 ) THEN
         IF ( M.EQ.0 ) THEN
            CALL DLASET( 'Full', NL, NL, ZERO, ONE, C, LDC )
            CALL DLASET( 'Full', N, L, ZERO, ZERO, X, LDX )
         END IF
         DWORK(1) = TWO
         DWORK(2) = ONE
         RETURN
      END IF
C
C     Subroutine MB02MD solves a set of linear equations by a Total
C     Least Squares Approximation.
C
C     Step 1: Compute part of the singular value decomposition (SVD)
C             USV' of C = [A   |B   ], namely compute S and V'.
C                           M,N  M,L
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.
C     NB refers to the optimal block size for the immediately
C     following subroutine, as returned by ILAENV.)
C
      IF ( M.GE.NL ) THEN
C
C        M >= N + L:  Overwrite V' on C.
C        Workspace: need max(3*min(M,N+L) + max(M,N+L), 5*min(M,N+L)).
C
         JWORK = 1
         CALL DGESVD( 'No left vectors', 'Overwritten on C', M, NL, C,
     $                LDC, S, DWORK, 1, DWORK, 1, DWORK(JWORK),
     $                LDWORK-JWORK+1, INFO )
      ELSE
C
C        M < N + L:  Save C in the workspace and compute V' in C.
C        Note that the previous DGESVD call cannot be used in this case.
C        Workspace: need M*(N+L) + max(3*min(M,N+L) + max(M,N+L),
C                                      5*min(M,N+L)).
C
         CALL DLACPY( 'Full', M, NL, C, LDC, DWORK, M )
         JWORK = M*NL + 1
         CALL DGESVD( 'No left vectors', 'All right vectors', M, NL,
     $                DWORK, M, S, DWORK, 1, C, LDC, DWORK(JWORK),
     $                LDWORK-JWORK+1, INFO )
      END IF
C
      IF ( INFO.GT.0 ) THEN
C
C        Save the unconverged non-diagonal elements of the bidiagonal
C        matrix and exit.
C
         DO 10 J = 1, MINMNL - 1
            DWORK(J) = DWORK(JWORK+J)
   10    CONTINUE
C
         RETURN
      END IF
      WRKOPT = MAX( 2, INT( DWORK(JWORK) ) + JWORK - 1 )
C
C     Transpose V' in-situ (in C).
C
      DO 20 J = 2, NL
         CALL DSWAP( J-1, C(J,1), LDC, C(1,J), 1 )
   20 CONTINUE
C
C     Step 2: Compute the rank of the approximation [A+DA|B+DB].
C
      IF ( CTOL ) THEN
         TOLTMP = SQRT( TWO*DBLE( K ) )*TOL
         SMAX = TOLTMP
      ELSE
         TOLTMP = TOL
         IF ( TOLTMP.LE.ZERO ) TOLTMP = DLAMCH( 'Precision' )
         SMAX = MAX( TOLTMP*S(1), DLAMCH( 'Safe minimum' ) )
      END IF
C
      IF ( CRANK ) THEN
C        WHILE ( RANK .GT. 0 ) .AND. ( S(RANK) .LE. SMAX ) DO
   40    IF ( RANK.GT.0 ) THEN
            IF ( S(RANK).LE.SMAX ) THEN
               RANK = RANK - 1
               GO TO 40
            END IF
         END IF
C        END WHILE 40
      END IF
C
      IF ( L.EQ.0 ) THEN
         DWORK(1) = WRKOPT
         DWORK(2) = ONE
         RETURN
      END IF
C
      N1 = N + 1
      ITAU  = 1
      JWORK = ITAU + L
C
C     Step 3: Compute the orthogonal matrix Q and matrices F and Y
C     such that F is nonsingular.
C
C     REPEAT
C
C        Adjust the rank if S(RANK) has multiplicity greater than 1.
C
   60    CONTINUE
         R1 = RANK + 1
         IF ( RANK.LT.MINMNL ) THEN
C           WHILE RANK.GT.0 .AND. S(RANK)**2 - S(R1)**2.LE.TOL**2 DO
   80       IF ( RANK.GT.0 ) THEN
               IF ( ONE - ( S(R1)/S(RANK) )**2.LE.( TOLTMP/S(RANK) )**2
     $            ) THEN
                  RANK = RANK - 1
                  IWARN = 1
                  GO TO 80
               END IF
            END IF
C           END WHILE 80
         END IF
C
         IF ( RANK.EQ.0 ) THEN
C
C           Return zero solution.
C
            CALL DLASET( 'Full', N, L, ZERO, ZERO, X, LDX )
            DWORK(1) = WRKOPT
            DWORK(2) = ONE
            RETURN
         END IF
C
C        Compute the orthogonal matrix Q (in factorized form) and the
C        matrices F and Y using RQ factorization. It is assumed that,
C        generically, the last L rows of V2 matrix have full rank.
C        The code could not be the most efficient one when RANK has been
C        lowered, because the already created zero pattern of the last
C        L rows of V2 matrix is not exploited.
C        Workspace: need 2*L;  prefer L + L*NB.
C
         R1 = RANK + 1
         CALL DGERQF( L, NL-RANK, C(N1,R1), LDC, DWORK(ITAU),
     $                DWORK(JWORK), LDWORK-JWORK+1, INFO )
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
C
C        Workspace: need N+L;  prefer L + N*NB.
C
         CALL DORMRQ( 'Right', 'Transpose', N, NL-RANK, L, C(N1,R1),
     $                LDC, DWORK(ITAU), C(1,R1), LDC, DWORK(JWORK),
     $                LDWORK-JWORK+1, INFO )
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
C
         CALL DLASET( 'Full', L, N-RANK, ZERO, ZERO, C(N1,R1), LDC )
         IF ( L.GT.1 )
     $      CALL DLASET( 'Lower', L-1, L-1, ZERO, ZERO, C(N1+1,N1),
     $                   LDC )
C
C        Estimate the reciprocal condition number of the matrix F,
C        and lower the rank if F can be considered as singular.
C        Workspace: need 3*L.
C
         CALL DTRCON( '1-norm', 'Upper', 'Non-unit', L, C(N1,N1), LDC,
     $                RCOND, DWORK, IWORK, INFO )
         WRKOPT = MAX( WRKOPT, 3*L )
C
         FNORM = DLANTR( '1-norm', 'Upper', 'Non-unit', L, L, C(N1,N1),
     $                   LDC, DWORK )
         IF ( RCOND.LE.TOLTMP*FNORM ) THEN
            RANK = RANK - 1
            IWARN = 2
            GO TO 60
         ELSE IF ( FNORM.LE.TOLTMP*DLANGE( '1-norm', N, L, C(1,N1), LDC,
     $                                     DWORK ) ) THEN
            RANK = RANK - L
            IWARN = 2
            GO TO 60
         END IF
C     UNTIL ( F nonsingular, i.e., RCOND.GT.TOL*FNORM or
C                                  FNORM.GT.TOL*norm(Y) )
C
C     Step 4: Solve X F = -Y by forward elimination,
C             (F is upper triangular).
C
      CALL DLACPY( 'Full', N, L, C(1,N1), LDC, X, LDX )
      CALL DTRSM( 'Right', 'Upper', 'No transpose', 'Non-unit', N, L,
     $            -ONE, C(N1,N1), LDC, X, LDX )
C
C     Set the optimal workspace and reciprocal condition number of F.
C
      DWORK(1) = WRKOPT
      DWORK(2) = RCOND
C
      RETURN
C *** Last line of MB02MD ***
      END


       SUBROUTINE W3FA04(HEIGHT,PRESS,TEMP,THETA)
C$$$   SUBPROGRAM  DOCUMENTATION  BLOCK
C
C SUBPROGRAM: W3FA04         COMPUTE STADARD PRESSURE, TEMP, POT TEMP
C   AUTHOR: MCDONELL, J.     ORG: W345       DATE: JUL 74
C
C ABSTRACT: COMPUTES THE STANDARD PRESSURE, TEMPERATURE, AND POTEN-
C   TIAL TEMPERATURE GIVEN THE HEIGHT IN METERS ( < 32 KM ).    FOR
C   THE PRESSURE AND TEMPERATURE THE RESULTS DUPLICATE THE VALUES IN
C   THE U.S. STANDARD ATMOSPHERE (1962), WHICH IS THE ICAO STANDARD
C   ATMOSPHERE TO 54.7487 MB (20 KM) AND THE PROPOSED EXTENSION TO
C   8.68 MB (32 KM).  FOR POTENTIAL TEMPERATURE A VALUE OF  2/7  IS
C   USED FOR  RD/CP.
C
C PROGRAM HISTORY LOG:
C   74-06-01  J.MCDONELL
C   84-07-05  R.E.JONES   CHANGE TO IBM VS FORTRAN
C   90-04-27  R.E.JONES   CHANGE TO CRAY CFT77 FORTRAN
C
C USAGE:  CALL W3FA04 (HEIGHT, PRESS, TEMP, THETA)
C
C   INPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     HEIGHT ARG LIST  HEIGHT IN METERS
C
C   OUTPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     PRESS  ARG LIST  STANDARD PRESSURE IN MILLIBARS
C     TEMP   ARG LIST  TEMPERATURE IN DEGREES KELVIN
C     THETA  ARG LIST  POTENTIAL TEMPERATURE IN DEGREES KELVIN
C
C   SUBPROGRAMS CALLED:
C     NAMES                                                   LIBRARY
C     ------------------------------------------------------- --------
C     EXP                                                     SYSTEM
C
C   REMARKS: NOT VALID FOR HEIGHTS GREATER THAN 32 KM.
C     DECLARE ALL PARAMETERS AS TYPE REAL*4
C
C ATTRIBUTES:
C   LANGUAGE: INCLUDE VENDOR EXTENSIONS USED.
C
C ATTRIBUTES:
C   LANGUAGE: CRAY CFT77 FORTRAN
C   MACHINE:  CRAY Y-MP/832
C
C$$$
C
      REAL  M0
C
      DATA
     *G     /9.80665/,
     *RSTAR /8314.32/,
     *M0    /28.9644/,
     *PISO  /54.7487/,
     *ZISO  /20000./,
     *SALP  /-.0010/,
     *TSTR  /216.65/,
     *PTROP /226.321/,
     *ALP   /.0065/,
     *T0    /288.15/,
     *PZERO /1013.25/
C
      ROVCP = 2.0 / 7.0
      R     = RSTAR/M0
      IF (HEIGHT.GT.ZISO)   GO TO 100
      IF (HEIGHT.GT.11000.) GO TO 200
C
C     COMPUTE IN TROPOSPHERE
C
      TEMP = T0 - HEIGHT * ALP
      PRESS = PZERO * ((1.0 - ((ALP/T0) * HEIGHT)) ** (G/(ALP * R)))
      GO TO 300
C
C     COMPUTE LAPSE RATE = -.0010 CASES
C
 100  CONTINUE
      D     = HEIGHT - ZISO
      PRESS = PISO * ((1.-(( SALP /TSTR) * D  )) ** (G/( SALP * R)))
      TEMP  = TSTR - D * SALP
      GO TO 300
C
C     COMPUTE ISOTHERMAL CASES
C
 200  CONTINUE
      D     = EXP((HEIGHT - 11000.0) / ((R / G) * TSTR))
      PRESS = PTROP / D
      TEMP  = TSTR
C
 300  CONTINUE
      THETA = TEMP * ((1000.0 / PRESS) ** ROVCP)
      RETURN
      END


module extend_mesh
    use mesh
    use mod_func
    implicit none

    real(8) :: xc,yc,zc   !center for mesh, used in bodyforce.f90
    real(8),allocatable:: SAMB(:,:,:),SAMBXY(:,:,:),DSAMB(:,:,:)
contains
    subroutine comp_gaussian_info()
        iMPLICIT   NONE

      INTEGER IE,K,J,LK,LI,LJ,ISI,IETA,NSAMB,IND
        REAL*8 XITSI(4),XITETA(4),WIT(4),XIQ(4),WIQ(4)
        REAL*8 SF(8),DSF(2,8),XJ(3,3)

        REAL*8 DET,DET1,DET2,DET3,DUM,SI,ETA

!C
!C
!C ** matrix XITSI store the Gauss-Legendre sampling points(3) for the
!C    triangular element in SI coordinate
!C
        DATA XITSI/0.333333333333333D0, 0.6D0, 0.2D0, 0.2D0/
!C
!C ** matrix XITETA store the Gauss-Legendre sampling points(3) for the
!C    triangular element in ETA coordinate
!C
        DATA XITETA/0.333333333333333D0, 0.2D0, 0.6D0, 0.2D0/

!C
!C ** matrix WIT store the Gauss-Legendre weighting factors for the
!C    triangular element in SI coordinate
!C
        DATA WIT/-0.28125D0,.260416666666667D0,.260416666666667D0,&
     &          .260416666666667D0/
!C
!C
!C ** matrix XIQ store the Gauss-Legendre sampling points(3) for the
!C    quadrilateral element
!c
        DATA XIQ/-0.861136311594053D0,-0.339981043584856D0,&
     &          0.339981043584856D0, 0.861136311594053D0/
!C
!C ** matrix WIQ store the Gauss-Legendre weighting factors for the
!C    quadrilateral element
!c
        DATA WIQ/0.347854845137454D0,0.652145154862546D0,&
     &         0.652145154862546D0,0.347854845137454D0/
!c
!C
        DO 500 IE=1, NELEM
!c   Print *,' I=',I
!C
        NSAMB=0
!c
!c       NSAMB:  codes of sampling points inside an element
!C
        IF(NCN(IE).EQ.8) THEN
!C
!C ** Quadrilateral element **
!C
        DO 110 ISI=1,4
        DO 120 IETA=1,4
        NSAMB=NSAMB+1
!c   Print *,' NSAMB=',NSAMB
!C
!C **  calculate the shape function at the sampling points
!C
        SI =XIQ(ISI)
        ETA=XIQ(IETA)

        CALL SPFUNC8(SI,ETA,SF,DSF)
!C
!C ** evaluate the Jacobian matrix at (SI,ETA),  XJ(2,3)
!C
!c       LI: 1--SI,  2--ETA
!c       LJ: 1--X,   2--Y,   3--Z
!c
      DO 130 LI=1,2
      DO 130 LJ=1,3
      DUM=0.0D0
      DO 140 LK=1, NCN(IE)
      DUM=DUM+DSF(LI,LK)*XYZE(LJ,LK,IE)
!      DUM=DUM+DSF(LI,LK)*XYZ(LJ,NCON(IE,LK))  XYZE(3,J,IE)
140   CONTINUE
130   XJ(LI,LJ)=DUM
!C
!C ** compute the determinant of the Jacobian maxtix at (SI,ETA), DET
!C
      DET1=XJ(1,2)*XJ(2,3)-XJ(1,3)*XJ(2,2)
      DET2=XJ(1,1)*XJ(2,3)-XJ(1,3)*XJ(2,1)
      DET3=XJ(1,1)*XJ(2,2)-XJ(1,2)*XJ(2,1)
      DET=DSQRT(DET1*DET1+DET2*DET2+DET3*DET3)
!C
!C ** transform the local coordinates of the sampling points to
!C    global coordinates
!C
!c       SAMBXY=??
!c       I: code of the element,  LI:1--X, 2--Y, 3--Z
!c       NCON:code of the node in the global mesh
!c       NSAMB:
!c       SF: shape function
!c
      DO 160 LI=1,3
      SAMBXY(IE,NSAMB,LI)=0.0D0
      DO 170 LK=1,NCN(IE)
      SAMBXY(IE,NSAMB,LI)=SAMBXY(IE,NSAMB,LI)+SF(LK)*XYZE(LI,LK,IE)
170   CONTINUE
160   CONTINUE

      DO 180 LI=1,3
      DSAMB(IE,NSAMB,LI)=0.0D0
      DO 190 LK=1,NCN(IE)
      DSAMB(IE,NSAMB,LI)=DSAMB(IE,NSAMB,LI)+SF(LK)*DXYZE(LI,LK,IE)
190   CONTINUE
180   CONTINUE

      DSAMB(IE,NSAMB,4)=(SAMBXY(IE,NSAMB,2)-YC)*DSAMB(IE,NSAMB,3)-&
     &      (SAMBXY(IE,NSAMB,3)-ZC)*DSAMB(IE,NSAMB,2)
      DSAMB(IE,NSAMB,5)=(SAMBXY(IE,NSAMB,3)-ZC)*DSAMB(IE,NSAMB,1)-&
     &      (SAMBXY(IE,NSAMB,1)-XC)*DSAMB(IE,NSAMB,3)
      DSAMB(IE,NSAMB,6)=(SAMBXY(IE,NSAMB,1)-XC)*DSAMB(IE,NSAMB,2)-&
     &      (SAMBXY(IE,NSAMB,2)-YC)*DSAMB(IE,NSAMB,1)
!C
!C ** calculate the free surface boundary condition*WIT*DET
!C
      SAMB(IE,NSAMB,0)=WIQ(ISI)*WIQ(IETA)*DET

      DO 20 J=1,NCN(IE)
      SAMB(IE,NSAMB,J)=SF(J)*WIQ(ISI)*WIQ(IETA)*DET
20    CONTINUE
!C
!c   Print *,' 8  SAMB=',SAMB(IE,NSAMB,0)

120   CONTINUE
110   CONTINUE

      ELSE
!C
!C ** for triangular element **
!C
      DO 210 J=1, 4
      NSAMB=NSAMB+1
!C
!C **  calculate the shape function at the sampling points
!C
      SI =XITSI(J)
      ETA=XITETA(J)

      CALL SPFUNC6(SI,ETA,SF,DSF)
!C
!C ** evaluate the Jacobian matrix at (SI,ETA)
!C
      DO 230 LI=1,2
      DO 230 LJ=1,3
      DUM=0.0D0
      DO 240  LK=1, NCN(IE)
      DUM=DUM+DSF(LI,LK)*XYZE(LJ,LK,IE)
240   CONTINUE
230   XJ(LI,LJ)=DUM
!C
!C ** compute the determinant of the Jacobian maxtix at (SI,ETA)
!C
      DET1=XJ(1,2)*XJ(2,3)-XJ(1,3)*XJ(2,2)
      DET2=XJ(1,1)*XJ(2,3)-XJ(1,3)*XJ(2,1)
      DET3=XJ(1,1)*XJ(2,2)-XJ(1,2)*XJ(2,1)
      DET=DSQRT(DET1*DET1+DET2*DET2+DET3*DET3)
!C
!C ** transform the local coordinates of the sampling points to
!C    global coordinates
!C
      DO 260 LI=1,3
      SAMBXY(IE,NSAMB,LI)=0.0D0
      DO 270 LK=1,NCN(IE)
      SAMBXY(IE,NSAMB,LI)=SAMBXY(IE,NSAMB,LI)+SF(LK)*XYZE(LI,LK,IE)
270   CONTINUE
260   CONTINUE

      DO 280 LI=1,3
      DSAMB(IE,NSAMB,LI)=0.0D0
      DO 290 LK=1,NCN(IE)
      DSAMB(IE,NSAMB,LI)=DSAMB(IE,NSAMB,LI)+SF(LK)*DXYZE(LI,LK,IE)
290   CONTINUE
280   CONTINUE

     DSAMB(IE,NSAMB,4)=(SAMBXY(IE,NSAMB,2)-YC)*DSAMB(IE,NSAMB,3)-&
     &      (SAMBXY(IE,NSAMB,3)-ZC)*DSAMB(IE,NSAMB,2)
       DSAMB(IE,NSAMB,5)=(SAMBXY(IE,NSAMB,3)-ZC)*DSAMB(IE,NSAMB,1)-&
     &      (SAMBXY(IE,NSAMB,1)-XC)*DSAMB(IE,NSAMB,3)
       DSAMB(IE,NSAMB,6)=(SAMBXY(IE,NSAMB,1)-XC)*DSAMB(IE,NSAMB,2)-&
     &      (SAMBXY(IE,NSAMB,2)-YC)*DSAMB(IE,NSAMB,1)
!C
!C ** calculate the free surface boundary condition*WIT*DET
!C
      SAMB(IE,NSAMB,0)=WIT(J)*DET

      DO 30 K=1,NCN(IE)
      SAMB(IE,NSAMB,K)=SF(K)*WIT(J)*DET
30    CONTINUE
!c   Print *,'6   SAMB=',SAMB(IE,NSAMB,1)

220   CONTINUE
210   CONTINUE

      ENDIF

500    CONTINUE

!
     DO IND=1, NNODED

     DXYZ(4,IND)=(XYZ(2,IND)-YC)*DXYZ(3,IND)-&
     &             (XYZ(3,IND)-ZC)*DXYZ(2,IND)
       DXYZ(5,IND)=(XYZ(3,IND)-ZC)*DXYZ(1,IND)-&
     &             (XYZ(1,IND)-XC)*DXYZ(3,IND)
       DXYZ(6,IND)=(XYZ(1,IND)-XC)*DXYZ(2,IND)-&
     &             (XYZ(2,IND)-YC)*DXYZ(1,IND)
    ENDDO

      RETURN
      END
end module


program test_array_equality
implicit none
integer, parameter :: n = 3, a(n)=[1,2,3], &
   b(n)=[1,2,3], c(n) = [1,2,4]
logical :: ab_equal
write(*,*) a == b ! This returns an array, T T T
! Below does not work since A==B is an array
! if (A == B) write(*,*) "A and B are equal"
print*,all(a == b), all(a == b+1) ! T F
print*,all(a == c), any(a == c)   ! F T
! How to test if two arrays are equal using a loop
compare: block
integer :: i ! exists only within block
ab_equal = .false.
if (size(a) == size(b)) then
   do i=1,size(a)
      ab_equal = a(i) == b(i)
      if (.not. ab_equal) exit
   end do
end if
end block compare
print*,"a same as b?",ab_equal,equal(a,b)
!
contains
! function to test equality of 1D arrays
! unlike the expression all(m == n) it can be used
! when size(m) /= size(n)
pure function equal(m,n) result(tf)
integer, intent(in) :: m(:),n(:)
logical             :: tf
integer             :: i
tf = .false.
if (size(m) /= size(n)) return
do i=1,size(m)
   if (m(i) /= n(i)) return
end do
tf = .true.
end function equal
!
end program test_array_equality


module bessel_mod

contains

  REAL (KIND=8) FUNCTION BESSI0(X)

    REAL *8 X,Y,P1,P2,P3,P4,P5,P6,P7,  &
         Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9,AX,BX
    DATA P1,P2,P3,P4,P5,P6,P7/1.D0,3.5156229D0,3.0899424D0,1.2067429D0,  &
         0.2659732D0,0.360768D-1,0.45813D-2/
    DATA Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9/0.39894228D0,0.1328592D-1, &
         0.225319D-2,-0.157565D-2,0.916281D-2,-0.2057706D-1,  &
         0.2635537D-1,-0.1647633D-1,0.392377D-2/
    IF(ABS(X).LT.3.75D0) THEN
       Y=(X/3.75D0)**2
       BESSI0=P1+Y*(P2+Y*(P3+Y*(P4+Y*(P5+Y*(P6+Y*P7)))))
    ELSE
       AX=ABS(X)
       Y=3.75D0/AX
       BX=EXP(AX)/SQRT(AX)
       AX=Q1+Y*(Q2+Y*(Q3+Y*(Q4+Y*(Q5+Y*(Q6+Y*(Q7+Y*(Q8+Y*Q9)))))))
       BESSI0=AX*BX
    ENDIF
    RETURN
  END FUNCTION BESSI0

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

  REAL (KIND=8) FUNCTION BESSI1(X)

    REAL *8 X,Y,P1,P2,P3,P4,P5,P6,P7,  &
         Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9,AX,BX
    DATA P1,P2,P3,P4,P5,P6,P7/0.5D0,0.87890594D0,0.51498869D0,  &
         0.15084934D0,0.2658733D-1,0.301532D-2,0.32411D-3/
    DATA Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9/0.39894228D0,-0.3988024D-1, &
         -0.362018D-2,0.163801D-2,-0.1031555D-1,0.2282967D-1, &
         -0.2895312D-1,0.1787654D-1,-0.420059D-2/
    IF(ABS(X).LT.3.75D0) THEN
       Y=(X/3.75D0)**2
       BESSI1=X*(P1+Y*(P2+Y*(P3+Y*(P4+Y*(P5+Y*(P6+Y*P7))))))
    ELSE
       AX=ABS(X)
       Y=3.75D0/AX
       BX=EXP(AX)/SQRT(AX)
       AX=Q1+Y*(Q2+Y*(Q3+Y*(Q4+Y*(Q5+Y*(Q6+Y*(Q7+Y*(Q8+Y*Q9)))))))
       BESSI1=AX*BX
    ENDIF
    RETURN
  END FUNCTION BESSI1

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

  REAL (KIND=8) FUNCTION BESSI(N,X)

    PARAMETER (IACC = 40,BIGNO = 1.D10, BIGNI = 1.D-10)
    REAL *8 X,TOX,BIM,BI,BIP

    IF (N.EQ.0) THEN
       BESSI = BESSI0(X)
       RETURN
    ENDIF
    IF (N.EQ.1) THEN
       BESSI = BESSI1(X)
       RETURN
    ENDIF
    IF(X.EQ.0.D0) THEN
       BESSI=0.D0
       RETURN
    ENDIF
    TOX = 2.D0/X
    BIP = 0.D0
    BI  = 1.D0
    BESSI = 0.D0
    M = 2*((N+INT(SQRT(FLOAT(IACC*N)))))
    DO J = M,1,-1
       BIM = BIP+DFLOAT(J)*TOX*BI
       BIP = BI
       BI  = BIM
       IF (ABS(BI).GT.BIGNO) THEN
          BI  = BI*BIGNI
          BIP = BIP*BIGNI
          BESSI = BESSI*BIGNI
       ENDIF
       IF (J.EQ.N) BESSI = BIP
    END DO
    BESSI = BESSI*BESSI0(X)/BI
    RETURN
  END FUNCTION BESSI

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

  REAL (KIND=8) FUNCTION BESSK0(X)

    REAL*8 X,Y,AX,P1,P2,P3,P4,P5,P6,P7,Q1,Q2,Q3,Q4,Q5,Q6,Q7

    DATA P1,P2,P3,P4,P5,P6,P7/-0.57721566D0,0.42278420D0,0.23069756D0, &
         0.3488590D-1,0.262698D-2,0.10750D-3,0.74D-5/
    DATA Q1,Q2,Q3,Q4,Q5,Q6,Q7/1.25331414D0,-0.7832358D-1,0.2189568D-1, &
         -0.1062446D-1,0.587872D-2,-0.251540D-2,0.53208D-3/
    IF(X.EQ.0.D0) THEN
       BESSK0=1.D30
       RETURN
    ENDIF
    IF(X.LE.2.D0) THEN
       Y=X*X/4.D0
       AX=-LOG(X/2.D0)*BESSI0(X)
       BESSK0=AX+(P1+Y*(P2+Y*(P3+Y*(P4+Y*(P5+Y*(P6+Y*P7))))))
    ELSE
       Y=(2.D0/X)
       AX=EXP(-X)/SQRT(X)
       BESSK0=AX*(Q1+Y*(Q2+Y*(Q3+Y*(Q4+Y*(Q5+Y*(Q6+Y*Q7))))))
    ENDIF
    RETURN
  END FUNCTION BESSK0

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

  REAL (KIND=8) FUNCTION BESSK1(X)

    REAL*8 X,Y,AX,P1,P2,P3,P4,P5,P6,P7,Q1,Q2,Q3,Q4,Q5,Q6,Q7

    DATA P1,P2,P3,P4,P5,P6,P7/1.D0,0.15443144D0,-0.67278579D0,  &
         -0.18156897D0,-0.1919402D-1,-0.110404D-2,-0.4686D-4/
    DATA Q1,Q2,Q3,Q4,Q5,Q6,Q7/1.25331414D0,0.23498619D0,-0.3655620D-1, &
         0.1504268D-1,-0.780353D-2,0.325614D-2,-0.68245D-3/
    IF(X.EQ.0.D0) THEN
       BESSK1=1.D32
       RETURN
    ENDIF
    IF(X.LE.2.D0) THEN
       Y=X*X/4.D0
       AX=LOG(X/2.D0)*BESSI1(X)
       BESSK1=AX+(1.D0/X)*(P1+Y*(P2+Y*(P3+Y*(P4+Y*(P5+Y*(P6+Y*P7))))))
    ELSE
       Y=(2.D0/X)
       AX=EXP(-X)/SQRT(X)
       BESSK1=AX*(Q1+Y*(Q2+Y*(Q3+Y*(Q4+Y*(Q5+Y*(Q6+Y*Q7))))))
    ENDIF
    RETURN
  END FUNCTION BESSK1

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

  REAL (KIND=8) FUNCTION BESSK(N,X)

    REAL *8 X,TOX,BK,BKM,BKP

    IF (N.EQ.0) THEN
       BESSK = BESSK0(X)
       RETURN
    ENDIF
    IF (N.EQ.1) THEN
       BESSK = BESSK1(X)
       RETURN
    ENDIF
    IF (X.EQ.0.D0) THEN
       BESSK = 1.D30
       RETURN
    ENDIF
    TOX = 2.D0/X
    BK  = BESSK1(X)
    BKM = BESSK0(X)
    DO J=1,N-1
       BKP = BKM+DFLOAT(J)*TOX*BK
       BKM = BK
       BK  = BKP
    ENDDO
    BESSK = BK
    RETURN
  END FUNCTION BESSK

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

end module bessel_mod


program rk45test

    use kindmodule
    use mathmodule
    use constmodule
    use rk45module
    use derivmodule
    use intplotmodule

    ! DECLARATION
    implicit none

    abstract interface
        subroutine func(t,x,xdot)
            use kindmodule
            complex(wp),intent(in) :: t
            complex(wp),intent(in),dimension(:) :: x
            complex(wp),intent(out),dimension(:) :: xdot
        end subroutine func
    end interface

    procedure (func), pointer :: f_ptr => null()
    type(IntegratorIn) :: intin
    type(IntegratorOut) :: intout
    complex(wp),allocatable :: error(:)

    integer :: i,timeiter

    real(wp) :: starttime, endtime

    ! EXECUTION
    intin%n = 6
    intin%t0 = 0.0_wp
    intin%tf = 2.0_wp*pi
    intin%h0 = 1.0e-8_wp
    intin%tol = 1e-12_wp
    allocate(intin%x0(6))
    !intin%x0 = [0.7816_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.4432_wp, 0.0_wp]
    intin%x0 = [1.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 1.0_wp, 0.0_wp]

    f_ptr => dkep

    timeiter = 100
    call CPU_TIME(starttime)
    do i=1,timeiter
        call rk45(f_ptr, intin, intout)
    end do
    call CPU_TIME(endtime)
    print *, (endtime-starttime)/real(timeiter)

    allocate(error(6))
    error = intin%x0 - intout%xout(size(intout%tout),:)
    print *, real(astnorm(error))
    print *, real(intin%x0(1:3))
    print *, real(intout%xout(size(intout%tout),1:3))

    call resetpoints
    do i=1,size(intout%tout)
        call addpoint(real(intout%xout(i,1), sp), real(intout%xout(i,2), sp))
    end do
    call intplotstart(600,600)

    ! Cleanup
    deallocate(intin%x0)

    deallocate(intout%tout)
    deallocate(intout%eout)
    deallocate(intout%hout)
    deallocate(intout%xout)

end program rk45test


       function dev_2(T)
        implicit none

        type(Tensor2), intent(in) :: T
        type(Tensor2) :: dev_2,Eye

        Eye = identity2(Eye)
        dev_2%ab = T%ab - tr(T)/3.d0*Eye%ab

       end function dev_2

       function dev_2s(T)
        implicit none

        type(Tensor2s), intent(in) :: T
        type(Tensor2s) :: dev_2s,Eye

        Eye = identity2(Eye)
        dev_2s%a6 = T%a6 - tr(T)/3.d0*Eye%a6

       end function dev_2s


C++***************************************************************
C SP_BACK
C Program to remove the background from a spectrum.
C Fits a polynomial, and then subtract this fit
C Designed for Parkes data (256 channels)
C
C Version of 03-10-90
C--**************************************************************
	PROGRAM SP_BACK
	PARAMETER (IDIM=2000)
	REAL*8 XX(IDIM),YY(IDIM),YY1(IDIM)
	REAL*8 XC(20),SDEV(20),ERR
	REAL*4 CVELOCITY,XLOW(20),XHIGH(20)
	REAL*4 X1(IDIM),Y1(IDIM),Y2(IDIM)
	REAL*4 XOUT,YOUT
	INTEGER*4 NPTS,NOUT,KK,NPTS1
	LOGICAL PLAN
	INTEGER*4 INOPROMPT
	CHARACTER LIMITS_USER*80,LIMITS_HARD*80,PLOTDEV2*32
	CHARACTER ANS*1,PLOTDEV*32
	CHARACTER INFILE*40,OUTFILE*40,COMMENTS*80,BUFFER*80
	CHARACTER CHAR1*30,CHAR2*30,TITLE*40,NCHAR*4,PCOLOR*30

C Common block for cursor:
	COMMON /STR_OUTPUT/XOUT(200),YOUT(200),NOUT
C Common block for NEWPLOT:
	COMMON/NEWPLOT1/INOPROMPT,PLAN,LIMITS_USER,PLOTDEV2,
     1	LIMITS_HARD

	CALL JLP_BEGIN
10	FORMAT(A)

	PRINT 88
88	FORMAT(' Program SP_BACK to subtract the background from a',
     1	' profile/spectrum',/,
     1	' Designed for Parkes data (256 channels)')

	PRINT *,' Graphic device? (for direct plot)'
	READ(5,10) PLOTDEV

C Reading the input file :
	WRITE(6,*) ' Input ASCII file ?'
	READ(5,10) INFILE
	OPEN(1,FILE=INFILE,STATUS='OLD',ACCESS='SEQUENTIAL')
	READ(1,10) BUFFER
	READ(BUFFER,*) X1(1),Y1(1)
	I=INDEX(BUFFER(27:80),' ')+26
	COMMENTS=BUFFER(I:80)
	  DO I=2,IDIM
	   READ(1,*,END=57) X1(I),Y1(I)
	  END DO
57	CLOSE(1)
	NPTS=I-1

	CVELOCITY=X1(128)
	WRITE(6,35) COMMENTS(1:53),CVELOCITY
35	FORMAT(' Comments: ',A53,/,' Central velocity:',G12.3)

C Graphic options:
	PLAN='N'
	INOPROMPT=1
	PLOTDEV2='N'
	LIMITS_HARD=' '
	V1=X1(241)
	V2=X1(15)
	F1=-0.5
	F2=1.
	WRITE(LIMITS_USER,*)V1,V2,F1,F2

	CHAR1='V helio (km/s)'
	CHAR2='Flux (Jy)'
	TITLE=COMMENTS(1:40)
	NCHAR='L0'
	PCOLOR='Default'
	WRITE(6,28)
28	FORMAT(' Displaying the curves (Use the cursor',
     1	' to set the limits of the zones selected for the fit)')
62	CALL NEWPLOT(X1,Y1,NPTS,IDIM,1,CHAR1,CHAR2,TITLE,
     1	NCHAR,PCOLOR,PLOTDEV,INFILE,COMMENTS)

	PRINT *,' Do you want to display the curve again? (N)'
	READ(5,10) ANS
	IF(ANS.EQ.'Y'.OR.ANS.EQ.'y')GOTO 62

C*****************************************************************
C Check if an even number of points have been entered:
	NZONES=NOUT/2
	ITEST=NZONES*2
	IF(ITEST.EQ.NOUT.AND.ITEST.NE.0)THEN
	  WRITE(6,39) NZONES
39	  FORMAT(' Number of zones for the fit: ',I3)
	  DO K=1,NZONES
	    I=(2*K)-1
	    XLOW(K)=XOUT(I)
	    XHIGH(K)=XOUT(I+1)
	    WRITE(6,38) K,XLOW(K),XHIGH(K)
38	    FORMAT(' Zone number ',I3,' Limits: ',2(G12.3,X))
	  END DO

	ELSE

C Displaying the coordinates of the points drawn by the cursor, if any:
	  DO I=1,NOUT
	    PRINT *,' I, X, Y :',I,XOUT(I),YOUT(I)
	  END DO

52	  PRINT *,' Number of zones you want to select for the fit? (0=all)'
	  READ(5,*) NZONES

	  DO K=1,NZONES
	    PRINT *,' Lower and upper limits for zone number:',K,' ?'
	    READ(5,*) XLOW(K),XHIGH(K)
	  END DO

C If no points, takes everything (except the edges...)
	  NZONES=NZONES+1
	  XLOW(NZONES)=X1(245)
	  XHIGH(NZONES)=X1(15)

	ENDIF

C*****************************************************************
63	PRINT *,' Order of the polynomial?'
	READ(5,*) KK

C Conversion to double precision:
	DO I=1,NPTS
	  XX(I)=X1(I)
	  YY(I)=Y1(I)
	END DO

C Selection of the fit points:
	NPTS1=NPTS
	CALL SP_SELECT(XX,YY,XLOW,XHIGH,NPTS1,NZONES)
	IF(NPTS1.EQ.0)THEN
	  PRINT *,' Error: 0 point(s) have been selected !'
	  GOTO 52
	ENDIF

C Fitting a polynomial :
	  PRINT *,' Fitting the Polynomial now ...'
	  CALL POLYFIT(XX,YY,NPTS1,KK,XC,SDEV,ERR)

	  WRITE(6,25) ERR
25	  FORMAT(' Mean error rms :',G10.3)
	   DO K=1,KK+1
	     WRITE(6,26) K-1,XC(K),SDEV(K)
26	     FORMAT(' Order: ',I3,' Coeff: ',G10.3,' Error: ',G10.3)
	   END DO

C Conversion to double precision:
	DO I=1,NPTS
	  XX(I)=X1(I)
	  YY(I)=Y1(I)
	END DO

C Computing the model:
	    DO I=1,NPTS
	      CALL CALPOLY(XX(I),YY1(I),XC,KK)
	    END DO

C Plotting the result:
	  DO I=1,NPTS
	   Y2(I)=Y1(I)-YY1(I)
	  END DO

C Limits for the plot:
	F1=-0.15
	F2=0.3
	WRITE(LIMITS_USER,*)V1,V2,F1,F2

	TITLE=COMMENTS(1:40)
	PLOTDEV2='N'
C	PLOTDEV2='*PGPLOT.PLT/VERSA'
	LIMITS_HARD=' '
	WRITE(6,29)
29	FORMAT(' Displaying the curves (you can use the cursor',
     1	' to get the coordinates to measure the noise...')
	CALL NEWPLOT(X1,Y2,NPTS,IDIM,1,CHAR1,CHAR2,TITLE,
     1	NCHAR,PCOLOR,PLOTDEV,INFILE,COMMENTS)
C Displaying the coordinates of the points drawn by the cursor, if any:
	DO I=1,NOUT
	  PRINT *,' I, X, Y :',I,XOUT(I),YOUT(I)
	END DO

	IF(NOUT.EQ.2)THEN
	  XLO=XOUT(1)
	  XHI=XOUT(2)
	ELSE
	  PRINT *,' Enter lower and upper limit for noise computation:'
	  READ(5,*) XLO,XHI
	ENDIF

	CALL SP_NOISE(X1,Y2,NPTS,XLO,XHI)

	PRINT *,' Do you want to change the order of the polynomial? (N)'
	READ(5,10) ANS
	IF(ANS.EQ.'Y'.OR.ANS.EQ.'y')GOTO 63

	PRINT *,' Do you want to change the selection boundaries? (N)'
	READ(5,10) ANS
	IF(ANS.EQ.'Y'.OR.ANS.EQ.'y')GOTO 62

C Storing the output in an ASCII file :
	WRITE(6,*) ' Output ASCII file ?'
	READ(5,10) OUTFILE
	OPEN(2,FILE=OUTFILE,STATUS='NEW',ACCESS='SEQUENTIAL')
	BUFFER=' '
	WRITE(BUFFER,*) X1(1),Y1(1)
	BUFFER(32:80)=COMMENTS(1:49)
	WRITE(2,10) BUFFER
	  DO I=2,NPTS
	   WRITE(2,*) X1(I),Y2(I)
	  END DO
	CLOSE(2)

 	CALL JLP_END
	STOP
	END
C----------------------------------------------------------------------
C SP_SELECT
C To select a zone between XLOW and XHIGH for the fit (compact the
C array in output and update NPTS)
C---------------------------------------------------------------------
	SUBROUTINE SP_SELECT(X1,Y1,XLOW,XHIGH,NPTS,NZONES)
	REAL*8 X1(*),Y1(*)
	REAL*4 XLOW(*),XHIGH(*)
	INTEGER*4 NPTS,NZONES
	LOGICAL GOOD

	IF(NZONES.LE.0)THEN
	  PRINT *,' SP_SELECT/ 0 zone(s) selected'
	  RETURN
	ENDIF

	II=0
	DO I=1,NPTS
	  GOOD=.FALSE.
	  DO K=1,NZONES
	   IF(X1(I).GE.XLOW(K).AND.X1(I).LE.XHIGH(K)) GOOD=.TRUE.
	  END DO
	  IF(GOOD)THEN
	   II=II+1
	   X1(II)=X1(I)
	   Y1(II)=Y1(I)
	  ENDIF
	END DO

	NPTS=II
	RETURN
	END
C----------------------------------------------------------------------
	SUBROUTINE SP_NOISE(X,Y,NPTS,XLOW,XHIGH)
	REAL*4 X(NPTS),Y(NPTS)
	REAL*8 SUM,SUMSQ
	REAL*4 XMEAN,SIGMA

	IF(XHIGH.LE.XLOW)THEN
	  PRINT *,' SP_NOISE/Wrong limits'
	  RETURN
	ENDIF

	SUM=0.
	SUMSQ=0.
	K=0
	DO I=1,NPTS
	  IF(X(I).GE.XLOW.AND.X(I).LE.XHIGH)THEN
	    K=K+1
	    SUM=SUM+Y(I)
	    SUMSQ=SUMSQ+Y(I)*Y(I)
	  ENDIF
	END DO

	IF(K.NE.0)THEN
	  XMEAN=SUM/FLOAT(K)
	  SIGMA=SQRT(SUMSQ/FLOAT(K)-XMEAN*XMEAN)
	  WRITE(6,23) XMEAN,SIGMA
23	  FORMAT(' Mean, sigma',2(G10.3))
	ENDIF

	RETURN
	END
C**********************************************************************
	include 'jlpsub:polyfit.for'


      double precision function slotted_disk_sum(x,y,z)
      implicit none

      double precision x,y,z

      double precision wcloc(3,2)
      common /location_parms/ wcloc

      double precision r, hmax, b, c
      common /slotteddisk_parms/ r, hmax, b, c

      integer m, k
      double precision w(3), q, qv, slotted_disk

      q = 0
      do m = 1,2
         do k = 1,3
            w(k) = wcloc(k,m)
         end do
         qv = slotted_disk(x,y,z,w,r,hmax,m)
         q = q + qv
      enddo

      slotted_disk_sum = b + c*q
      end

      double precision function slotted_disk(x,y,z,w,r,hmax,
     &      which_disk)
      implicit none

      double precision x,y,z,w(3),r,hmax
      integer which_disk

      double precision th, lambda, thi, li, q
      double precision get_gc_distance, ri

      ri = get_gc_distance(x,y,z,w)

      call map2polar(w(1),w(2),w(3),lambda,th)
      call map2polar(x,y,z,li,thi)

c     # Default value
      q = 0

c     # Now check to if we are in a disk
      if (ri .lt. r) then
         if (abs(lambda - li) .gt. r/6.d0) then
            q = 1.d0
         else
            if (which_disk .eq. 1) then
               if (th - thi .gt. 5.d0*r/12) then
                  q = 1.d0
               endif
            else
               if (th - thi .lt. -5.d0*r/12) then
                  q = 1.d0
               endif
            endif
         endif
      endif

      slotted_disk = q

      end


program pi
  implicit none
  integer,dimension(3350) :: vect
  integer,dimension(201) :: buffer
  integer :: more,karray,num,k,l,n
  more = 0
  vect = 2
  do n = 1,201
    karray = 0
    do l = 3350,1,-1
      num = 100000*vect(l) + karray*l
      karray = num/(2*l - 1)
      vect(l) = num - karray*(2*l - 1)
    end do
    k = karray/100000
    buffer(n) = more + k
    more = karray - k*100000
  end do
  write (*,'(i2,"."/(1x,10i5.5))') buffer
end program pi


!> This subroutine calculates the exact equilibrium
!! reduced density matrix in the site basis using the
!! methodology described in
!! PHYSICAL REVIEW B 85, 115412 (2012)
SUBROUTINE calculate_equilibrium_site_mpi
    USE kinds
    USE random_numbers
    USE harmonic_bath
    USE hamiltonians
    USE linear_algebra
    USE unit_conversions
    USE imaginary_time
    USE input_output
    USE mpi_variables
    IMPLICIT NONE
    INTEGER :: istate, itraj, istep
    REAL(dp) :: beta, dt, trace
    REAL(dp) :: hel_eigenvectors( nstate, nstate )
    REAL(dp) :: hel_eigenvalues( nstate )
    REAL(dp) :: covariance_matrix( 0 : nbstep, 0 : nbstep, nstate )
    REAL(dp) :: covariance_eigenvectors_inverse( 0 : nbstep, 0 : nbstep, nstate )
    REAL(dp) :: covariance_eigenvalues( 0 : nbstep, nstate )
    REAL(dp) :: temporary( 0 : nbstep, 0 : nbstep )
    REAL(dp) :: equilibrium_site_populations( nstate )
    REAL(dp) :: sum_equilibrium_site_populations( nstate )
    REAL(dp) :: redmat( nstate, nstate )
    REAL(dp) :: redmat_init( nstate, nstate )
    REAL(dp) :: system_propagator( nstate, nstate ), bath_propagator( nstate, nstate )
    REAL(dp) :: xi( 0 : nbstep, nstate )
    hel_eigenvectors = 0.0_dp ; hel_eigenvalues = 0.0_dp ; covariance_matrix = 0.0_dp
    covariance_eigenvectors_inverse = 0.0_dp ; covariance_eigenvalues = 0.0_dp
    equilibrium_site_populations = 0.0_dp ; redmat = 0.0_dp ; redmat_init = 0.0_dp
    system_propagator = 0.0_dp ; bath_propagator = 0.0_dp ; dt = 0.0_dp ; trace = 0.0_dp

    ! Set Boltzmann according to input temperature
    beta = 1.0_dp / ( temperature * convert('kelvin','au_energy') )
    dt = beta / nbstep

    ! Read the input electonic Hamiltonian
    CALL read_hel ; hel = hel * convert('wvnbr','au_energy')

    ! Initialize in the high temperature limit, all states equally populated
    DO istate = 1, nstate
        redmat_init( istate, istate ) = 1.0_dp / nstate
    END DO

    ! Initialize the imaginary time covariance matrix using the input continuum spectral density
    CALL get_covariance_matrix( covariance_matrix, beta )

    ! Get the electronic (system) eigenvectors and eigenvalues
    hel_eigenvectors = hel
    CALL diagonalize_real_symmetric( hel_eigenvectors, hel_eigenvalues )

    ! Use the system eigenstuff to calculate the system portion of the propagator
    ! to use with the Trotter factorization of the imaginary time propagator
    DO istate = 1, nstate
        system_propagator( istate, istate ) = EXP( -dt * hel_eigenvalues( istate ) )
    END DO
    system_propagator = MATMUL( system_propagator, TRANSPOSE( hel_eigenvectors ) )
    system_propagator = MATMUL( hel_eigenvectors, system_propagator )

    ! Get the eigenvectors and eigenvalues for the inverse of the covariance matrix
    covariance_eigenvectors_inverse = covariance_matrix
    DO istate = 1, nstate
        CALL diagonalize_real_symmetric( covariance_eigenvectors_inverse( :, :, istate ), &
                covariance_eigenvalues( :, istate ) )
        covariance_eigenvectors_inverse( :, :, istate ) =  TRANSPOSE( covariance_eigenvectors_inverse( :, :, istate ) )
    END DO

    ! Run Imaginary time trajectories
    DO itraj = 1, INT( ntraj / npes )
        redmat = redmat_init

        DO istate = 1, nstate
            xi( :, istate ) = gaussian_rn( xi( :, istate ) ) * DSQRT( covariance_eigenvalues( :, istate ) ) / dt
            xi( :, istate ) = MATMUL( covariance_eigenvectors_inverse( :, :, istate ), xi( :, istate ) )
        END DO

        ! Propagate the reduced density matrix with trotter in imaginary time
        DO istep = 0, nbstep

            ! Build current bath propagator
            DO istate = 1, nstate
                bath_propagator( istate, istate ) = EXP( -0.5_dp * dt * xi( istep, istate ) )
            END DO

            ! Trotter propagation in imaginary time
            redmat = MATMUL( bath_propagator, redmat )
            redmat = MATMUL( system_propagator, redmat )
            redmat = MATMUL( bath_propagator, redmat )

        END DO

        DO istate = 1, nstate
            equilibrium_site_populations( istate ) = equilibrium_site_populations( istate ) &
                    + redmat( istate, istate )
        END DO

    END DO

    trace = SUM( equilibrium_site_populations )
    equilibrium_site_populations = equilibrium_site_populations / trace

    result_size = SIZE( equilibrium_site_populations )

    CALL MPI_Barrier(MPI_COMM_WORLD, ierr)
    IF ( mype /= 0 ) THEN
        CALL MPI_Send(equilibrium_site_populations, result_size, MPI_DOUBLE, &
                0, tag, MPI_COMM_WORLD, ierr)
    ELSE
        sum_equilibrium_site_populations = equilibrium_site_populations
        DO ipe=1, npes-1
            CALL MPI_recv(equilibrium_site_populations, result_size, MPI_DOUBLE,&
                    ipe, tag, MPI_COMM_WORLD, status,ierr)
            sum_equilibrium_site_populations = &
                    sum_equilibrium_site_populations + equilibrium_site_populations
        END DO
        sum_equilibrium_site_populations = sum_equilibrium_site_populations / DBLE(npes)
        CALL write_equilibrium_site_populations( sum_equilibrium_site_populations )
    END IF

END SUBROUTINE calculate_equilibrium_site_mpi


module da_be_spectral

   use da_control, only : da_zero_complex,ierr, trace_use, &
      pi,gaussian_lats
   use da_reporting, only : da_error,message
   use da_tools_serial, only : da_free_unit, da_get_unit
   use da_gen_be, only : da_trace_entry, da_trace_exit

   !--------------------------------------------------------------------
   ! Contains all necessary routines to perform global spectral transform
   !  (based on Fourier and Legendre decompositions).
   !--------------------------------------------------------------------

   implicit none

contains

#include "da_asslegpol.inc"
#include "da_calc_power.inc"
#include "da_get_gausslats.inc"
#include "da_get_reglats.inc"
#include "da_initialize_h.inc"
#include "da_legtra_inv.inc"
#include "da_legtra.inc"
#include "da_setlegpol_test.inc"
#include "da_setlegpol.inc"
#include "da_vv_to_v_spectral.inc"
#include "da_legtra_inv_adj.inc"
#include "da_apply_power.inc"

end module da_be_spectral


c
c     cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine madewd(lastrs,lastkn,myatom,num_atoms,alat,
     >                  rslat_x,rslat_y,rslat_z,rslatmd,
     >                  knlat_x,knlat_y,knlat_z,knlatsq,
     >                  atom_posi_x,atom_posi_y,atom_posi_z,
     >                  eta,tau,madmat,
     >                  iprint,istop)
c     ================================================================
c
c     ****************************************************************
c     program calculates the madelung constants
c     written by w.a.s.,jr. 2-21-88
c     modified by y.w., 06-20-94
c     modified by y.w., 06-06-95
c
c     ****************************************************************
c     input :
c     =====
c         1.) ewald card
c             lastrs = number real-space vectors
c             rslat= real-space vectors (in the units of a0=1)
c             rslatmd= rslat module
c             lastkn = number reciprocal-space vectors
c             knlat = reciprocal-space vectors (in the units of a0=1)
c             knlatsq= knlat square
c             eta = ewald parameter
c             num_atoms = number of atoms in the unit cell
c             tau = Wigner-Seitz volume
c
c     calling sequence
c     ================
c       |
c     intewld                      ! evaluates integral over eta
c       |
c       |
c     madsum                       ! real & recip space sums
c
c     ****************************************************************
c
      implicit   none
c
      character  istop*32
      character  sname*32
      parameter (sname='madewd')
c
      integer    lastrs
      integer    lastkn
      integer    num_atoms
      integer    iprint
      integer    ibegin
      integer    myatom
      integer    n
      integer    i
c
      real*8     atom_posi_x(num_atoms)
      real*8     atom_posi_y(num_atoms)
      real*8     atom_posi_z(num_atoms)
      real*8     rslat_x(lastrs)
      real*8     rslat_y(lastrs)
      real*8     rslat_z(lastrs)
      real*8     rslatmd(lastrs)
      real*8     knlat_x(lastkn)
      real*8     knlat_y(lastkn)
      real*8     knlat_z(lastkn)
      real*8     knlatsq(lastkn)
      real*8     madmat(num_atoms)
      real*8     alat
      real*8     aij(3)
      real*8     r0tm
      real*8     term0
      real*8     tau
      real*8     eta
      real*8     fnpi
      real*8     pi
      real*8     pi4
      real*8     zero
      real*8     two
      real*8     four
c
      parameter (zero=0.0d0)
      parameter (two=2.0d0)
      parameter (four=4.0d0)
c
c     ****************************************************************
c     calculate Madelung's constant matrix:
c
c     for i <> j,
c                                   2   2       -> ->
c            4*pi          1    -eta *Kq /4 - i*Kq*aij
c     M   =  ---- * sum  ----- e
c      ij    tau    q<>0    2
c                         Kq
c
c                          ->   ->                  2
c                 1 - erf(|Rn + aij|/eta)     pi*eta
c          + sum ------------------------- - ---------
c             n         ->   ->                 tau
c                      |Rn + aij|
c
c     for i = j,
c                                   2   2
c            4*pi          1    -eta *Kq /4
c     M   =  ---- * sum  ----- e
c      ii    tau    q<>0    2
c                         Kq
c
c                                             2
c                  1 - erf(Rn/eta)      pi*eta           2
c          + sum  ----------------- - ---------- - --------------
c            n<>0         Rn             tau        sqrt(pi)*eta
c
c     eta is the Ewald's parameter;
c     tau, atom_posi_*, rslat_* and knlat_* are in the units of a0=1;
c     madmat is in the units of a0=alat;
c     ****************************************************************
c
      pi=fnpi()
      pi4=four*pi
c
      term0=-pi*eta*eta/tau
c
c     ================================================================
c     start madmat calculation
c     ================================================================
      do n =1,num_atoms
c        =============================================================
c        aij is in the units of a0 = 1................................
c        =============================================================
         aij(1) = atom_posi_x(myatom) - atom_posi_x(n)
         aij(2) = atom_posi_y(myatom) - atom_posi_y(n)
         aij(3) = atom_posi_z(myatom) - atom_posi_z(n)
c
         if( n .eq. myatom ) then
            ibegin=2
            r0tm=-two/sqrt(pi)/eta
         else
            ibegin=1
            r0tm=zero
         endif
c        =============================================================
c        subrtact aij from rslat and calculate rslatmd which is used in
c        calculating the real-space integral
c        rslatmd, and aij are in the units of a0 = 1
c        =============================================================
         do i = 1,lastrs
            rslatmd(i)=sqrt( (rslat_x(i)-aij(1))*(rslat_x(i)-aij(1))
     >                      +(rslat_y(i)-aij(2))*(rslat_y(i)-aij(2))
     >                      +(rslat_z(i)-aij(3))*(rslat_z(i)-aij(3)) )
         enddo
c        =============================================================
c        perform the reciprocal-space sum and real-space sum
c        -------------------------------------------------------------
         call madsum(lastkn,lastrs,ibegin,aij,
     >               rslatmd,knlat_x,knlat_y,knlat_z,knlatsq,
     >               eta,tau,madmat(n),
     >               pi4,iprint,istop)
c        -------------------------------------------------------------
         madmat(n)=madmat(n)+r0tm+term0
c        =============================================================
c        The unit of madmat is finally resumed to a0 = alat
c        =============================================================
         madmat(n)=madmat(n)/alat
      enddo                                  ! end do loop over n
c
      if( istop .eq. sname ) then
        call fstop(sname)
      endif
c     ================================================================
c
      return
      end


! { dg-do run }
! { dg-options "-ff2c" }
! PR 34868

function f(a) result(res)
  implicit none
  real(8), intent(in) :: a(:)
  complex(8) :: res

  res = cmplx(sum(a),product(a),8)
end function f

function g(a)
  implicit none
  real(8), intent(in) :: a(:)
  complex(8) :: g

  g = cmplx(sum(a),product(a),8)
end function g

program test
  real(8) :: a(1,5)
  complex(8) :: c
  integer :: i

  interface
    complex(8) function f(a)
      real(8), intent(in) :: a(:)
    end function f
    function g(a) result(res)
      real(8), intent(in) :: a(:)
      complex(8) :: res
    end function g
  end interface

  do i = 1, 5
    a(1,i) = sqrt(real(i,kind(a)))
  end do

  c = f(a(1,:))
  call check (real(c), sum(a))
  call check (imag(c), product(a))

  c = g(a(1,:))
  call check (real(c), sum(a))
  call check (imag(c), product(a))
contains
  subroutine check (a, b)
    real(8), intent(in) :: a, b
    if (abs(a - b) > 1.e-10_8) STOP 1
  end subroutine check
end program test


program test_spectral_interpolation_ipol_2

use kind_values, only:  wp => kind_swd_internal
use spectral_interpolation_def, only: spectral_interpolation

implicit none

! This program tests the ipol=2 temporal scheme

! Dummy polynomials: f(t) = a0 + a1*t + a2*t**2 + ... a7*t**7
complex(wp), parameter :: a0 = cmplx(0.156_wp, 0.17_wp, wp)
complex(wp), parameter :: a1 = cmplx(1.234_wp, -0.54_wp, wp)
complex(wp), parameter :: a2 = cmplx(-2.34_wp, 0.154_wp, wp)
complex(wp), parameter :: a3 = cmplx(-0.18_wp, -0.25_wp, wp)
complex(wp), parameter :: a4 = cmplx(0.58_wp, -0.74_wp, wp)
complex(wp), parameter :: a5 = cmplx(0.23_wp, 0.09_wp, wp)
complex(wp), parameter :: a6 = cmplx(-0.84_wp, 0.12_wp, wp)
complex(wp), parameter :: a7 = cmplx( 0.13_wp, -0.70_wp, wp)

real(wp), parameter :: delta_t = 0.34_wp
real(wp), parameter :: t_im1 = 0.15_wp
real(wp), parameter :: t_i = t_im1 + delta_t
real(wp), parameter :: t_ip1 = t_i + delta_t
real(wp), parameter :: t_ip2 = t_ip1 + delta_t

type(spectral_interpolation) :: si
real(wp) :: t, delta
complex(wp) :: c1, dc1, ddc1, c2, dc2, ddc2
complex(wp) :: f_im1, f_i, f_ip1, f_ip2
complex(wp) :: df_im1, df_i, df_ip1, df_ip2
complex(wp) :: ddf_i, ddf_ip1

integer :: ipol, i, ierr, n_error = 0
real(wp), parameter :: deltas(5) = [0.0_wp, 0.29_wp, 0.64_wp, 0.84_wp, 1.0_wp]

print*, " Test of ipol=2..."
ipol = 2
call si % construct(ipol, delta_t, ierr)
if (ierr /= 0) then
    print *, "Unknown interpolation scheme: ", ipol
    stop
end if

f_im1 = f7(t_im1)
f_i = f7(t_i)
f_ip1 = f7(t_ip1)
f_ip2 = f7(t_ip2)
df_im1 = df7(t_im1)
df_i = df7(t_i)
df_ip1 = df7(t_ip1)
df_ip2 = df7(t_ip2)
! Adjust f_im1 make ddf_i based on finite-difference match polynomial at t_i
! Adjust f_ip2 to make ddf_ip1 based on finite-difference match polynomial at t_ip1
stop 'Not implemented yet !!!'

ddf_ip1 = ddf7(t_ip1)
f_ip2 = 0.5_wp * ddf_ip1 * delta_t**2 + 2 * f_ip1 - f_i + (df_ip2 - df_i) * delta_t / 4

do i = 1, size(deltas)
    delta = deltas(i)
    t = t_i + delta * delta_t
    c1 = f7(t)
    dc1 = df7(t)
    ddc1 = ddf7(t)
    call si % scheme(delta, &
                     f_im1, f_i, f_ip1, f_ip2, &
                     df_im1, df_i, df_ip1, df_ip2, &
                     c2, dc2)
    print*, "Delta = ", delta
    print*, "Compare function values: ", c1, c2, compare(c1, c2)
    print*, "Compare function derivatives: ", dc1, dc2, compare(dc1, dc2)
    if (i==1) then
        print*, "f_i, df_i: ", f_i, df_i
        print*, "compare(c2, f_i)", compare(c2, f_i)
        print*, "compare(dc2, df_i)", compare(dc2, df_i)
        print*, "compare(ddc1, ddf_i)", compare(ddc1, ddf_i)
    else if (i==size(deltas)) then
        print*, "f_ip1, df_ip1: ", f_ip1, df_ip1
        print*, "compare(c2, f_ip1)", compare(c2, f_ip1)
        print*, "compare(dc2, df_ip1)", compare(dc2, df_ip1)
        print*, "compare(ddc1, ddf_ip1)", compare(ddc1, ddf_ip1)
    end if
end do

print*, "Number of detected ERRORs = ", n_error

contains

function f7(t) result(res)
real(wp), intent(in) :: t
complex(wp) res
res = a0 + a1*t + a2*t**2 + a3*t**3 + a4*t**4 + a5*t**5 + a6*t**6 + a7*t**7
end function f7

function df7(t) result(res)
real(wp), intent(in) :: t
complex(wp) res
res = a1 + 2.0_wp * a2*t + 3.0_wp * a3*t**2 + 4.0_wp * a4*t**3 + &
      5.0_wp * a5*t**4 + 6.0_wp * a6*t**5  + 7.0_wp * a7*t**6
end function df7

function ddf7(t) result(res)
real(wp), intent(in) :: t
complex(wp) res
res = 2.0_wp * a2 + 6.0_wp * a3*t + 12.0_wp * a4*t**2 + &
     20.0_wp * a5*t**3 + 30.0_wp * a6*t**4  + 42.0_wp * a7*t**5
end function ddf7

function compare(c1, c2) result(res)
complex(wp), intent(in) :: c1, c2
character(len=10) res
real(wp), parameter :: eps = 100*epsilon(eps)
if (abs(c1 % re - c2 % re) > eps * max(abs(c1 % re), abs(c2 % re)) .or. &
    abs(c1 % im - c2 % im) > eps * max(abs(c1 % im), abs(c2 % im))) then
    res = "ERROR!"
    n_error = n_error + 1
else
    res = "OK"
end if
end function compare

end program test_spectral_interpolation_ipol_2


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! DFPMIN Module
! Author: Brian Krauth, Simon Fraser University
!
! Optimization code for SMLE program.
!
! Public procedures defined in this module are:
!
!   dfp:	Optimize a function using the method of Davidson,
!		Fletcher and Powell.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
module dfpmin
use bklib, only : SP,DP
use smglob, only : save_dfp_checkpoint, SMGLOBAL, RESUME_FROM_CHECKPOINT, load_dfp_checkpoint
implicit none
private
private :: dfpd,outerprod,outerprods,outerprodd,vabs,vabss,vabsd, &
     unit_matrix,unit_matrixs,unit_matrixd,linmib
public :: dfp
interface dfp
   module procedure dfpd
end interface
interface outerprod
   module procedure outerprods,outerprodd
end interface
interface vabs
   module procedure vabss,vabsd
end interface
interface unit_matrix
   module procedure unit_matrixs,unit_matrixd
end interface

contains

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! DFP subroutine
!
! Format: dfp(p,gtol,iter,fret,func,dfunc)
!
! Finds the minimum of function FUNC, given a starting value
! P.  Returns the minimizer in P, the minimum in FRET, and the
! number of iterations required in ITER.  GTOL is the convergence
! tolerance, and DFUNC is a function that returns the first
! derivative (gradient) of FUNC.
!
! The algorithm used is the Davidson-Fletcher-Powell algorithm
! and the code is adapted from "Numerical recipes in Fortran 90"
! See that book for detailed documentation.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE dfpd(p,gtol,iter,fret,func,dfunc)
integer, intent(out) :: iter
real(kind=DP), intent(in) :: gtol
real(kind=DP), intent(out) :: fret
real(kind=DP), dimension(:), intent(inout) :: p
interface
!   function func(p) result (fout)
   subroutine func(p,fout) ! new
     use bklib
     use smglob
     real(kind=dp), dimension(:), intent(in) :: p
!     real(kind=dp) :: fout
     real(kind=dp), intent(inout) :: fout ! new
!   end function func
   end subroutine func ! new
!   function dfunc(p,fp) result(fout)
   subroutine dfunc(p,fp,fout) ! new
     use bklib
     use smglob
     real(kind=dp), dimension(:), intent(in) :: p
     real(kind=dp), intent(in) :: fp
!     real(kind=dp), dimension(size(p)) :: fout
     real(kind=dp), dimension(size(p)), intent(inout) :: fout ! new
!   END FUNCTION dfunc
   end subroutine dfunc ! new
END INTERFACE
! constants differ from gauss
INTEGER, PARAMETER  :: ITMAX=200
! REAL(kind=DP), PARAMETER :: STPMX=100.0_dp,EPS=0.0000000001_dp,ftol=0.00001_dp
REAL(kind=DP), PARAMETER :: STPMX=5.0_dp,EPS=0.0000000001_dp,ftol=0.00001_dp
! description: does BFGS search
INTEGER :: its,itstart,ios
!LOGICAL :: check
REAL(kind=DP) :: den,fac,fad,fae,fp,stpmax,sumdg,sumxi
REAL(kind=DP), DIMENSION(size(p)) :: dg,g,hdg,pnew,xi
REAL(kind=DP), DIMENSION(size(p),size(p)) :: hessin
!
! Based on the function DFPMIN  in Numerical Recipes in Fortran 90, pages 1215-1216
!
! Given a starting point P that is a vector of length N, the Broyden-Fletcher-Goldfarb-Shanno
! variant of the Davidon-Fletcher-Powell algorithm is performed on a function FUNC, using
! its gradient as calculated by the routine DFUNC. The convergence requirement on zeroing
! the gradient is input as GTOL.  Returned quantities are P (the location of the minumum)
! ITER (the number of iterations that were performed) and FRET (the minimum value of the
! function).  ITMAX is the maximum allowed number of iterations; STPMX is the scaled
! maximum step length allowed in line searches; EPS is the machine precision; TOLX is
! the convergence criterion on x values
!
if (RESUME_FROM_CHECKPOINT) then
   call load_dfp_checkpoint(itstart,p,fp,g,hessin)
else
   itstart=1
!   fp = func(p) ! Calculate starting value and gradient
   call func(p,fp) ! Calculate starting value and gradient ! new
!   g = dfunc(p,fp)
   call dfunc(p,fp,g)
   call unit_matrix(hessin) ! Initialize inverse hessian to the unit matrix
end if
! deleted by BK 11/28/03
! xi=-g ! initial line direction, moved by BK inside loop
stpmax=STPMX*max(vabs(p),real(size(p),dp)) ! Used by lnsrch, but not linmib
open (unit=1,file=smglobal%logfile,iostat=ios,action="write",position="append",status="old")
if (ios==0) then
   write (unit=1,iostat=ios,fmt=*) "STPMX: ", STPMX
   write (unit=1,iostat=ios,fmt=*) "vabs(p): ", vabs(p)
   write (unit=1,iostat=ios,fmt=*) "real(size(p),dp): ", real(size(p),dp)
   write (unit=1,iostat=ios,fmt=*) "stpmax: ", stpmax
   close (unit=1,iostat=ios)
else
   continue ! no need for error handling here
end if
do its=itstart,ITMAX ! main search loop
  open (unit=1,file=smglobal%logfile,iostat=ios,action="write",position="append",status="old")
  if (ios==0) then
     write (unit=1,iostat=ios,fmt=*) "Iteration: ", its
     write (unit=1,iostat=ios,fmt=*) "Current optimal b: ", p
     write (unit=1,iostat=ios,fmt=*) "Current value of function: ",-fp
     write (unit=1,iostat=ios,fmt=*) "g: ", g
     close (unit=1,iostat=ios)
  else
     continue ! no need for error handling here
  end if
  call save_dfp_checkpoint(its,p,fp,g,hessin) ! save current status to disk in case program is interrupted
  iter=its
  xi=-matmul(hessin,g) ! set line direction; moved up from bottom of loop by BK 11/28/03
!  call lnsrch(p,fp,g,xi,pnew,fret,stpmax,check,func)
  call linmib(p,fp,xi,pnew,fret,func) ! use LINMIB to do linear search for minimum in direction XI
  if (2.0_dp*abs(fp-fret) < ftol*(abs(fp)+abs(fret)+eps)) then ! function has converged
     open (unit=1,file=smglobal%logfile,iostat=ios,action="write",position="append",status="old")
     if (ios == 0) then
        write (unit=1,iostat=ios,fmt=*) "relative function convergence"
        close (unit=1,iostat=ios)
     else
        continue
     end if
     return
  end if
! added by BK - only used when likelihood bounds are being used, should probably be removed
  if (fret < SMGLOBAL%DFPSTOP) then
     open (unit=1,file=smglobal%logfile,iostat=ios,action="write",position="append",status="old")
     if (ios == 0) then
        write (unit=1,iostat=ios,fmt=*) "fret < dfpstop"
        close (unit=1,iostat=ios)
     else
        continue
     end if
     return
  end if
! back to original code
  fp=fret ! update the current minimum
!   xi=pnew-p ! direction (THIS APPEARS TO BE A BUG IN THE NUMERICAL RECIPES CODE; deleted)
  p=pnew ! and minimizer
! NOT IN GAUSS VERSION
!   if (maxval(abs(xi)*max(abs(p),1.0_dp)/den) < gtol) then ! test for convergence on dX
!      return
!   end if
  dg=g ! save the old gradient
!  g=dfunc(p,fp) ! and get the new gradient
  call dfunc(p,fp,g) ! new
  den=max(fret,1.0_dp)
!   if(maxval(abs(g)*max(abs(p),1.0_dp)/den) < gtol) then ! test for convergence on zero gradient
!      return
!   end if
  dg=g-dg ! Compute difference of gradients
  hdg=matmul(hessin,dg) ! and difference times current matrix
  fac=dot_product(dg,xi) ! calculate dot products for the denominators
  fae=dot_product(dg,hdg)
  sumdg=dot_product(dg,dg)
  sumxi=dot_product(xi,xi)
  open (unit=1,file=smglobal%logfile,iostat=ios,action="write",position="append",status="old")
  if (ios == 0) then
     write (unit=1,iostat=ios,fmt=*) "STPMX: ", sumdg,sumxi,eps,fac,fae
     close (unit=1,iostat=ios)
  else
     continue
  end if
  if (fac > sqrt(eps*sumdg*sumxi)) then ! skip update if FAC not sufficiently positive
     fac=1.0_dp/fac
     fad=1.0_dp/fae
     dg=fac*xi-fad*hdg ! vector that makes BFGS different from DFP
     hessin=hessin+fac*outerprod(xi,xi)-fad*outerprod(hdg,hdg)+fae*outerprod(dg,dg) ! the BFGS updating formula
  else
     open (unit=1,file=smglobal%logfile,iostat=ios,action="write",position="append",status="old")
     if (ios == 0) then
        write (unit=1,iostat=ios,fmt=*) "fac nearly zero, fac= ",fac," EPS=",EPS, &
             "sumdg=",sumdg,"sumxi=",sumxi
        close (unit=1,iostat=ios)
     else
        continue
     end if
     return
  end if
! Moved to beginning by BK 11/28/03
!  xi=-matmul(hessin,g)
end do ! start the next iteration
stop "Error: too many iterations in DFP algorithm"
END SUBROUTINE dfpd

FUNCTION outerprods(a,b) result(outerprodout)
REAL(kind=SP), DIMENSION(:), INTENT(IN) :: a,b
REAL(kind=SP), DIMENSION(size(a),size(b)) :: outerprodout
outerprodout = spread(a,dim=2,ncopies=size(b))*spread(b,dim=1,ncopies=size(a))
END FUNCTION outerprods
FUNCTION outerprodd(a,b) result(outerprodout)
REAL(kind=DP), DIMENSION(:), INTENT(IN) :: a,b
REAL(kind=DP), DIMENSION(size(a),size(b)) :: outerprodout
outerprodout = spread(a,dim=2,ncopies=size(b))*spread(b,dim=1,ncopies=size(a))
END FUNCTION outerprodd

FUNCTION vabss(v) result(vabsout)
REAL(kind=SP), DIMENSION(:), INTENT(IN) :: v
REAL(kind=SP) :: vabsout
vabsout=sqrt(dot_product(v,v))
END FUNCTION vabss
FUNCTION vabsd(v) result(vabsout)
REAL(kind=DP), DIMENSION(:), INTENT(IN) :: v
REAL(kind=DP) :: vabsout
vabsout=sqrt(dot_product(v,v))
END FUNCTION vabsd

SUBROUTINE unit_matrixs(mat)
REAL(kind=SP), DIMENSION(:,:), INTENT(OUT) :: mat
INTEGER :: i,n
n=min(size(mat,1),size(mat,2))
mat(:,:)=0.0_sp
do i=1,n
   mat(i,i)=1.0_sp
end do
END SUBROUTINE unit_matrixs
SUBROUTINE unit_matrixd(mat)
REAL(kind=DP), DIMENSION(:,:), INTENT(OUT) :: mat
INTEGER :: i,n
n=min(size(mat,1),size(mat,2))
mat(:,:)=0.0_dp
do i=1,n
   mat(i,i)=1.0_dp
end do
END SUBROUTINE unit_matrixd

subroutine linmib(pst,fp,xi,pnew,fret,func)
! implicit none
real(kind=DP), dimension(:), intent(in) :: pst,xi
real(kind=DP), intent(in) :: fp
real(kind=DP), dimension(:), intent(inout) :: pnew
real(kind=DP), intent(inout) :: fret
real(kind=DP) :: a1,a2,f1,f2,am,fm,ad,a,b,u,v,w,x,e,fx,xm,tol1,tol2,p,q,r,etemp, &
     d,fu,fw,fv
integer :: i
real(kind=DP), parameter :: cgold=0.381966_dp,zeps=1.0e-10_dp,tol=0.00001_dp
! real(DP), parameter :: cgold=0.381966d0,zeps=1d-5,tol=0.001d0
integer, parameter :: maxit=100
interface
!   function func(p) result(fout)
   subroutine func(p,fout) ! new
     use bklib
     use smglob
     implicit none
!     real(kind=DP) :: fout
     real(kind=DP), intent(inout) :: fout ! new
     real(kind=DP), dimension(:), intent(in) :: p
!   end function func
   end subroutine func
end interface
a1=0.0_dp
a2=0.01_dp
! new stuff - see if it works better
if (xi(1) > 0.0_dp) then
   b=(0.9_dp-pst(1))/xi(1)
   a=(-0.5_dp-pst(1))/xi(1)
else
   a=(0.9_dp-pst(1))/xi(1)
   b=(-0.5_dp-pst(1))/xi(1)
end if
!f1 = func(pst+a*xi)
call func(pst+a*xi,f1) ! new
!f2 = func(pst+b*xi)
call func(pst+b*xi,f2) ! new
if ((f1 > fp).and.(f2 > fp)) then
   v=0.0_dp
   x=v
   w=v
   e=v
   fx=fp
   fv=fx
   fw=fx
   goto 5
end if
! end of new stuff
f1=fp
do i=1,10
   if (i==10) then
      stop "Error in linmib: function is too flat "
   end if
!   f2=func(pst+a2*xi)
   call func(pst+a2*xi,f2) ! new
   if (f1 /= f2) exit
   a2=a2+1.0_dp
end do
if (f1 <= f2) then
   am=a1
   fm=f1
   f1=f2
   a1=a2
else
   am=a2
   fm=f2
end if
ad=5.0_dp*(am-a1)
a2=am+ad
!f2 = func(pst+a2*xi)
 call func(pst+a2*xi,f2) ! new
do i=1,maxit
   if (f2 > fm) exit
   ad=2.0_dp*ad
   a2=am+ad
!   f2=func(pst+a2*xi)
   call func(pst+a2*xi,f2) ! new
end do
if (a1 < a2) then
   a=a1
   b=a2
else
   a=a2
   b=a1
end if
v=am
x=v
w=v
e=0.0_dp
fx=fm
fv=fx
fw=fx
5 continue
do i=1,maxit
   xm=(a+b)*0.5_dp
   tol1=tol*abs(x)+zeps
   tol2=2.0_dp*tol1
   if (abs(x-xm) <= (tol2-0.5_dp*(b-a))) goto 30
   if (abs(e) > tol1) then
      r=(x-w)*(fx-fv)
      q=(x-v)*(fx-fw)
      p=(x-v)*q-(x-w)*r
      q=2.0_dp*(q-r)
      if (q > 0) p=-p
      q=abs(q)
      etemp=e
      e=d
      if ((abs(p)>=abs(0.5_dp*q*etemp)).or.(p<=q*(a-x)).or.(p>=(q*(b-x)))) goto 10
      d=p/q
      u=x+d
      if (((u-a)<tol2).or.((b-u)<tol2)) then
         d=abs(tol1)
         if (xm<x) d=-d
      end if
      goto 20
   end if
10 continue
   if(x>=xm) then
      e=a-x
   else
      e=b-x
   end if
   d=cgold*e
20 continue
   if (abs(d) >= tol1) then
      u=x+d
   else
      if (d>0.0_dp) then
         u=x+abs(tol1)
      else
         u=x-abs(tol1)
      end if
   end if
!   fu=func(pst+u*xi)
   call func(pst+u*xi,fu) !new
   if (fu <= fx) then
      if (u >= x) then
         a=x
      else
         b=x
      end if
      v=w
      fv=fw
      w=x
      fw=fx
      x=u
      fx=fu
   else
      if (u<x) then
         a=u
      else
         b=u
      end if
      if ((fu<= fw).or.(w==x)) then
         v=w
         fv=fw
         w=u
         fw=fu
      else
         if ((fu <= fv).or.(v == x).or.(v == w)) then
            v=u
            fv=fu
         end if
      end if
   end if
end do
stop "Error in linmib: max number of iterations exceeded"
30 continue
  pnew=pst+x*xi
  fret=fx
end subroutine linmib

end module dfpmin


! sum up absolute of "num" integers in array "inp", store result in "asum"
subroutine sum_abs(inp, num, asum)
  implicit none
  integer, intent(in) :: inp(*), num
  integer, intent(out) :: asum
  integer :: i,s

   s = 0
   do i=1,num
     s = s + abs(inp(i));
   end do
   asum = s;
end subroutine sum_abs


// combine Fig_6.8_mandelbrotWrongPart1_C and Fig_6.9_mandelbrotWrongPart2_c into one file, and name it as mandel_wrong.c
// sample compile command: gcc -fopenmp -o mandel_wrong mandel_wrong.c

void testpoint(void) {

// Does the iteration z=z*z+c, until |z| > 2 when point is known to
// be outside set. If loop count reaches MAXITER, point is considered
// to be inside the set.

   struct d_complex z;
   int iter;
   double temp;

   z = c;
   for (iter = 0; iter < MAXITER; iter++) {
      temp = (z.r * z.r) - (z.i * z.i) + c.r;
      z.i = z.r * z.i * 2 + c.i;
      z.r = temp;
      if ((z.r * z.r + z.i * z.i) > 4.0) {
         numoutside++;
         break;
      }
   }
}


      SUBROUTINE CLPGON (VISCT, NUMPL, RAD)

C  CLPGON draws a set of markers some of which are just inside the
C  clipping region shaped like a regular polygon, and the rest just
C  outside it.

C  Input parameters:
C    VISCT : number of markers to be drawn inside clipping region
C    NUMPL : total number of markers to be drawn = #sides of polygon
C    RAD   : radius of polygon (distance from center to face, not vertex)

      INTEGER    VISCT, NUMPL, VISLIS(50), IX, IARFND
C maximum number of planes to be tested
      INTEGER    TSTMAX
      PARAMETER (TSTMAX = 500)

      REAL       XLOC(TSTMAX), YLOC(TSTMAX), ZLOC(TSTMAX)
      REAL       RAD, THSRAD, RNDRL, ANG, PI
      PARAMETER (PI = 3.14159265)

C  Choose visct markers to be inside
      CALL RNSET (VISCT, NUMPL, VISLIS)

C  calculate coordinates of polymarker:
      DO 100 IX = 1,NUMPL
         IF ( IARFND (IX, VISCT, VISLIS) .GT. 0) THEN
C  Inside:
            THSRAD = 0.99 * RAD
         ELSE
C  Outside:
            THSRAD = 1.01 * RAD
         ENDIF
         ANG = IX*2*PI / NUMPL
         XLOC (IX) = 0.5 + THSRAD * COS(ANG)
         YLOC (IX) = 0.5 + THSRAD * SIN(ANG)
         ZLOC (IX) = RNDRL(0.,1.0)
  100 CONTINUE
      CALL PPM3 (NUMPL, XLOC,YLOC,ZLOC)

      END


      real*8 function interp4 (a1, a2, av, b1, b2, bv, t1, t2, t3, t4)
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
!**********************************************************************
!D1
!D1 PURPOSE
!D1
!D1 To calculate particle time delay using type curves.
!D1
!**********************************************************************
!D2
!D2 REVISION HISTORY
!D2
!D2 FEHM Version 2.10 [10086-STN-2.10-00]
!D2
!D2 Initial implementation: 05-MAY-99, Programmer: Zora Dash
!D2
!D2 $Log:   /pvcs.config/fehm90/src/interp4.f_a  $
!D2
!D2    Rev 2.5   06 Jan 2004 10:43:24   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2    Rev 2.4   29 Jan 2003 09:09:24   pvcs
!D2 FEHM Version 2.20, STN 10086-2.20-00
!D2
!D2    Rev 2.3   14 Nov 2001 13:10:38   pvcs
!D2 FEHM Version 2.12, STN 10086-2.12-00
!D2
!D2    Rev 2.2   06 Jun 2001 13:31:08   pvcs
!D2 FEHM Version 2.11, STN 10086-2.11-00
!D2
!D2    Rev 2.1   30 Nov 2000 12:04:40   pvcs
!D2 FEHM Version 2.10, STN 10086-2.10-00
!D2
!**********************************************************************
!D3
!D3 REQUIREMENTS TRACEABILITY
!D3
!D3 2.3.5 Cell-based particle-tracking module
!D3 2.3.6 Streamline particle-tracking module
!D3
!**********************************************************************
!D4
!D4 SPECIAL COMMENTS AND REFERENCES
!D4
!D4 Requirements from SDN: 10086-RD-2.20-00
!D4   SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
!D4   FEHM Application Version 2.20
!D4
!**********************************************************************
! Return the interpolated time value

      implicit none

      real*8 a1, a2, av, b1, b2, bv, t1, t2, t3, t4
      real*8 d1, d2, d3, d4, totald

      d1 = dsqrt( (dlog10 (a1) - dlog10(av))**2 +
     .     (dlog10 (b1) - dlog10(bv))**2)

      if (d1 .eq. 0) then
         interp4 = t1
         return
      end if

      d2 =  dsqrt( (dlog10 (a1) - dlog10(av))**2 +
     .     (dlog10 (b2) - dlog10(bv))**2)

      if (d2 .eq. 0) then
         interp4 = t2
         return
      end if

      d3 =  dsqrt( (dlog10 (a2) - dlog10(av))**2 +
     .     (dlog10 (b1) - dlog10(bv))**2)

      if (d3 .eq. 0) then
         interp4 = t3
         return
      end if

      d4 =  dsqrt( (dlog10 (a2) - dlog10(av))**2 +
     .     (dlog10 (b2) - dlog10(bv))**2)

      if (d4 .eq. 0) then
         interp4 = t4
         return
      end if

      d1 = 1./d1
      d2 = 1./d2
      d3 = 1./d3
      d4 = 1./d4

      totald = 1. /(d1 + d2 + d3 +d4)

      interp4 = totald * (d1*t1 + d2*t2 + d3*t3 + d4*t4)

      return
      end


module fplus_filter
    use fplus_error
    implicit none

contains

    !***********************************************************************
    !     ZEITREIHENFILTERUNG MIT REKURSIVEM FILTER NACH BUTTERWORTH       *
    !     (siehe Stearns: Digitale verarbeitung analoger Systeme, 1984)    *
    !     BEACHTE: LAENGE DER ZEITREIHE BLEIBT KONSTANT                    *
    !                                                                      *
    !     XTS         : ORIGINALZEITREIHEN U. GEF. ZR AM ENDE D. ROUTINE   *
    !     NTERMIN     : ANZAHL DER DATENPUNKTE                             *
    !     TLOW,THIGH  : Half Power Cutin/Cutoff-Perioden                   *
    !     NS          : 2*NS = Ordnung des Butterworth filters             *
    !     ZRRF,TREV    : Hilfsfelder                                       *
    !***********************************************************************
    ! aus filter.f von A. Fink.
    SUBROUTINE BWBPASS(Xts,Ntermin,Tlow,Thigh,Ns)
        INTEGER :: i , j , k , kk , l , Ns , NT , Ntermin
        REAL (kind=8) :: Thigh , Tlow
        REAL (kind=8) :: Xts(Ntermin)
        REAL (kind=8) :: trev(Ntermin) , zrev(Ntermin) , f(6,5)
        REAL (kind=8) :: a(5) , b(5) , c(5) , d(5) , e(5) , f1 , f2 , temp
        REAL (kind=8) :: cs , p , q , r , s , deltat , wc , w1 , w2 , x , pi

        ! maximum order allowed is 10
        if (Ns > 5) call fplus_error_print("maximum order allowed is 10", "BWBPASS")

        !      REAL A(5),B(5),C(5),D(5),E(5)
        !      REAL CS,P,Q,R,S,DELTAT,WC,W1,W2,X,F1,F2

        pi = ACOS(-1.)
        !PRINT * , '*** BANDPASSFILTER BUTTERWORTH ***'
        !PRINT * , 'TLOW= ' , Tlow , 'THIGH ' , Thigh
        f1 = 1./Thigh
        f2 = 1./Tlow
        deltat = 1.

        !***********************************************************************
        ! Berechnung der Filterkoeffizienten A(K)-E(K)                        *
        !***********************************************************************

        w1 = SIN(f1*pi*deltat)/COS(f1*pi*deltat)
        w2 = SIN(f2*pi*deltat)/COS(f2*pi*deltat)
        wc = w2 - w1
        q = wc*wc + 2.*w1*w2
        s = w1*w1*w2*w2
        DO k = 1 , Ns
            cs = COS(FLOAT(2*(k+Ns)-1)*pi/FLOAT(4*Ns))
            p = -2.*wc*cs
            r = p*w1*w2
            x = 1. + p + q + r + s
            a(k) = wc*wc/x
            b(k) = (-4.-2.*p+2.*r+4.*s)/x
            c(k) = (6.-2.*q+6.*s)/x
            d(k) = (-4.+2.*p-2.*r+4.*s)/x
            e(k) = (1.-p+q-r+s)/x
        ENDDO
!      PRINT * , 'Filterkoeffizienten A(K)-B(K)'
!      PRINT * , '  '
!      DO i = 1 , Ns
!         WRITE (*,99001) i , a(i) , b(i) , c(i) , d(i) , e(i)
!99001    FORMAT (5(I3,5E18.10))
!      ENDDO

        !***********************************************************************
        ! Hin/Rueckrekursion. Filter besteht aus NS Filtern in Reihe           *
        ! (Rekursion nach Stearns, S. 345)                                      *
        !***********************************************************************

        !***********************************************************************
        ! Initialisierung F(NS+1,5):                                           *
        ! F(1,5): present value, input to filter section 1                     *
        ! F(2,5): input to filter section 2                                    *
        !    "  :        "                                                     *
        ! F(6,5): output of filter section 5 = filtered value                  *
        ! F(1,4): previous value of F(1,5)                                     *
        ! F(2,3): previous value of F(1,4)                                     *
        !    "  :        "                                                     *
        !***********************************************************************

        DO i = 1 , Ns + 1
            DO j = 1 , 5
                f(i,j) = 0.
            ENDDO
        ENDDO

        DO i = 1 , Ntermin
            f(1,5) = Xts(i)
            DO j = 1 , Ns
                temp = a(j)*(f(j,5)-2.*f(j,3)+f(j,1))
                f(j+1,5) = temp - b(j)*f(j+1,4) - c(j)*f(j+1,3) - d(j) *f(j+1,2) - e(j)*f(j+1,1)
            ENDDO
            DO j = 1 , Ns + 1
                DO kk = 1 , 4
                    f(j,kk) = f(j,kk+1)
                ENDDO
            ENDDO
            zrev(i) = f(Ns+1,5)
        ENDDO

        !***********************************************************************
        ! Zeitumkehr und Filterung des Outputs                                 *
        !***********************************************************************

        DO l = 1 , Ntermin
            trev(Ntermin-l+1) = zrev(l)
        ENDDO

        DO i = 1 , Ns + 1
            DO j = 1 , 5
                f(i,j) = 0.
            ENDDO
        ENDDO

        DO i = 1 , Ntermin
            f(1,5) = trev(i)
            DO j = 1 , Ns
                temp = a(j)*(f(j,5)-2.*f(j,3)+f(j,1))
                f(j+1,5) = temp - b(j)*f(j+1,4) - c(j)*f(j+1,3) - d(j)      &
                         & *f(j+1,2) - e(j)*f(j+1,1)
            ENDDO
            DO j = 1 , Ns + 1
                DO kk = 1 , 4
                   f(j,kk) = f(j,kk+1)
                ENDDO
            ENDDO
            trev(i) = f(Ns+1,5)
        ENDDO

        !***********************************************************************
        ! Erneute Zeitumkehr, abspeichern des gefilterten Sihnales             *
        !***********************************************************************

        DO l = 1 , Ntermin
           Xts(Ntermin-l+1) = trev(l)
        ENDDO
    END subroutine

end module