      SUBROUTINE SB10QD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, B, LDB,
     $                   C, LDC, D, LDD, F, LDF, H, LDH, X, LDX, Y, LDY,
     $                   XYCOND, IWORK, DWORK, LDWORK, BWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the state feedback and the output injection
C     matrices for an H-infinity (sub)optimal n-state controller,
C     using Glover's and Doyle's 1988 formulas, for the system
C
C                   | A  | B1  B2  |   | A | B |
C               P = |----|---------| = |---|---|
C                   | C1 | D11 D12 |   | C | D |
C                   | C2 | D21 D22 |
C
C     and for a given value of gamma, where B2 has as column size the
C     number of control inputs (NCON) and C2 has as row size the number
C     of measurements (NMEAS) being provided to the controller.
C
C     It is assumed that
C
C     (A1) (A,B2) is stabilizable and (C2,A) is detectable,
C
C     (A2) D12 is full column rank with D12 = | 0 | and D21 is
C                                             | I |
C          full row rank with D21 = | 0 I | as obtained by the
C          subroutine SB10PD,
C
C     (A3) | A-j*omega*I  B2  | has full column rank for all omega,
C          |    C1        D12 |
C
C
C     (A4) | A-j*omega*I  B1  |  has full row rank for all omega.
C          |    C2        D21 |
C
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the system.  N >= 0.
C
C     M       (input) INTEGER
C             The column size of the matrix B.  M >= 0.
C
C     NP      (input) INTEGER
C             The row size of the matrix C.  NP >= 0.
C
C     NCON    (input) INTEGER
C             The number of control inputs (M2).  M >= NCON >= 0,
C             NP-NMEAS >= NCON.
C
C     NMEAS   (input) INTEGER
C             The number of measurements (NP2).  NP >= NMEAS >= 0,
C             M-NCON >= NMEAS.
C
C     GAMMA   (input) DOUBLE PRECISION
C             The value of gamma. It is assumed that gamma is
C             sufficiently large so that the controller is admissible.
C             GAMMA >= 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             system state matrix A.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,N).
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,M)
C             The leading N-by-M part of this array must contain the
C             system input matrix B.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= max(1,N).
C
C     C       (input) DOUBLE PRECISION array, dimension (LDC,N)
C             The leading NP-by-N part of this array must contain the
C             system output matrix C.
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= max(1,NP).
C
C     D       (input) DOUBLE PRECISION array, dimension (LDD,M)
C             The leading NP-by-M part of this array must contain the
C             system input/output matrix D.
C
C     LDD     INTEGER
C             The leading dimension of the array D.  LDD >= max(1,NP).
C
C     F       (output) DOUBLE PRECISION array, dimension (LDF,N)
C             The leading M-by-N part of this array contains the state
C             feedback matrix F.
C
C     LDF     INTEGER
C             The leading dimension of the array F.  LDF >= max(1,M).
C
C     H       (output) DOUBLE PRECISION array, dimension (LDH,NP)
C             The leading N-by-NP part of this array contains the output
C             injection matrix H.
C
C     LDH     INTEGER
C             The leading dimension of the array H.  LDH >= max(1,N).
C
C     X       (output) DOUBLE PRECISION array, dimension (LDX,N)
C             The leading N-by-N part of this array contains the matrix
C             X, solution of the X-Riccati equation.
C
C     LDX     INTEGER
C             The leading dimension of the array X.  LDX >= max(1,N).
C
C     Y       (output) DOUBLE PRECISION array, dimension (LDY,N)
C             The leading N-by-N part of this array contains the matrix
C             Y, solution of the Y-Riccati equation.
C
C     LDY     INTEGER
C             The leading dimension of the array Y.  LDY >= max(1,N).
C
C     XYCOND  (output) DOUBLE PRECISION array, dimension (2)
C             XYCOND(1) contains an estimate of the reciprocal condition
C                       number of the X-Riccati equation;
C             XYCOND(2) contains an estimate of the reciprocal condition
C                       number of the Y-Riccati equation.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension
C             (max(2*max(N,M-NCON,NP-NMEAS),N*N))
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) contains the optimal
C             LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             LDWORK >= max(1,M*M + max(2*M1,3*N*N +
C                                       max(N*M,10*N*N+12*N+5)),
C                           NP*NP + max(2*NP1,3*N*N +
C                                       max(N*NP,10*N*N+12*N+5))),
C             where M1 = M - M2 and NP1 = NP - NP2.
C             For good performance, LDWORK must generally be larger.
C             Denoting Q = MAX(M1,M2,NP1,NP2), an upper bound is
C             max(1,4*Q*Q+max(2*Q,3*N*N + max(2*N*Q,10*N*N+12*N+5))).
C
C     BWORK   LOGICAL array, dimension (2*N)
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:  if the controller is not admissible (too small value
C                   of gamma);
C             = 2:  if the X-Riccati equation was not solved
C                   successfully (the controller is not admissible or
C                   there are numerical difficulties);
C             = 3:  if the Y-Riccati equation was not solved
C                   successfully (the controller is not admissible or
C                   there are numerical difficulties).
C
C     METHOD
C
C     The routine implements the Glover's and Doyle's formulas [1],[2]
C     modified as described in [3]. The X- and Y-Riccati equations
C     are solved with condition and accuracy estimates [4].
C
C     REFERENCES
C
C     [1] Glover, K. and Doyle, J.C.
C         State-space formulae for all stabilizing controllers that
C         satisfy an Hinf norm bound and relations to risk sensitivity.
C         Systems and Control Letters, vol. 11, pp. 167-172, 1988.
C
C     [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and
C         Smith, R.
C         mu-Analysis and Synthesis Toolbox.
C         The MathWorks Inc., Natick, Mass., 1995.
C
C     [3] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M.
C         Fortran 77 routines for Hinf and H2 design of continuous-time
C         linear control systems.
C         Rep. 98-14, Department of Engineering, Leicester University,
C         Leicester, U.K., 1998.
C
C     [4] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V.
C         DGRSVX and DMSRIC: Fortan 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, Tech. Univ.
C         Chemnitz, May 1998.
C
C     NUMERICAL ASPECTS
C
C     The precision of the solution of the matrix Riccati equations
C     can be controlled by the values of the condition numbers
C     XYCOND(1) and XYCOND(2) of these equations.
C
C     FURTHER COMMENTS
C
C     The Riccati equations are solved by the Schur approach
C     implementing condition and accuracy estimates.
C
C     CONTRIBUTORS
C
C     P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, May 1999,
C     Sept. 1999.
C
C     KEYWORDS
C
C     Algebraic Riccati equation, H-infinity optimal control, robust
C     control.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, LDC, LDD, LDF, LDH, LDWORK,
     $                   LDX, LDY, M, N, NCON, NMEAS, NP
      DOUBLE PRECISION   GAMMA
C     ..
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ),
     $                   D( LDD, * ), DWORK( * ),  F( LDF, * ),
     $                   H( LDH, * ), X( LDX, * ), XYCOND( 2 ),
     $                   Y( LDY, * )
      LOGICAL            BWORK( * )
C
C     ..
C     .. Local Scalars ..
      INTEGER            INFO2, IW2, IWA, IWG, IWI, IWQ, IWR, IWRK, IWS,
     $                   IWT, IWV, LWAMAX, M1, M2, MINWRK, N2, ND1, ND2,
     $                   NN, NP1, NP2
      DOUBLE PRECISION   ANORM, EPS, FERR, RCOND, SEP
C     ..
C     .. External Functions ..
C
      DOUBLE PRECISION   DLAMCH, DLANSY
      EXTERNAL           DLAMCH, DLANSY
C     ..
C     .. External Subroutines ..
      EXTERNAL           DGEMM, DLACPY, DLASET, DSYCON, DSYMM, DSYRK,
     $                   DSYTRF, DSYTRI, MB01RU, MB01RX, SB02RD, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          DBLE, INT, MAX
C     ..
C     .. Executable Statements ..
C
C     Decode and Test input parameters.
C
      M1  = M - NCON
      M2  = NCON
      NP1 = NP - NMEAS
      NP2 = NMEAS
      NN  = N*N
C
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( NP.LT.0 ) THEN
         INFO = -3
      ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN
         INFO = -4
      ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN
         INFO = -5
      ELSE IF( GAMMA.LT.ZERO ) THEN
         INFO = -6
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN
         INFO = -12
      ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN
         INFO = -14
      ELSE IF( LDF.LT.MAX( 1, M ) ) THEN
         INFO = -16
      ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
         INFO = -18
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -20
      ELSE IF( LDY.LT.MAX( 1, N ) ) THEN
         INFO = -22
      ELSE
C
C        Compute workspace.
C
         MINWRK = MAX( 1, M*M + MAX( 2*M1, 3*NN +
     $                               MAX( N*M, 10*NN + 12*N + 5 ) ),
     $                  NP*NP + MAX( 2*NP1, 3*NN +
     $                               MAX( N*NP, 10*NN + 12*N + 5 ) ) )
         IF( LDWORK.LT.MINWRK )
     $      INFO = -26
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SB10QD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0
     $    .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN
         XYCOND( 1 ) = ONE
         XYCOND( 2 ) = ONE
         DWORK( 1 )  = ONE
         RETURN
      END IF
      ND1 = NP1 - M2
      ND2 = M1 - NP2
      N2  = 2*N
C
C     Get the machine precision.
C
      EPS = DLAMCH( 'Epsilon' )
C
C     Workspace usage.
C
      IWA = M*M + 1
      IWQ = IWA + NN
      IWG = IWQ + NN
      IW2 = IWG + NN
C
C     Compute |D1111'||D1111 D1112| - gamma^2*Im1 .
C             |D1112'|
C
      CALL DLASET( 'L', M1, M1, ZERO, -GAMMA*GAMMA, DWORK, M )
      IF( ND1.GT.0 )
     $   CALL DSYRK( 'L', 'T', M1, ND1, ONE, D, LDD, ONE, DWORK, M )
C
C     Compute inv(|D1111'|*|D1111 D1112| - gamma^2*Im1) .
C                 |D1112'|
C
      IWRK = IWA
      ANORM = DLANSY( 'I', 'L', M1, DWORK, M, DWORK( IWRK ) )
      CALL DSYTRF( 'L', M1, DWORK, M, IWORK, DWORK( IWRK ),
     $             LDWORK-IWRK+1, INFO2 )
      IF( INFO2.GT.0 ) THEN
         INFO = 1
         RETURN
      END IF
C
      LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1
      CALL DSYCON( 'L', M1, DWORK, M, IWORK, ANORM, RCOND,
     $             DWORK( IWRK ), IWORK( M1+1 ), INFO2 )
      IF( RCOND.LT.EPS ) THEN
         INFO = 1
         RETURN
      END IF
C
C     Compute inv(R) block by block.
C
      CALL DSYTRI( 'L', M1, DWORK, M, IWORK, DWORK( IWRK ), INFO2 )
C
C     Compute -|D1121 D1122|*inv(|D1111'|*|D1111 D1112| - gamma^2*Im1) .
C                                |D1112'|
C
      CALL DSYMM( 'R', 'L', M2, M1, -ONE, DWORK, M, D( ND1+1, 1 ), LDD,
     $            ZERO, DWORK( M1+1 ), M )
C
C     Compute |D1121 D1122|*inv(|D1111'|*|D1111 D1112| -
C                               |D1112'|
C
C                  gamma^2*Im1)*|D1121'| + Im2 .
C                               |D1122'|
C
      CALL DLASET( 'Lower', M2, M2, ZERO, ONE, DWORK( M1*(M+1)+1 ), M )
      CALL MB01RX( 'Right', 'Lower', 'Transpose', M2, M1, ONE, -ONE,
     $             DWORK( M1*(M+1)+1 ), M, D( ND1+1, 1 ), LDD,
     $             DWORK( M1+1 ), M, INFO2 )
C
C     Compute D11'*C1 .
C
      CALL DGEMM( 'T', 'N', M1, N, NP1, ONE, D, LDD, C, LDC, ZERO,
     $            DWORK( IW2 ), M )
C
C     Compute D1D'*C1 .
C
      CALL DLACPY( 'Full', M2, N, C( ND1+1, 1 ), LDC, DWORK( IW2+M1 ),
     $             M )
C
C     Compute inv(R)*D1D'*C1 in F .
C
      CALL DSYMM( 'L', 'L', M, N, ONE, DWORK, M, DWORK( IW2 ), M, ZERO,
     $            F, LDF )
C
C     Compute Ax = A - B*inv(R)*D1D'*C1 .
C
      CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IWA ), N )
      CALL DGEMM( 'N', 'N', N, N, M, -ONE, B, LDB, F, LDF, ONE,
     $            DWORK( IWA ), N )
C
C     Compute Cx = C1'*C1 - C1'*D1D*inv(R)*D1D'*C1 .
C
      IF( ND1.EQ.0 ) THEN
         CALL DLASET( 'L', N, N, ZERO, ZERO, DWORK( IWQ ), N )
      ELSE
         CALL DSYRK( 'L', 'T', N, NP1, ONE, C, LDC, ZERO,
     $               DWORK( IWQ ), N )
         CALL MB01RX( 'Left', 'Lower', 'Transpose', N, M, ONE, -ONE,
     $                DWORK( IWQ ), N, DWORK( IW2 ), M, F, LDF, INFO2 )
      END IF
C
C     Compute Dx = B*inv(R)*B' .
C
      IWRK = IW2
      CALL MB01RU( 'Lower', 'NoTranspose', N, M, ZERO, ONE,
     $             DWORK( IWG ), N, B, LDB, DWORK, M, DWORK( IWRK ),
     $             M*N, INFO2 )
C
C     Solution of the Riccati equation Ax'*X + X*Ax + Cx - X*Dx*X = 0 .
C     Workspace:  need   M*M + 13*N*N + 12*N + 5;
C                 prefer larger.
C
      IWT  = IW2
      IWV  = IWT + NN
      IWR  = IWV + NN
      IWI  = IWR + N2
      IWS  = IWI + N2
      IWRK = IWS + 4*NN
C
      CALL SB02RD( 'All', 'Continuous', 'NotUsed', 'NoTranspose',
     $             'Lower', 'GeneralScaling', 'Stable', 'NotFactored',
     $             'Original', N, DWORK( IWA ), N, DWORK( IWT ), N,
     $             DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N,
     $             X, LDX, SEP, XYCOND( 1 ), FERR, DWORK( IWR ),
     $             DWORK( IWI ), DWORK( IWS ), N2, IWORK, DWORK( IWRK ),
     $             LDWORK-IWRK+1, BWORK, INFO2 )
      IF( INFO2.GT.0 ) THEN
         INFO = 2
         RETURN
      END IF
C
      LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX )
C
C     Compute F = -inv(R)*|D1D'*C1 + B'*X| .
C
      IWRK = IW2
      CALL DGEMM( 'T', 'N', M, N, N, ONE, B, LDB, X, LDX, ZERO,
     $            DWORK( IWRK ), M )
      CALL DSYMM( 'L', 'L', M, N, -ONE, DWORK, M, DWORK( IWRK ), M,
     $            -ONE, F, LDF )
C
C     Workspace usage.
C
      IWA = NP*NP + 1
      IWQ = IWA + NN
      IWG = IWQ + NN
      IW2 = IWG + NN
C
C     Compute |D1111|*|D1111' D1121'| - gamma^2*Inp1 .
C             |D1121|
C
      CALL DLASET( 'U', NP1, NP1, ZERO, -GAMMA*GAMMA, DWORK, NP )
      IF( ND2.GT.0 )
     $   CALL DSYRK( 'U', 'N', NP1, ND2, ONE, D, LDD, ONE, DWORK, NP )
C
C     Compute inv(|D1111|*|D1111' D1121'| - gamma^2*Inp1) .
C                 |D1121|
C
      IWRK  = IWA
      ANORM = DLANSY( 'I', 'U', NP1, DWORK, NP, DWORK( IWRK ) )
      CALL DSYTRF( 'U', NP1, DWORK, NP, IWORK, DWORK( IWRK ),
     $             LDWORK-IWRK+1, INFO2 )
      IF( INFO2.GT.0 ) THEN
         INFO = 1
         RETURN
      END IF
C
      LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX )
      CALL DSYCON( 'U', NP1, DWORK, NP, IWORK, ANORM, RCOND,
     $             DWORK( IWRK ), IWORK( NP1+1 ), INFO2 )
      IF( RCOND.LT.EPS ) THEN
         INFO = 1
         RETURN
      END IF
C
C     Compute inv(RT) .
C
      CALL DSYTRI( 'U', NP1, DWORK, NP, IWORK, DWORK( IWRK ), INFO2 )
C
C     Compute -inv(|D1111||D1111' D1121'| - gamma^2*Inp1)*|D1112| .
C                  |D1121|                                |D1122|
C
      CALL DSYMM( 'L', 'U', NP1, NP2, -ONE, DWORK, NP, D( 1, ND2+1 ),
     $            LDD, ZERO, DWORK( NP1*NP+1 ), NP )
C
C     Compute [D1112' D1122']*inv(|D1111||D1111' D1121'| -
C                                 |D1121|
C
C                gamma^2*Inp1)*|D1112| + Inp2 .
C                              |D1122|
C
      CALL DLASET( 'Full', NP2, NP2, ZERO, ONE, DWORK( NP1*(NP+1)+1 ),
     $             NP )
      CALL MB01RX( 'Left', 'Upper', 'Transpose', NP2, NP1, ONE, -ONE,
     $             DWORK( NP1*(NP+1)+1 ), NP, D( 1, ND2+1 ), LDD,
     $             DWORK( NP1*NP+1 ), NP, INFO2 )
C
C     Compute B1*D11' .
C
      CALL DGEMM( 'N', 'T', N, NP1, M1, ONE, B, LDB, D, LDD, ZERO,
     $            DWORK( IW2 ), N )
C
C     Compute B1*DD1' .
C
      CALL DLACPY( 'Full', N, NP2, B( 1, ND2+1 ), LDB,
     $             DWORK( IW2+NP1*N ), N )
C
C     Compute B1*DD1'*inv(RT) in H .
C
      CALL DSYMM( 'R', 'U', N, NP, ONE, DWORK, NP, DWORK( IW2 ), N,
     $            ZERO, H, LDH )
C
C     Compute Ay = A - B1*DD1'*inv(RT)*C .
C
      CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IWA ), N )
      CALL DGEMM( 'N', 'N', N, N, NP, -ONE, H, LDH, C, LDC, ONE,
     $            DWORK( IWA ), N )
C
C     Compute Cy = B1*B1' - B1*DD1'*inv(RT)*DD1*B1' .
C
      IF( ND2.EQ.0 ) THEN
         CALL DLASET( 'U', N, N, ZERO, ZERO, DWORK( IWQ ), N )
      ELSE
         CALL DSYRK( 'U', 'N', N, M1, ONE, B, LDB, ZERO, DWORK( IWQ ),
     $               N )
         CALL MB01RX( 'Right', 'Upper', 'Transpose', N, NP, ONE, -ONE,
     $                DWORK( IWQ ), N, H, LDH, DWORK( IW2 ), N, INFO2 )
      END IF
C
C     Compute Dy = C'*inv(RT)*C .
C
      IWRK = IW2
      CALL MB01RU( 'Upper', 'Transpose', N, NP, ZERO, ONE, DWORK( IWG ),
     $             N, C, LDC, DWORK, NP, DWORK( IWRK), N*NP, INFO2 )
C
C     Solution of the Riccati equation Ay*Y + Y*Ay' + Cy - Y*Dy*Y = 0 .
C     Workspace:  need   NP*NP + 13*N*N + 12*N + 5;
C                 prefer larger.
C
      IWT  = IW2
      IWV  = IWT + NN
      IWR  = IWV + NN
      IWI  = IWR + N2
      IWS  = IWI + N2
      IWRK = IWS + 4*NN
C
      CALL SB02RD( 'All', 'Continuous', 'NotUsed', 'Transpose',
     $             'Upper', 'GeneralScaling', 'Stable', 'NotFactored',
     $             'Original', N, DWORK( IWA ), N, DWORK( IWT ), N,
     $             DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N,
     $             Y, LDY, SEP, XYCOND( 2 ), FERR, DWORK( IWR ),
     $             DWORK( IWI ), DWORK( IWS ), N2, IWORK, DWORK( IWRK ),
     $             LDWORK-IWRK+1, BWORK, INFO2 )
      IF( INFO2.GT.0 ) THEN
         INFO = 3
         RETURN
      END IF
C
      LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX )
C
C     Compute H = -|B1*DD1' + Y*C'|*inv(RT) .
C
      IWRK = IW2
      CALL DGEMM( 'N', 'T', N, NP, N, ONE, Y, LDY, C, LDC, ZERO,
     $            DWORK( IWRK ), N )
      CALL DSYMM( 'R', 'U', N, NP, -ONE, DWORK, NP, DWORK( IWRK ), N,
     $            -ONE, H, LDH )
C
      DWORK( 1 ) = DBLE( LWAMAX )
      RETURN
C *** Last line of SB10QD ***
      END


	SUBROUTINE VC_LNIN  ( pb, pt, pp, vb, vt, nxy, vv, iret )
C************************************************************************
C* VC_LNIN								*
C*									*
C*  This subroutine performs linear interpolation.			*
C*									*
C* VC_LNIN ( PB, PT, PP, VB, VT, NXY, VV, IRET )			*
C*									*
C* Input parameters:							*
C*	PB (NXY)	REAL		Ln (p) bottom			*
C*	PT (NXY)	REAL		Ln (p) top			*
C*	PP (NXY)	REAL		Ln (p) at level of interest	*
C*	VB (NXY)	REAL		Value at bottom			*
C*	VT (NXY)	REAL		Value at top			*
C*	NXY		INTEGER		Number of grid points		*
C*									*
C* Output parameters:							*
C*	VV (NXY)	REAL		Value on level of interest	*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 +1 = all missing		*
C**									*
C* Log:									*
C* K. Brill/NMC		07/92						*
C* K. Brill/NMC	     	08/92	Added all missing error			*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		pb (*), pt (*), pp (*), vb (*), vt (*), vv (*)
C*
	LOGICAL		betwen
	INCLUDE		'ERMISS.FNC'
C*
	BETWEN ( rlev, rlo, rhi ) =
     +     ( ( rlev .ge. rlo .and. rlev .le. rhi )   .or.
     +       ( rlev .le. rlo .and. rlev .ge. rhi ) )
C-----------------------------------------------------------------------
	iret = 0
	icnt = 0
C
C*	Interpolate only at points between the two bounding surfaces.
C*	Store missing values elsewhere.
C
	DO ij = 1, nxy
	    IF ( BETWEN ( pp (ij), pb (ij), pt (ij) ) .and.
     +		 .not. ( ERMISS ( pb (ij) ) .or.
     +			 ERMISS ( pt (ij) ) .or.
     +		         ERMISS ( pp (ij) ) .or.
     +			 ERMISS ( vb (ij) ) .or.
     +			 ERMISS ( vt (ij) )      ) .and.
     +			 pt (ij) .ne. pb (ij) ) THEN
C
C*		Do linear interpolation if values are not missing.
C
		vv (ij) = vb (ij) + ( pp (ij) - pb (ij) ) *
     +		       ( ( vt (ij) - vb (ij) ) / ( pt (ij) - pb (ij) ) )
C*
	    ELSE
		vv (ij) = RMISSD
		icnt = icnt + 1
	    END IF
	END DO
	IF ( icnt .eq. nxy ) iret = +1
C*
	RETURN
	END


program vin
  integer:: val(10,5),val2(5)
  val = 5

  val2 = sum(val, dim=1)
  print *,sum(val, dim=2)
  print *,sum(val, dim=2,mask=val /=5)
  print *,sum(val, dim=1,mask=val ==5)
  print *,val2
end program vin


MODULE SYSGRIDS
 USE FORTGRAPHER
 USE GEOAXES
 USE SYSINFO

 INTERFACE GEODSTNBTWN
  MODULE PROCEDURE R4GEODSTNBTWN,R8GEODSTNBTWN
 END INTERFACE GEODSTNBTWN

 INTERFACE GEOBEARINGBTWN
  MODULE PROCEDURE R4GEOBEARINGBTWN,R8GEOBEARINGBTWN
 END INTERFACE GEOBEARINGBTWN

 CONTAINS

 SUBROUTINE GRIDBUILDER
  IMPLICIT NONE
  REAL(8), PARAMETER   :: PI=4.0d0*ATAN(1.0d0)
  REAL(4), ALLOCATABLE :: tX1D(:),tY1D(:),tZ1D(:)
  REAL(4)              :: xDST,yDST
  REAL(4)              :: R,BEARNG
  INTEGER(4)           :: iXDIM,iYDIM,iZDIM
  INTEGER(4)           :: nLAT,nLON,nALT
  INTEGER(4)           :: iLAT,iLON,iALT

  nLAT=XDIM;nLON=YDIM;nALT=ZDIM

  IF(ALLOCATED(X1D)) DEALLOCATE(X1D)
  IF(ALLOCATED(Y1D)) DEALLOCATE(Y1D)
  IF(ALLOCATED(Z1D)) DEALLOCATE(Z1D)
  ALLOCATE(X1D(XDIM))
  ALLOCATE(Y1D(YDIM))
  ALLOCATE(Z1D(ZDIM))

  IF(ALLOCATED(X3D)) DEALLOCATE(X3D)
  IF(ALLOCATED(Y3D)) DEALLOCATE(Y3D)
  IF(ALLOCATED(Z3D)) DEALLOCATE(Z3D)
  ALLOCATE(X3D(XDIM,YDIM,ZDIM))
  ALLOCATE(Y3D(XDIM,YDIM,ZDIM))
  ALLOCATE(Z3D(XDIM,YDIM,ZDIM))

  IF(EQUISPACED.AND.RECTGRID) THEN
   CALL LINVECTOR(Xsrt,Xend,XDIM,X1D)
   CALL LINVECTOR(Ysrt,Yend,YDIM,Y1D)
   CALL LINVECTOR(Zsrt,Zend,ZDIM,Z1D)
   CALL MESHGRID(X1D,Y1D,Z1D,X3D,Y3D,Z3D)
   IF(ALLOCATED(X1D)) DEALLOCATE(X1D)
   IF(ALLOCATED(Y1D)) DEALLOCATE(Y1D)
   IF(ALLOCATED(Z1D)) DEALLOCATE(Z1D)

   IF(GEOGRAPHICGRID) THEN
!******** BUILDING THE ALT(Z)-DIMESNION GRID ***********
    IF(ALLOCATED(ALT1D)) DEALLOCATE(ALT1D)
    ALLOCATE(ALT1D(nALT))
   !IF(ALLOCATED(ALT3D)) DEALLOCATE(ALT3D)
   !ALLOCATE(ALT3D(nLAT,nLON,nALT))
    IF(nALT.GT.1) THEN
     DO iALT=1,nALT
      ALT1D(iALT)=srtALT+1.0d-3*Z3D(1,1,iALT)
     END DO
    !DO iLAT=1,nLAT
    ! DO iLON=1,nLON
    !  ALT3D(iLAT,iLON,:)=ALT1D
    ! END DO
    !END DO
    ELSE IF(nALT.EQ.1) THEN
     ALT1D=srtALT
    !DO iLAT=1,nLAT
    ! DO iLON=1,nLON
    !  ALT3D(iLAT,iLON,:)=srtALT
    ! END DO
    !END DO
    END IF

!******** BUILDING THE LAT(X)-DIMESNION GRID ***********
    IF(ALLOCATED(LAT1D)) DEALLOCATE(LAT1D)
    ALLOCATE(LAT1D(nLAT))
   !IF(ALLOCATED(LAT3D)) DEALLOCATE(LAT3D)
   !ALLOCATE(LAT3D(nLAT,nLON,nALT))
    IF(nLAT.GT.1) THEN
     xDST=(X3D(2,1,1)-X3D(1,1,1))*1.0e-3
     BEARNG=GEOBEARINGBTWN(srtLAT,endLAT,srtLON,srtLON)
     DO iALT=1,nALT
      R=RE+ALT1D(iALT)
      LAT1D(1)=srtLAT
      DO iLAT=2,nLAT
       LAT1D(iLAT)=RAD2DEG(ASIN(SIN(DEG2RAD(LAT1D(iLAT-1)))*COS(xDST/R)+COS(DEG2RAD(LAT1D(iLAT-1)))*SIN(xDST/R)*COS(BEARNG)))
      END DO
     !DO iLON=1,nLON
     ! LAT3D(:,iLON,iALT)=LAT1D
     !END DO
     END DO
    ELSE IF(nLAT.EQ.1) THEN
     LAT1D=srtLAT
    !DO iALT=1,nALT
    ! DO iLON=1,nLON
    !  ALT3D(:,iLON,iALT)=srtLAT
    ! END DO
    !END DO
    END IF

!******** BUILDING THE LON(Y)-DIMESNION GRID ***********
    IF(ALLOCATED(LON1D)) DEALLOCATE(LON1D)
    ALLOCATE(LON1D(nLON))
   !IF(ALLOCATED(LON3D)) DEALLOCATE(LON3D)
   !ALLOCATE(LON3D(nLAT,nLON,nALT))
    IF(nLON.GT.1) THEN
     yDST=(Y3D(1,2,1)-Y3D(1,1,1))*1.0e-3
     BEARNG=GEOBEARINGBTWN(srtLAT,srtLAT,srtLON,endLON)
     DO iALT=1,nALT
      R=RE+ALT1D(iALT)
      LON1D(1)=srtLON
      DO iLON=2,nLON
       LON1D(iLON)=LON1D(iLON-1)+RAD2DEG(ATAN2(SIN(yDST/R)*COS(DEG2RAD(srtLAT))*SIN(BEARNG),COS(yDST/R)-SIN(DEG2RAD(srtLAT))**2))
      END DO
     !DO iLAT=1,nLAT
     ! LON3D(iLAT,:,iALT)=LON1D
     !END DO
     END DO
    ELSE IF(nLON.EQ.1) THEN
     LON1D=srtLON
    !DO iALT=1,nALT
    ! DO iLAT=1,nLAT
    !  ALT3D(iLAT,:,iALT)=srtLON
    ! END DO
    !END DO
    END IF

   END IF
   PRINT*, "EQUISPACED R-SPACE 3D GRIDS BUILDING >>> DONE!"

  ELSE IF(CHEBYSHEVSPACED.AND.RECTGRID) THEN
   DO iXDIM=1,XDIM
    X1D(iXDIM)=COS((2.0d0*iXDIM-1.0d0)*PI/(2.0d0*XDIM))
   END DO
   X1D=1.0d0*((Xend-Xsrt)*X1D+(Xend+Xsrt))/2.0d0
   DO iYDIM=1,YDIM
    Y1D(iYDIM)=COS((2.0d0*iYDIM-1.0d0)*PI/(2.0d0*YDIM))
   END DO
   Y1D=1.0d0*((Yend-Ysrt)*Y1D+(Yend+Ysrt))/2.0d0
   DO IZDIM=1,ZDIM
    Z1D(iZDIM)=COS((2.0d0*iZDIM-1.0d0)*PI/(2.0d0*ZDIM))
   END DO
   Z1D=1.0d0*((Zend-Zsrt)*Z1D+(Zend+Zsrt))/2.0d0

   CALL MESHGRID(X1D,Y1D,Z1D,X3D,Y3D,Z3D)
   PRINT*, "CHEBYSHEV R-SPACE 3D GRIDS BUILDING >>> DONE!"
  END IF

  RETURN
 END SUBROUTINE GRIDBUILDER

!FUNCTION FINDLONBEARING(sLAT,sLON,R,d,TOL)
! IMPLICIT NONE
! REAL(4)            :: FINDLONBEARING
! REAL(4),INTENT(IN) :: sLAT,sLON,R,d
! REAL(4),OPTIONAL   :: TOL
! REAL(4)            :: eLON
! REAL(4)            :: sBEARING,eBEARING,tBEARING
! INTEGER(4)         :: ICOUNTER=0

! IF(PRESENT(TOL)) THEN
!  tBEARING=TOL
! ELSE
!  tBEARING=1.e-6
! END IF

! eBEARING=10.0
! sBEARING=0.0
! DO WHILE(ABS(eBEARING-sBEARING).LE.tBEARING)
!  sBEARING=eBEARING
!  eLON=sLON+RAD2DEG(ATAN2(SIN(d/R)*COS(DEG2RAD(sLAT))*SIN(sBEARING),COS(d/R)-SIN(DEG2RAD(sLAT))**2))
!  eBEARING=GEOBEARINGBTWN(sLAT,sLAT,sLON,eLON)
!  ICOUNTER=ICOUNTER+1
!  PRINT*, ICOUNTER,sBEARING,eBEARING
! END DO
! FINDLONBEARING=eBEARING

! RETURN
!END FUNCTION FINDLONBEARING

!**********************************************************
!************* BUILD THE UNIVERSAL TIME MATRIX ************
!**********************************************************
 SUBROUTINE DTLTMAT
  IMPLICIT NONE
  INTEGER(4) :: srtLTHUR,srtLTMIN,srtLTSEC
  INTEGER(4) :: endLTHUR,endLTMIN,endLTSEC
  INTEGER(4) :: stpLTHUR,stpLTMIN,stpLTSEC
  INTEGER(4) :: srtYYYY,srtMM,srtDD,srtMMDD
  INTEGER(4) :: endYYYY,endMM,endDD,endMMDD

  INTEGER(4) :: TEMPNUM1,TEMPNUM2,TEMPNUM3
  INTEGER(4) :: srtDY,endDY,NRDAYMON
  INTEGER(4) :: NoY,TNoD,CurrentYYYY
  INTEGER(4) :: I,J,K,L,srtJ,endJ,ICOUNTER
  INTEGER(4),ALLOCATABLE :: DoY(:)

  IF(srtLT.LT.0.OR.srtLT.GT.240000) THEN
    WRITE(*,*) "START LOCAL TIME MUST BE BETWEEN 0 AND 240000"
    RETURN
  END IF
  IF(endLT.LT.0.OR.endLT.GT.240000) THEN
    WRITE(*,*) "END LOCAL TIME MUST BE BETWEEN 0 AND 240000"
    RETURN
  END IF
  IF(srtLT.GT.endLT) THEN
    WRITE(*,*) "START LOCAL TIME IS NOT LARGE THAN END LOCAL TIME"
    RETURN
  END IF

  srtLTHUR=srtLT/10000
  srtLTMIN=MOD(srtLT,10000)/100
  srtLTSEC=MOD(MOD(srtLT,10000),100)

  endLTHUR=endLT/10000
  endLTMIN=MOD(endLT,10000)/100
  endLTSEC=MOD(MOD(endLT,10000),100)

  stpLTHUR=stpLT/10000
  stpLTMIN=MOD(stpLT,10000)/100
  stpLTSEC=MOD(MOD(stpLT,10000),100)

  IF(srtLT.EQ.endLT.OR.stpLT.EQ.0) THEN
    IF(ALLOCATED(LTHURMAT)) DEALLOCATE(LTHURMAT)
    IF(ALLOCATED(LTMINMAT)) DEALLOCATE(LTMINMAT)
    IF(ALLOCATED(LTSECMAT)) DEALLOCATE(LTSECMAT)
    ALLOCATE(LTHURMAT(1),LTMINMAT(1),LTSECMAT(1))
    LTHURMAT(1)=srtLTHUR
    LTMINMAT(1)=srtLTMIN
    LTSECMAT(1)=srtLTSEC
  ELSE
    TEMPNUM1=srtLTHUR*3600+srtLTMIN*60+srtLTSEC
    TEMPNUM2=endLTHUR*3600+endLTMIN*60+endLTSEC
    TEMPNUM3=stpLTHUR*3600+stpLTMIN*60+stpLTSEC
    IF(ALLOCATED(LTMAT))    DEALLOCATE(LTMAT)
    IF(ALLOCATED(LTHURMAT)) DEALLOCATE(LTHURMAT)
    IF(ALLOCATED(LTMINMAT)) DEALLOCATE(LTMINMAT)
    IF(ALLOCATED(LTSECMAT)) DEALLOCATE(LTSECMAT)
    ALLOCATE(LTMAT(((TEMPNUM2-TEMPNUM1)/TEMPNUM3)+1))
    ALLOCATE(LTHURMAT(((TEMPNUM2-TEMPNUM1)/TEMPNUM3)+1))
    ALLOCATE(LTMINMAT(((TEMPNUM2-TEMPNUM1)/TEMPNUM3)+1))
    ALLOCATE(LTSECMAT(((TEMPNUM2-TEMPNUM1)/TEMPNUM3)+1))
    CALL VARVECTOR(TEMPNUM1,TEMPNUM2,TEMPNUM3,LTMAT)
    DO I=1,SIZE(LTMAT)
      LTHURMAT(I)=LTMAT(I)/3600
      LTMINMAT(I)=MOD(LTMAT(I),3600)/60
      LTSECMAT(I)=MOD(MOD(LTMAT(I),3600),60)
    END DO
  END IF

  IF(srtDT.LT.19000101.OR.srtDT.GT.20201231) THEN
    WRITE(*,*) "START DATE MUST BE BETWEEN 19000101 AND 20201231"
    RETURN
  END IF
  IF(endDT.LT.19000101.OR.endDT.GT.20201231) THEN
    WRITE(*,*) "END DATE MUST BE BETWEEN 19000101 AND 20201231"
    RETURN
  END IF
  IF(srtDT.GT.endDT) THEN
    WRITE(*,*) "START DATE IS NOT LARGE THAN END DATE"
    RETURN
  END IF

  srtYYYY=srtDT/10000
  srtMM=MOD(srtDT,10000)/100
  srtDD=MOD(MOD(srtDT,10000),100)
  srtMMDD=100*srtMM+srtDD

  endYYYY=endDT/10000
  endMM=MOD(endDT,10000)/100
  endDD=MOD(MOD(endDT,10000),100)
  endMMDD=100*endMM+endDD

  IF(srtDT.EQ.endDT) THEN
    IF(ALLOCATED(DTMAT))     DEALLOCATE(DTMAT)
    IF(ALLOCATED(DTYYYYMAT)) DEALLOCATE(DTYYYYMAT)
    IF(ALLOCATED(DTMMMAT))   DEALLOCATE(DTMMMAT)
    IF(ALLOCATED(DTDDMAT))   DEALLOCATE(DTDDMAT)
    IF(ALLOCATED(DTMMDDMAT)) DEALLOCATE(DTMMDDMAT)
    ALLOCATE(DTYYYYMAT(1),DTMMMAT(1),DTDDMAT(1))
    ALLOCATE(DTMMDDMAT(1),DTMAT(1))
    DTYYYYMAT(1)=srtYYYY
    DTMMMAT(1)=srtMM
    DTDDMAT(1)=srtDD
    DTMMDDMAT(1)=srtMMDD
    CALL IDDD(0,srtYYYY,srtMM,srtDD,srtDY,NRDAYMON)
    DTMAT(1)=1000*DTYYYYMAT(1)+srtDY
  ELSEIF(srtYYYY.EQ.endYYYY) THEN
    CALL IDDD(0,srtYYYY,srtMM,srtDD,srtDY,NRDAYMON)
    CALL IDDD(0,endYYYY,endMM,endDD,endDY,NRDAYMON)
    IF(ALLOCATED(DTMAT))     DEALLOCATE(DTMAT)
    IF(ALLOCATED(DTYYYYMAT)) DEALLOCATE(DTYYYYMAT)
    IF(ALLOCATED(DTMMMAT))   DEALLOCATE(DTMMMAT)
    IF(ALLOCATED(DTDDMAT))   DEALLOCATE(DTDDMAT)
    IF(ALLOCATED(DTMMDDMAT)) DEALLOCATE(DTMMDDMAT)
    ALLOCATE(DTMAT((endDY-srtDY)+1))
    ALLOCATE(DTYYYYMAT((endDY-srtDY)+1))
    ALLOCATE(DTMMMAT((endDY-srtDY)+1))
    ALLOCATE(DTDDMAT((endDY-srtDY)+1))
    ALLOCATE(DTMMDDMAT((endDY-srtDY)+1))
    CALL VARVECTOR(srtDY,endDY,1,DTMAT)
    DTYYYYMAT=srtYYYY
    DO I=1,SIZE(DTMAT)
      CALL IDDD(1,srtYYYY,DTMMMAT(I),DTDDMAT(I),DTMAT(I),NRDAYMON)
      DTMMDDMAT(I)=100*DTMMMAT(I)+DTDDMAT(I)
      DTMAT(I)=1000*DTYYYYMAT(I)+DTMAT(I)
    END DO
  ELSEIF(srtYYYY.LT.endYYYY) THEN
    CALL IDDD(0,srtYYYY,srtMM,srtDD,srtDY,NRDAYMON)
    CALL IDDD(0,endYYYY,endMM,endDD,endDY,NRDAYMON)
    NoY=endYYYY-srtYYYY
    IF(ALLOCATED(DoY)) DEALLOCATE(DoY)
    ALLOCATE(DoY(NoY+1))
    IF(MOD(srtYYYY,4).EQ.0) THEN
      TNoD=1+(366-srtDY)
      DoY(1)=1+(366-srtDY)
    ELSE
      TNoD=1+(365-srtDY)
      DoY(1)=1+(365-srtDY)
    END IF
    TNoD=TNoD+endDY
    DoY(NoY+1)=endDY
    DO I=1,NoY-1
      CurrentYYYY=srtYYYY+I
      IF(MOD(CurrentYYYY,4).EQ.0) THEN
        TNoD=TNoD+366
        DoY(I+1)=366
      ELSE
        TNoD=TNoD+365
        DoY(I+1)=365
      END IF
    END DO
    IF(ALLOCATED(DTMAT))     DEALLOCATE(DTMAT)
    IF(ALLOCATED(DTYYYYMAT)) DEALLOCATE(DTYYYYMAT)
    IF(ALLOCATED(DTMMMAT))   DEALLOCATE(DTMMMAT)
    IF(ALLOCATED(DTDDMAT))   DEALLOCATE(DTDDMAT)
    IF(ALLOCATED(DTMMDDMAT)) DEALLOCATE(DTMMDDMAT)
    ALLOCATE(DTMAT(TNoD))
    ALLOCATE(DTYYYYMAT(TNoD))
    ALLOCATE(DTMMMAT(TNoD))
    ALLOCATE(DTDDMAT(TNoD))
    ALLOCATE(DTMMDDMAT(TNoD))

    ICOUNTER=1
    DO I=1,NoY+1
      CurrentYYYY=srtYYYY+(I-1)
      IF(CurrentYYYY.EQ.srtYYYY) THEN
        srtJ=srtDY
        endJ=(srtDY+DoY(I))-1
      ELSEIF(CurrentYYYY.EQ.endYYYY) THEN
        srtJ=1
        endJ=endDY
      ELSE
        srtJ=1
        endJ=DoY(I)
      END IF
      DO J=srtJ,endJ
        DTYYYYMAT(ICOUNTER)=CurrentYYYY
        DTMAT(ICOUNTER)=J
        CALL IDDD(1,CurrentYYYY,DTMMMAT(ICOUNTER),DTDDMAT(ICOUNTER),DTMAT(ICOUNTER),NRDAYMON)
        DTMMDDMAT(ICOUNTER)=100*DTMMMAT(ICOUNTER)+DTDDMAT(ICOUNTER)
        DTMAT(ICOUNTER)=1000*DTYYYYMAT(ICOUNTER)+DTMAT(ICOUNTER)
        ICOUNTER=ICOUNTER+1
      END DO
    END DO
  END IF

!       DO I=1,SIZE(DTMAT)
!          PRINT*, DTMAT(I),DTYYYYMAT(I),DTMMMAT(I),DTDDMAT(I),DTMMDDMAT(I)
!       END DO

 END SUBROUTINE DTLTMAT

 SUBROUTINE IYYDDD(iyr,iday,hrl,glong,iyd,secut)

! msistim calculates time parameters for the
! nrlmsise00 neutral atmosphere model.

! the arguments are defined as follows:

! iyr    the julian year
! iday   the day of the year
! hr     the local time in hours
! glong  the geocentric longitude in degrees east
! iyd    the year and day in the form yyddd
! secut  the universal time in seconds

  iyd    = 1000 * mod(iyr,100) + iday
  hrut   = hrl - glong /15.

  do while ( hrut .lt. 0.  )
    hrut = hrut + 24.
  enddo

  do while ( hrut .ge. 24. )
    hrut = hrut - 24.
  enddo

  secut  = hrut * 3600.

  return
 END SUBROUTINE IYYDDD

 SUBROUTINE IDDD(IN,IYEAR,MONTH,IDAY,IDOY,NRDAYMO)
!-------------------------------------------------------------------
! CALCULATES DAY OF YEAR (IDOY, ddd) FROM YEAR (IYEAR, yy or yyyy),
! MONTH (MONTH, mm) AND DAY OF MONTH (IDAY, dd) IF IN=0, OR MONTH
! AND DAY FROM YEAR AND DAY OF YEAR IF IN=1. NRDAYMO is an output
! parameter providing the number of days in the specific month.
!-------------------------------------------------------------------
  REAL(4) :: MM(12)

  MM=(/31,28,31,30,31,30,31,31,30,31,30,31/)
  IMO=0
  MOBE=0
!
!  leap year rule: years evenly divisible by 4 are leap years, except
!  years also evenly divisible by 100 are not leap years, except years
!  also evenly divisible by 400 are leap years. The year 2000 therefore
!  is a leap year. The 100 and 400 year exception rule
!     if((iyear/4*4.eq.iyear).and.(iyear/100*100.ne.iyear)) mm(2)=29
!  will become important again in the year 2100 which is not a leap
!  year.
!
  MM(2)=28
  IF(IYEAR/4*4.EQ.IYEAR) MM(2)=29

  IF(IN.GT.0) GOTO 5

  MOSUM=0
  IF(MONTH.GT.1) THEN
    DO I=1,MONTH-1
       MOSUM=MOSUM+MM(i)
    END DO
  END IF
  IDOY=MOSUM+IDAY
  NRDAYMO=MM(MONTH)
  RETURN

5 IMO=IMO+1
  IF(IMO.GT.12) GOTO 55
  MOOLD=MOBE
  NRDAYMO=MM(IMO)
  MOBE=MOBE+nrdaymo
  IF(MOBE.LT.IDOY) GOTO 5
55 MONTH=IMO
  IDAY=IDOY-MOOLD
  RETURN

 END SUBROUTINE IDDD

!*************************************************************************
!  TO CALCULATE THE GEODISTANCE BETWEEN TWO POINTS ON EARTH COORDINATES
!*************************************************************************
 FUNCTION R4GEODSTNBTWN(R,LAT1,LAT2,LON1,LON2)
  IMPLICIT NONE
  REAL(4) :: LAT1,LAT2                 ! GEOGRAPHIC LATITUDES
  REAL(4) :: radLAT1,radLAT2
  REAL(4) :: LON1,LON2                 ! GEOGRAPHIC LONGITUDES
  REAL(4) :: radLON1,radLON2
  REAL(4) :: R
  REAL(4) :: A1,A2,R4GEODSTNBTWN

  radLAT1=DEG2RAD(LAT1)
  radLAT2=DEG2RAD(LAT2)
  radLON1=DEG2RAD(LON1)
  radLON2=DEG2RAD(LON2)
  A1=(SIN((radLAT2-radLAT1)/2)**2)+(COS(radLAT1)*COS(radLAT2)*(SIN((radLON2-radLON1)/2)**2))
  A2=1-A1
  R4GEODSTNBTWN=2.0*R*ATAN2(SQRT(A1),SQRT(A2))
 END FUNCTION R4GEODSTNBTWN

 FUNCTION R8GEODSTNBTWN(R,LAT1,LAT2,LON1,LON2)
  IMPLICIT NONE
  REAL(8) :: LAT1,LAT2                 ! GEOGRAPHIC LATITUDES
  REAL(8) :: radLAT1,radLAT2
  REAL(8) :: LON1,LON2                 ! GEOGRAPHIC LONGITUDES
  REAL(8) :: radLON1,radLON2
  REAL(8) :: R
  REAL(8) :: A1,A2,R8GEODSTNBTWN

  radLAT1=DEG2RAD(LAT1)
  radLAT2=DEG2RAD(LAT2)
  radLON1=DEG2RAD(LON1)
  radLON2=DEG2RAD(LON2)
  A1=(SIN((radLAT2-radLAT1)/2)**2)+(COS(radLAT1)*COS(radLAT2)*(SIN((radLON2-radLON1)/2)**2))
  A2=1-A1
  R8GEODSTNBTWN=2.0*R*ATAN2(SQRT(A1),SQRT(A2))
 END FUNCTION R8GEODSTNBTWN

!*************************************************************************
!  TO CALCULATE THE GEO-BEARING BETWEEN TWO POINTS ON EARTH COORDINATES
!*************************************************************************
 FUNCTION R4GEOBEARINGBTWN(LAT1,LAT2,LON1,LON2)
  IMPLICIT NONE
  REAL(4) :: LAT1,LAT2
  REAL(4) :: radLAT1,radLAT2
  REAL(4) :: LON1,LON2
  REAL(4) :: radLON1,radLON2
  REAL(4) :: R4GEOBEARINGBTWN

  radLAT1=DEG2RAD(LAT1)
  radLAT2=DEG2RAD(LAT2)
  radLON1=DEG2RAD(LON1)
  radLON2=DEG2RAD(LON2)
  R4GEOBEARINGBTWN=ATAN2(SIN(radLON2-radLON1)*COS(radLAT2),COS(radLAT1)*SIN(radLAT2)-SIN(radLAT1)*COS(radLAT2)*COS(radLON2-radLON1))
 END FUNCTION R4GEOBEARINGBTWN

 FUNCTION R8GEOBEARINGBTWN(LAT1,LAT2,LON1,LON2)
  IMPLICIT NONE
  REAL(8) :: LAT1,LAT2
  REAL(8) :: radLAT1,radLAT2
  REAL(8) :: LON1,LON2
  REAL(8) :: radLON1,radLON2
  REAL(8) :: R8GEOBEARINGBTWN

  radLAT1=DEG2RAD(LAT1)
  radLAT2=DEG2RAD(LAT2)
  radLON1=DEG2RAD(LON1)
  radLON2=DEG2RAD(LON2)
  R8GEOBEARINGBTWN=ATAN2(SIN(radLON2-radLON1)*COS(radLAT2),COS(radLAT1)*SIN(radLAT2)-SIN(radLAT1)*COS(radLAT2)*COS(radLON2-radLON1))
 END FUNCTION R8GEOBEARINGBTWN

!****************************************************************
!******* CALCULATING THE GEOMAGNETIC SHELLS (FLUX TUBES) ********
!****************************************************************
 SUBROUTINE BSHELL(L,PHIG,R,Q,IGRFYEAR)
  IMPLICIT NONE

  REAL :: L
  REAL(8) :: QMIN,QNMAX,QSMAX,QVALUE
  REAL(8), PARAMETER :: PI=4.0d0*ATAN(1.0d0)
! REAL(8) :: DR,RE,R,RM0,XED,YED,ZED,DRMIN,CN
  REAL(8) :: DR,R,RM0,XED,YED,ZED,DRMIN,CN
  REAL(8) :: RED,THETAED,PHIED,RED2,RCD,THETACD,PHICD
  REAL(8) :: PHIG,RG,THETAG,THETAN,PHIN
  REAL(8) :: IGRFYEAR
  REAL(8) :: THETAM0,X,Z,C,TEMP
  REAL(8), DIMENSION(3) :: EDXYZ,CDXYZ
  REAL(8), DIMENSION(:) :: Q
  REAL(8), ALLOCATABLE, DIMENSION(:,:) :: ED,CD,GEO
  INTEGER :: I,N,NN,NS

  X=1.0
  DRMIN=0.5
  CN=401.0
  N=INT(CN)
  NN=(N-1)/2;NS=(N-1)/2
  ALLOCATE(ED(N,3))
  ALLOCATE(CD(N,3))
  ALLOCATE(GEO(N,3))

! RE=6300.0
  RM0=R

! DO I=1,7
  DO WHILE(ABS(DR).LT.DRMIN)
    THETAM0=ASIN(SQRT(RM0/(R*L)))
    CALL ED2CD(RM0,THETAM0,PHIG,RG,THETACD,PHICD,IGRFYEAR)
    DR=RG-R
!   IF(ABS(DR).LT.DRMIN) GOTO 11
    RM0=RM0-ABS(DR)
  END DO
! print*, RM0

!11   QMIN=0
  QMIN=0
  Q(201)=QMIN
  QNMAX=COS(THETAM0)*(R/RM0)**2
  C=2/(CN-1)

  DO I=1,NN
    Q(I)=0.2*ASINH(X*SINH(5.0*QNMAX))
    X=X+C
  END DO

  X=-1.0
! DO I=1,7
  DO WHILE(ABS(DR).LT.DRMIN)
    THETAM0=ASIN(-SQRT(RM0/(R*L)))
    CALL ED2CD(RM0,THETAM0,PHIG,RG,THETACD,PHICD,IGRFYEAR)
    DR=RG-R
!   IF(ABS(DR).LT.DRMIN) GOTO 12
      RM0=RM0-ABS(DR)
  END DO
!   print*, RM0

!12 QSMAX=COS(THETAM0)*(R/RM0)**2
  QSMAX=COS(THETAM0)*(R/RM0)**2
  C=2/(CN-1)

  DO I=0,NS-1
    Q(401-I)=0.2*ASINH(X*SINH(5*QSMAX))
    X=X+C
  END DO

  ED(201,1)=R*L
  ED(201,2)=ASIN(SQRT(ED(201,1)/(R*L)))
  DO I=1,(N-1)/2
    ED(201-I,1)=NROOT(ED(202-I,1),L,Q(201-I))
    ED(201-I,2)=ASIN(SQRT(ED(201-I,1)/(R*L)))
    ED(201-I,3)=PHIED
    ED(201+I,1)=NROOT(ED(200+I,1),L,Q(201+I))
    ED(201+I,2)=ASIN(-SQRT(ED(201+I,1)/(R*L)))
    ED(201+I,3)=PHIED
  END DO
  DO I=1,N
    CALL ED2CD(ED(I,1),ED(I,2),ED(I,3),CD(I,1),CD(I,2),CD(I,3),IGRFYEAR)
    GEO(I,1)=CD(I,1)
    CALL CD2GEO(CD(I,2),CD(I,3),GEO(I,2),GEO(I,3),IGRFYEAR)
  END DO

  print*, GEO(201,1),RAD2DEG(GEO(1,2)),RAD2DEG(GEO(1,3))
 END SUBROUTINE BSHELL

!**********************************************************
!***************** GEOGRAPHIC GRID ************************
!**********************************************************
!      SUBROUTINE FIELDGRID
!!             (/srtLAT,endLAT,srtLON,endLON,srtALT,endALT/)
!!              srtLAT=START POINT IN COLATITUDE (REAL(4) DEGREES: 0.0 -> 180.0)
!!              endLAT=END POINT IN LATITUDE EAST (REAL(4) DEGREES: 0.0 -> 360.0)
!!             (/nLAT,nLON,nALT/)
!!             nLAT=NUMBER OF POINTS ALONG LATITUDE RANGE (INTEGER(4))
!      IMPLICIT NONE
!      INTEGER(4) :: I,J,K,GEOGRIDID=0

!      IF(srtLAT.EQ.endLAT.OR.nLAT.EQ.1) THEN
!        vecLAT1D=srtLAT
!      ELSE
!        CALL LINVECTOR(srtLAT,endLAT,nLAT,vecLAT1D)
!      END IF
!      IF(srtLON.EQ.endLON.OR.nLON.EQ.1) THEN
!        vecLON1D=srtLON
!      ELSE
!        CALL LINVECTOR(srtLON,endLON,nLON,vecLON1D)
!      END IF
!      IF(srtALT.EQ.endALT.OR.nALT.EQ.1) THEN
!        vecALT1D=srtALT
!      ELSE
!        CALL LINVECTOR(srtALT,endALT,nALT,vecALT1D)
!      END IF
!      CALL MESHGRID(vecLAT1D,vecLON1D,vecLAT2D,vecLON2D)

!      DO I=1,nALT
!         DO J=1,nLAT
!            DO K=1,nLON
!               GEOGRIDID=GEOGRIDID+1
!               GEOMESHGRID(GEOGRIDID,1)=vecLAT2D(J,K)
!               GEOMESHGRID(GEOGRIDID,2)=vecLON2D(J,K)
!               GEOMESHGRID(GEOGRIDID,3)=vecLAT1D(I)
!            END DO
!          END DO
!      END DO

!     END SUBROUTINE FIELDGRID

!**********************************************************
!***************** OTHER FGUNCTIONS ***********************
!**********************************************************
 FUNCTION BQF(RI,L,Q)
  IMPLICIT NONE
  REAL(8) :: RI,Q,BQF,R=6371.0
  REAL :: L

  BQF=((Q**2/R**4)*(RI**4))+(RI/(L*R))-1
 END FUNCTION BQF

 FUNCTION NROOT(Z,L,Q)
  IMPLICIT NONE
  REAL(8) :: TOL,H,Z,NROOT,F,FH,DF,Q
  REAL :: L
  INTEGER :: I

  H=1E-1
  TOL=1E-5
! DO I=1,7
  DO WHILE(F.LE.TOL)
    F=BQF(Z,L,Q)
!   IF(F.LE.TOL) GOTO 21
    FH=BQF(Z+H,L,Q)
    DF=(FH-F)/H
!   DF=BQDF(Z,L,Q)
    Z=Z-(F/DF)
  END DO
  NROOT=Z
!21   NROOT=Z
 END FUNCTION NROOT

END MODULE SYSGRIDS


! ======================================================================
! NAME
!
!     POTENTIAL
!
! DESCRIPTION
!
!     POTENTIAL is a supporting program of GPECN1DTDPBC that generates
!     time-independent external potential functions that may be used to
!     act on its wave functions.
!
! AUTHOR
!
!     Marty Kandes, Ph.D.
!     Computational & Data Science Research Specialist
!     User Services Group
!     San Diego Supercomputer Center
!     University of California, San Diego
!
! COPYRIGHT
!
!     Copyright (c) 2010 - 2021 Martin Charles Kandes
!
! LICENSE
!
!     The MIT License (MIT)
!
! LAST UPDATED
!
!     Tuesday, April 4th, 2017
!
! ----------------------------------------------------------------------
      PROGRAM POTENTIAL
      IMPLICIT NONE

!     Parameter Declarations:
!     -----------------------
      REAL, PARAMETER :: PI = 3.1415926535897932384626433832795028841971E0

!     Input Variable and Array Declarations:
!     --------------------------------------
      INTEGER :: NUMBER_OF_GRID_POINTS
      INTEGER :: EXTERNAL_POTENTIAL_SWITCH

      REAL :: RADIUS
      REAL :: GAUSSIAN_OSCILLATOR_STRENGTH
      REAL :: INITIAL_ANGULAR_POSITION

!     Internal Variable and Array Declarations:
!     -----------------------------------------
      CHARACTER(80) :: BUFFER

      INTEGER :: CURRENT_GRID_POINT
      INTEGER :: LENGTH
      INTEGER :: INFO

      REAL :: ANGULAR_GRID_SPACING_SIZE

      COMPLEX, ALLOCATABLE, DIMENSION(:) :: EXTERNAL_POTENTIAL

!     Input Variable Assignment Read from Command-line Arguments:
!     -----------------------------------------------------------
      CALL GET_COMMAND_ARGUMENT(1,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) NUMBER_OF_GRID_POINTS

      CALL GET_COMMAND_ARGUMENT(2,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) EXTERNAL_POTENTIAL_SWITCH

      CALL GET_COMMAND_ARGUMENT(3,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) RADIUS

      CALL GET_COMMAND_ARGUMENT(4,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) GAUSSIAN_OSCILLATOR_STRENGTH

      CALL GET_COMMAND_ARGUMENT(5,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) INITIAL_ANGULAR_POSITION

!     Allocate Arrays:
!     ----------------
      ALLOCATE(EXTERNAL_POTENTIAL(NUMBER_OF_GRID_POINTS))

!     Internal Variable Assignment:
!     -----------------------------
      ANGULAR_GRID_SPACING_SIZE = 2.0E0*PI/FLOAT(NUMBER_OF_GRID_POINTS)

!     Main Program:
!     -------------
      IF (EXTERNAL_POTENTIAL_SWITCH.EQ.0) THEN
         EXTERNAL_POTENTIAL = CMPLX(0.0E0,0.0E0)
      ELSEIF (EXTERNAL_POTENTIAL_SWITCH.EQ.1) THEN
         DO CURRENT_GRID_POINT = 1, NUMBER_OF_GRID_POINTS
            EXTERNAL_POTENTIAL(CURRENT_GRID_POINT) = CMPLX(0.5E0*GAUSSIAN_OSCILLATOR_STRENGTH**2*RADIUS**2*(FLOAT(CURRENT_GRID_POINT-1)*ANGULAR_GRID_SPACING_SIZE-INITIAL_ANGULAR_POSITION)**2,0.0E0)
         ENDDO
      ENDIF

      OPEN(UNIT=999,ACTION='WRITE',FORM='UNFORMATTED')
      WRITE(UNIT=999) EXTERNAL_POTENTIAL
      CLOSE(UNIT=999)

!     Deallocate Arrays:
!     ------------------
      DEALLOCATE(EXTERNAL_POTENTIAL)

      STOP
      ENDPROGRAM POTENTIAL
! ======================================================================


module class_Circle
  implicit none
  private
  public :: Circle, circle_area, circle_print, circle_alloc_member

  real(8) :: pi = 3.1415926535897931d0 ! Class-wide private constant

  type Circle
     real(8) :: radius
     complex(8), dimension(:), allocatable :: alloc_array
  end type Circle
contains
  function circle_area(self) result(area)
    type(Circle), intent(in) :: self
    real(8) :: area
    area = pi * self%radius**2
  end function circle_area

  subroutine circle_print(self)
    type(Circle), intent(in) :: self
    real(8) :: area
    area = circle_area(self)  ! Call the circle_area function
    print *, 'Circle: r = ', self%radius, ' area = ', area
  end subroutine circle_print

  subroutine circle_alloc_member(self)
    type(Circle), intent(inout) :: self
    allocate(self%alloc_array(5))
    self%alloc_array = (1d0, 2d0)
  end subroutine

end module class_Circle

program circle_test
  use class_Circle
  implicit none

  type(Circle) :: c     ! Declare a variable of type Circle.
  c = Circle(1.5)       ! Use the implicit constructor, radius = 1.5.
  call circle_print(c)  ! Call a class subroutine
end program circle_test


c-------------------------------------------------------------------------------
c-------------------------------------------------------------------------------
c     SUBROUTINE REG_AR1.
c
c     Date:    27-MAR-2000.
c     Author:  B.D. Santer, PCMDI, Livermore.
c     Version: Single Precision.
c
c     Performs a simple linear regression with dependent variable y and
c     independent variable x. Various other statistical quantities are
c     also computed. Also computes lag-1 autocorrelation of residuals from
c     linear regression, and uses this to adjust effective temporal degrees
c     of freedom for confidence interval about estimated regression slope.
c
c     REFERENCE:
c
c     NAGFLIB:801/715:Mk5:Nov74.
c     Routine G02CAF.
c
c     EXTERNALS:
c
c     function BETAI   - Computes incomplete Beta function.
c     function BETACF  - Computes continued fraction for BETAI.
c     function GAMMLN  - Computes Gamma function
c     function PROBF1  - Computes probability for given F-value.
c     function PROBND1 - Computes area under a normal curve.
c     subroutine AUTO1 - Computes autocovariance and autocorrelation.
c
c
      subroutine reg_ar1(nmax, n1, lag, rneff, x, y,
     &result, res, cxx, rxx)
c
c
c
      implicit real (o-z, a-h)
c
c     ** INPUT **
c     integer nmax          Max. length of x and y
c     integer n1            Actual length of x and y
c     integer lag           Max. lag for autocorrelations
c     dimension x(nmax)     Independent variable
c     dimension y(nmax)     Dependent variable
c
c     ** OUTPUT **
c     real rneff               Effective sample size
c     dimension result(31)     Array of linear regression results
c     dimension res(nmax)      Residuals from linear regression
c     dimension cxx(0 : lag)   Autocovariance function
c     dimension rxx(0 : lag)   Autocorrelation function
c
      integer nmax, n1, lag
      real rneff
      dimension x(nmax), y(nmax), result(31), res(nmax)
      dimension cxx(0 : lag), rxx(0 : lag)
c
c
c
c-------------------------------------------------------------------------------
c
c
c
      eps1  = 1.0e-8
      bogus = -99.999
c
c
c
c-------------------------------------------------------------------------------
c     ** 1.0 **
c
c     Initialize sums.
c-------------------------------------------------------------------------------
c
c
c
      sumx  = 0.0
      sumy  = 0.0
      varx  = 0.0
      vary  = 0.0
      xy    = 0.0
      ssd   = 0.0
c
      do 10 i = 1, n1
        sumx  = sumx + x(i)
        sumy  = sumy + y(i)
   10 continue
c
c
c
c-------------------------------------------------------------------------------
c     ** 1.1 **
c
c     Compute means.
c-------------------------------------------------------------------------------
c
c
c
      dn   = float(n1)
      xbar = sumx / dn
      ybar = sumy / dn
c
c
c
c-------------------------------------------------------------------------------
c     ** 1.2 **
c
c     Compute standard deviations (sdx, sdy).
c-------------------------------------------------------------------------------
c
c
c
      do 12 i = 1, n1
       x1   = x(i) - xbar
       y1   = y(i) - ybar
       xy   = xy + (x1 * y1)
       varx = varx + (x1 * x1)
       vary = vary + (y1 * y1)
   12 continue
c
      if (varx .le. eps1) then
        print *, 'In REG_AR1. Small or zero variance detected in x!'
        print *, 'varx = ', varx
        do 121 kk = 1, 31
          result(kk) = bogus
  121   continue
        goto 1000
      else
        sdx  = sqrt(varx / (dn - 1.0))
      end if
c
      if (vary .eq. 0.0) then
        print *, 'In REG_AR1. Small or zero variance detected in y!'
        print *, 'vary = ', vary
        do 122 kk = 1, 31
          result(kk) = bogus
  122   continue
        goto 1000
      else
        sdy  = sqrt(vary / (dn - 1.0))
      end if
c
c
c
c-------------------------------------------------------------------------------
c     ** 1.3 **
c
c     Compute Pearson product-moment correlation coefficient (r).
c-------------------------------------------------------------------------------
c
c
c
      r = xy / sqrt(varx * vary)
c
c
c
c-------------------------------------------------------------------------------
c     ** 1.4 **
c
c     Compute regression coefficient (b) and regression constant (a).
c-------------------------------------------------------------------------------
c
c
c
      b    = xy / varx
      a    = ybar - b * xbar
c
c
c
c-------------------------------------------------------------------------------
c     ** 1.5 **
c
c     Compute:
c     ssr       Sum of squares attributable to the regression.
c     ssd       Sum of squares of deviations about the regression.
c     sst       Total sum of squares.
c     res       Residuals from regression.
c     rxx       Autocorrelation function.
c     rneff     Effective sample size.
c-------------------------------------------------------------------------------
c
c
c
      sst = vary
      do 15 i = 1, n1
        x2     = y(i) - a - b * x(i)
        ssd    = ssd + (x2 * x2)
        res(i) = x2
   15 continue
c
      ssr = sst - ssd
c
      call auto1(nmax, n1, lag, res, cxx, rxx)
c
      term1 = 1.0 - rxx(1)
      term2 = 1.0 + rxx(1)
      term3 = n1 * 1.0
      rneff = term3 * (term1 / term2)
c
c
c
c-------------------------------------------------------------------------------
c     ** 1.6 **
c
c     Compute:
c     idfr      D.O.F. attributable to the regression.
c     idfd1     D.O.F. of deviations about the regression (unadjusted).
c     rdfd2     D.O.F. of deviations about the regression (adjusted).
c     idft      Total degrees of freedom.
c-------------------------------------------------------------------------------
c
c
c
      idft  = n1 - 1
      idfd1 = n1 - 2
      rdfd2 = rneff - 2.0
      idfr  = 1
c
c
c
c-------------------------------------------------------------------------------
c     ** 1.7 **
c
c     Compute:
c     amsr      Mean square attributable to the regression.
c     amsd1     Mean square of deviations about the regression (unadjusted).
c     amsd2     Mean square of deviations about the regression (adjusted).
c-------------------------------------------------------------------------------
c
c
c
      amsr  = ssr / float(idfr)
      amsd1 = ssd / float(idfd1)
      amsd2 = ssd / rdfd2
c
c
c
c-------------------------------------------------------------------------------
c     ** 1.8 **
c
c     Compute the F-value for the analysis of variance (f). See also D.S.
c     Wilks (Statistical Methods in the Atmospheric Sciences, Academic
c     Press, 1995, pp. 166-168).
c-------------------------------------------------------------------------------
c
c
c
      f = amsr / amsd1
c
c
c
c-------------------------------------------------------------------------------
c     ** 1.9 **
c
c     Compute:
c     seb1      Standard error of regression coefficient b (unadjusted).
c     seb2      Standard error of regression coefficient b (adjusted).
c     sea1      Standard error of regression constant a (unadjusted).
c     sea2      Standard error of regression constant a (adjusted).
c-------------------------------------------------------------------------------
c
c
c
      seb1 = sqrt(amsd1 / varx)
      seb2 = sqrt(amsd2 / varx)
      s1   = (1.0 / dn) + ((xbar * xbar) / varx)
      sea1 = sqrt(amsd1 * s1)
      sea2 = sqrt(amsd2 * s1)
c
c
c
c-------------------------------------------------------------------------------
c     ** 1.10 **
c
c     Compute:
c     tb1       t-value for regression coefficient b (unadjusted).
c     tb2       t-value for regression coefficient b (adjusted).
c     ta1       t-value for regression constant a (unadjusted).
c     ta2       t-value for regression constant a (adjusted).
c-------------------------------------------------------------------------------
c
c
c
      tb1 = b / seb1
      tb2 = b / seb2
      ta1 = a / sea1
      ta2 = a / sea2
c
c
c
c-------------------------------------------------------------------------------
c     ** 1.11 **
c
c     Compute:
c     pt1       p-value for regression coefficient t-value. Effective sample
c               size adjustment for standard error (seb).
c     pt2       p-value for regression coefficient t-value. Effective sample
c               size adjustment for standard error (seb) and critical t-value.
c     pt3       p-value for regression coefficient t-value. No adjustment for
c               standard error or critical t-value.
c     pf1       p-value for regression coefficient F-value (one-tailed).
c     pf2       p-value for regression coefficient F-value (two-tailed).
c
c     The values pt1 and pt2 are use to test the null hypothesis that b = 0
c     (i.e., y is independent of x).
c
c     The values pf1 and pf2 are use to test the null hypothesis that the
c     regression is linear (goodness of linear fit). For non-replicated
c     values of y, the degrees of freedom are 1 and n - 2.
c-------------------------------------------------------------------------------
c
c
c
      ii1 = 1
      xx1 = n1 / (n1 + (tb2 * tb2))
      xx2 = rneff / (rneff + (tb2 * tb2))
      xx3 = n1 / (n1 + (tb1 * tb1))
      aa1 = n1 / 2.0
      aa2 = rneff / 2.0
      bb  = 1.0 / 2.0
c
      pt1 = betai(aa1, bb, xx1)
      pt2 = betai(aa2, bb, xx2)
      pt3 = betai(aa1, bb, xx3)
      pf1 = probf1(f, dum3, ii1, n1 - 2, 1)
      pf2 = probf1(f, dum4, ii1, n1 - 2, 2)
c
c
c
c-------------------------------------------------------------------------------
c     ** 1.12 **
c
c     Store results (result).
c-------------------------------------------------------------------------------
c
c
c
      result(1)  = xbar
      result(2)  = ybar
      result(3)  = sdx
      result(4)  = sdy
      result(5)  = r
      result(6)  = b
      result(7)  = a
      result(8)  = seb1
      result(9)  = seb2
      result(10) = sea1
      result(11) = sea2
      result(12) = tb1
      result(13) = tb2
      result(14) = ta1
      result(15) = ta2
      result(16) = ssr
      result(17) = idfr * 1.0
      result(18) = amsr
      result(19) = f
      result(20) = ssd
      result(21) = idfd1 * 1.0
      result(22) = rdfd2
      result(23) = amsd1
      result(24) = amsd2
      result(25) = sst
      result(26) = idft * 1.0
      result(27) = pt1
      result(28) = pt2
      result(29) = pt3
      result(30) = pf1
      result(31) = pf2
c
 1000 continue
      return
      end
c-------------------------------------------------------------------------------
c-------------------------------------------------------------------------------
      FUNCTION betai(a,b,x)
      REAL betai,a,b,x
CU    USES betacf,gammln
      REAL bt,betacf,gammln
      if(x.lt.0..or.x.gt.1.)pause 'bad argument x in betai'
      if(x.eq.0..or.x.eq.1.)then
        bt=0.
      else
        bt=exp(gammln(a+b)-gammln(a)-gammln(b)+a*log(x)+b*log(1.-x))
      endif
      if(x.lt.(a+1.)/(a+b+2.))then
        betai=bt*betacf(a,b,x)/a
        return
      else
        betai=1.-bt*betacf(b,a,1.-x)/b
        return
      endif
      END
c-------------------------------------------------------------------------------
c-------------------------------------------------------------------------------
      FUNCTION betacf(a,b,x)
      INTEGER MAXIT
      REAL betacf,a,b,x,EPS,FPMIN
      PARAMETER (MAXIT=100,EPS=3.e-7,FPMIN=1.e-30)
      INTEGER m,m2
      REAL aa,c,d,del,h,qab,qam,qap
      qab=a+b
      qap=a+1.
      qam=a-1.
      c=1.
      d=1.-qab*x/qap
      if(abs(d).lt.FPMIN)d=FPMIN
      d=1./d
      h=d
      do 11 m=1,MAXIT
        m2=2*m
        aa=m*(b-m)*x/((qam+m2)*(a+m2))
        d=1.+aa*d
        if(abs(d).lt.FPMIN)d=FPMIN
        c=1.+aa/c
        if(abs(c).lt.FPMIN)c=FPMIN
        d=1./d
        h=h*d*c
        aa=-(a+m)*(qab+m)*x/((a+m2)*(qap+m2))
        d=1.+aa*d
        if(abs(d).lt.FPMIN)d=FPMIN
        c=1.+aa/c
        if(abs(c).lt.FPMIN)c=FPMIN
        d=1./d
        del=d*c
        h=h*del
        if(abs(del-1.).lt.EPS)goto 1
11    continue
      pause 'a or b too big, or MAXIT too small in betacf'
1     betacf=h
      return
      END
c-------------------------------------------------------------------------------
c-------------------------------------------------------------------------------
      FUNCTION gammln(xx)
      REAL gammln,xx
      INTEGER j
      DOUBLE PRECISION ser,stp,tmp,x,y,cof(6)
      SAVE cof,stp
      DATA cof,stp/76.18009172947146d0,-86.50532032941677d0,
     *24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2,
     *-.5395239384953d-5,2.5066282746310005d0/
      x=xx
      y=x
      tmp=x+5.5d0
      tmp=(x+0.5d0)*log(tmp)-tmp
      ser=1.000000000190015d0
      do 11 j=1,6
        y=y+1.d0
        ser=ser+cof(j)/y
11    continue
      gammln=tmp+log(stp*ser/x)
      return
      END
c-------------------------------------------------------------------------------
c-------------------------------------------------------------------------------
c     FUNCTION PROBF1.
c
c     Date:    6-MAR-1992.
c     Author:  B.D. Santer, MPI, Hamburg.
c     Version: Single Precision.
c
c     The output is either the one- or two-tailed test area: i.e., the
c     area under an F-curve (with N1 and N2 degrees of freedom) to the
c     right of X if X exceeds 1.0 (one-tailed test) or twice this area
c     (two-tailed test).
c
c     Note: if X is less than 1.0, this function gives the area to the
c     right of 1/X with reversed order for the degrees of freedom. This
c     ensures the accuracy of the numerical algorithm.
c
c     REFERENCE:
c
c     M. Abramowitz and I.A. Stegun.
c     Handbook of Mathematical Functions.
c     Dover, 1970, page 947 (26.6.15).
c
c     EXTERNALS:
c
c     function PROBND1 - Calculates the area under a normal curve.
c
c
c
      function probf1(y, x, n1, n2, id)
c
c
c
      implicit real (o-z, a-h)
c
c     ** INPUT **
c     real y            Calculated F-value (unchanged on output)
c     real x            Inverse of Y if Y is less than 1.0
c     integer n1, n2    Degrees of freedom
c     integer id        Identifier for one- or two-tailed test
c
c     ** OUTPUT **
c     real probf1       Significance level (p-value) for F-value
c
c
c
      integer n1, n2, id
      real y, x, probf1
c
c
c
c-------------------------------------------------------------------------------
c
c
c
      x = y
      if (x .gt. 1.0) goto 1
      x  = 1.0 / x
      n  = n1
      n1 = n2
      n2 = n
c
    1 continue
      dn1 = float(n1)
      dn2 = float(n2)
      term1 = 2.0 / (9.0 * dn1)
      term2 = 2.0 / (9.0 * dn2)
      term3 = ((x ** (1.0 / 3.0)) * (1.0 - term2)) - (1.0 - term1)
      term4 = sqrt(term1 + ((x ** (2.0 / 3.0)) * term2))
      term5 = term3 / term4
      if (id .eq. 2) probf1 = 2.0 * probnd1(term5)
c
c
c
c-------------------------------------------------------------------------------
c     The numerical algorithm can have problems when the F-value is
c     close to 1.0 and the degrees of freedom are small. Therefore,
c     insure that the probabilities returned cannot exceed 1.0.
c-------------------------------------------------------------------------------
c
c
c
      if (id .eq. 1) probf1 = probnd1(term5)
      if (probf1 .gt. 1.0) probf1 = 1.0
      return
      end
c-------------------------------------------------------------------------------
c-------------------------------------------------------------------------------
c     FUNCTION PROBND1.
c
c     Date:    6-MAR-1992.
c     Author:  B.D. Santer, MPI, Hamburg.
c     Version: Single Precision.
c
c     Calculates the area under a normal curve (mean=0.0, variance=1.0)
c     to the right of x. The accuracy is better than 7.5 * 10.**-8.
c
c     REFERENCE:
c
c     M. Abramowitz and I.A. Stegun.
c     Handbook of Mathematical Functions.
c     Dover, 1970, pages 931-932 (26.2.1 and 26.2.17).
c
c
c
      function probnd1(x)
c
c
c
      implicit real (o-z, a-h)
c
c     ** INPUT **
c     real x         Input z score
c
c     ** OUTPUT **
c     real probnd1   Area under normal curve to right of x
c
c
c
      real x, probnd1
c
c
c
c-------------------------------------------------------------------------------
c
c
c
      b1 =  0.319381530
      b2 = -0.356563782
      b3 =  1.781477937
      b4 = -1.821255978
      b5 =  1.330274429
      p  =  0.2316419
      pi =  4.0 * atan(1.0)
c
      t = 1.0 / (1.0 + (p * x))
      term1 = ((((b1 * t) + (b2 * (t ** 2))) + (b3 * (t ** 3))) + (b4 *
     &(t ** 4))) + (b5 * (t ** 5))
c
c
c
c-------------------------------------------------------------------------------
c     If x is large, set probnd1 to zero to avoid error in computing
c     z (underflow).
c-------------------------------------------------------------------------------
c
c
c
      probnd1 = 0.0
      if (x .gt. 7.0) goto 1
      z = (1.0 / sqrt(2.0 * pi)) * exp(- ((x * x) / 2.0))
      probnd1 = z * term1
    1 continue
      return
      end
c-------------------------------------------------------------------------------
c-------------------------------------------------------------------------------
c     SUBROUTINE AUTO1.
c
c     Date:    27-OCT-1994.
c     Author:  B.D. Santer, LLNL, Livermore.
c     Version: Single precision.
c
c     Computes autocovariance (cxx) and autocorrelation (rxx) functions
c     of an input data series x(t). User specifies the number of lags
c     computed.
c
c     REFERENCE:
c
c     G.M. Jenkins and D.G. Watts.
c     Spectral Analysis and its Applications.
c     Holden-Day, 1968, pages 180-182, (5.3.25) and (5.3.33).
c
c
c
      subroutine auto1(n, n1, lag, x, cxx, rxx)
c
c
c
      implicit real (o-z, a-h)
c
c     ** INPUT **
c     integer n           Maximum dimension of x
c     integer n1          Actual dimension of x
c     integer lag         Number of lags computed
c     dimension x(n)      Input data series
c
c     ** OUTPUT **
c     dimension cxx(0 : lag)    Autocovariance function
c     dimension rxx(0 : lag)    Autocovariance function
c
      integer n, n1
      dimension x(n), cxx(0 : lag), rxx(0 : lag)
c
c
c
c-------------------------------------------------------------------------------
c
c
c
c-------------------------------------------------------------------------------
c     ** 1.0 **
c
c     Compute sample mean of x.
c-------------------------------------------------------------------------------
c
c
c
      sum1 = 0.0
      sum2 = 0.0
c
      do 100 it = 1, n1
        sum1 = sum1 + x(it)
  100 continue
      xbar = sum1 / float(n1)
c
c
c
c-------------------------------------------------------------------------------
c     ** 1.1 **
c
c     Compute total variance of x.
c-------------------------------------------------------------------------------
c
c
c
      do 110 it = 1, n1
        sum2 = sum2 + ((x(it) - xbar) ** 2)
  110 continue
      c0 = sum2 / float(n1)
c
c
c
c-------------------------------------------------------------------------------
c     ** 1.2 **
c
c     Compute autocovariance and autocorrelation for each lag (0 to lag).
c-------------------------------------------------------------------------------
c
c
c
      do 121 k = 0, lag
        sum3 = 0.0
        n2   = n1 - k
        do 120 it = 1, n2
          sum3 = sum3 + ((x(it) - xbar) * (x(it + k) - xbar))
  120   continue
c
        cxx(k) = sum3 / float(n1)
        if (c0 .eq. 0.0) then
          print *, 'AUTO1. zero variance for c0! '
          rxx(k) = 1.0
        else
          rxx(k) = cxx(k) / c0
        end if
c
c       if (k .eq. 0) write(*, 990)
c       write(*,991) k, cxx(k), rxx(k)
  121 continue
c
  990 format(t2, 'Lag', t10, 'Autocovariance', t30,
     &'Autocorrelation' )
  991 format(i3, t10, f12.5, t30, f12.5)
c
      return
      end


!===============================================================================
!> Define code units, in terms of (here) CGS units
!===============================================================================
MODULE scaling_mod
  USE units_mod
  USE io_mod
  USE trace_mod
  USE math_mod
  implicit none
  private
  !-----------------------------------------------------------------------------
  ! Extend the units_t data type, which contains only the three fundamental
  ! units: length, mass, and time (cf. CGS and MKS)
  !-----------------------------------------------------------------------------
  type, public, extends(units_t):: scaling_t
    real(kind=8):: d, e, ee, p, u, temp, grav, mu, kr, b
  contains
    procedure:: init
  end type
  type(scaling_t), public:: scaling
CONTAINS
!===============================================================================
!> Initialize code units:
!===============================================================================
SUBROUTINE init (self)
  class(scaling_t):: self
  logical, save:: first_time=.true.
  !-----------------------------------------------------------------------------
  if (.not.first_time) return
  call trace%begin ('scaling_t%init')
  if (io%master) print *, &
 '-------------------------------- scaling_mod -------------------------'
  first_time = .false.
  call cgs%init
  !--------------------------- defining quantities ---------------------
  self%system = 'cgs'                                                   ! pass on to Python
  self%l  = 1d0                                                         ! length = 1Mm = 1e8 cm
  self%d  = 1d0                                                        ! photospheric density
  self%t  = 1d0                                                         ! time = 100 sec
  !--------------------------- derived quantities ----------------------
  self%u  = self%l/self%t                                               ! speed
  self%m  = self%d*self%l**3                                            ! mass
  self%p  = self%d*self%u**2                                            ! pressure = energy density [dyne / cm2]
  self%kr = 1.0/(self%d*self%l)                                         ! rosseland opacity [cm2/g]
  self%ee = self%u**2                                                   ! specific energy
  self%e  = self%m*self%u**2                                            ! energy
  self%b  = self%l**(-0.5)*self%m**0.5*self%t**(-1)                   ! magnetic flux density
  self%mu = 2.4
  self%temp = self%mu*(cgs%m_u/self%m)/(cgs%k_b/self%e)                 ! temperature for given mu
  self%grav = cgs%grav*(self%m/self%l**3)*self%t**2     ! constant of gravity
  if (io%master) then
    print 1,' CODE UNITS:   (cgs):'
    print 1,'               length: ',self%l
    print 1,'                 mass: ',self%m
    print 1,'                 time: ',self%t
    print 1,'             velocity: ',self%u
    print 1,'              density: ',self%d
    print 1,'             pressure: ',self%p
    print 1,'magnetic flux density: ',self%b
    print 1,'               energy: ',self%e
    print 1,'              gravity: ',self%grav
    print 1,'          temperature: ',self%temp
  1 format(1x,a,1p,e11.3)
  end if
  call self%output
  call trace%end()
END SUBROUTINE init
END MODULE scaling_mod


subroutine implicit_vertical_diffusion(km, jm,          &
     dt, dp, g, Pr, eta, p, theta, U, V, q, srf_q_flx, srf_T_flx, srf_u_flx, srf_v_flx,  &
     Tinc, Uinc, Vinc, qinc)

implicit none

! In
integer, intent(in)                  :: km, jm
real, intent(in)                     :: dt, dp, g, Pr
real,             dimension(jm,km-1) :: eta
real, intent(in), dimension(jm,km)   :: p, theta, U, V, q
real, intent(in), dimension(jm)      :: srf_q_flx, srf_T_flx, srf_u_flx, srf_v_flx

! Out
real, intent(out), dimension(jm,km) :: Tinc, Uinc, Vinc, qinc

! Local
integer             :: j
real                :: gamma
real, dimension(km) :: sup,sub,dia,rhs,ans

integer :: k
real                :: smooth
real, dimension(jm) :: ysup,ysub,ydia,yrhs,yans

! Initialise
sup=0.
sub=0.
dia=0.
gamma = 2.*dt/dp/dp*g

! Momentum
do j=1,jm
   sup(2:km)   = -gamma*eta(j,:)
   sub(1:km-1) = -gamma*eta(j,:)
   dia(2:km-1) = 1. + gamma*(eta(j,1:km-2)+eta(j,2:km-1))
   dia(1)      = 1. + gamma*eta(j,1)     ! no flux through top
   dia(km)     = 1. + gamma*eta(j,km-1)
   ! -- U
   rhs = U(j,:)
   rhs(km) = U(j,km) + srf_u_flx(j)*gamma*dp
   call trid(sup,dia,sub,rhs,ans,km)
   Uinc(j,:) = ans - U(j,:)
   ! -- V
   rhs = V(j,:)
   rhs(km) = V(j,km) + srf_v_flx(j)*gamma*dp
   call trid(sup,dia,sub,rhs,ans,km)
   Vinc(j,:) = ans - V(j,:)
enddo

! Heat
eta = eta/Pr
do j=1,jm
   sup(2:km)   = -gamma*eta(j,:)
   sub(1:km-1) = -gamma*eta(j,:)
   dia(2:km-1) = 1. + gamma*(eta(j,1:km-2)+eta(j,2:km-1))
   dia(1)      = 1. + gamma*eta(j,1)     ! no flux through top
   dia(km)     = 1. + gamma*eta(j,km-1)
   ! -- theta
   rhs=theta(j,:)
   rhs(km) = theta(j,km) + srf_T_flx(j)*gamma*dp
   call trid(sup,dia,sub,rhs,ans,km)
   Tinc(j,:) = ans - theta(j,:)
enddo

! Moisture
eta = eta/Pr
do j=1,jm
   sup(2:km)   = -gamma*eta(j,:)
   sub(1:km-1) = -gamma*eta(j,:)
   dia(2:km-1) = 1. + gamma*(eta(j,1:km-2)+eta(j,2:km-1))
   dia(1)      = 1. + gamma*eta(j,1)     ! no flux through top
   dia(km)     = 1. + gamma*eta(j,km-1)
   ! -- q
   rhs=q(j,:)
   rhs(km) = q(j,km) + srf_q_flx(j)*gamma*dp
   call trid(sup,dia,sub,rhs,ans,km)
   qinc(j,:) = ans - q(j,:)
enddo

! -- Jonathan's strong horizontal diffusion --
!+++rca ! Apply second-derivative smoother to damp 2*deltaY mode
!+++rca ! Smoothing coefficient, units of s-1
!+++rca smooth = 0.25
!+++rca ysup = -smooth
!+++rca ydia = 1.+2.*smooth
!+++rca ysub = -smooth
!+++rca do k=1,km
!+++rca    ! Zero flux at the boundaries
!+++rca    ydia(1) = 1.+3.*smooth
!+++rca    ydia(jm) = 1.+3.*smooth
!+++rca    yrhs = V(:,k)
!+++rca    call trid(ysup,ydia,ysub,yrhs,yans,jm)
!+++rca    Vinc(:,k) = Vinc(:,k) + (yans - V(:,k))
!+++rca enddo

end subroutine implicit_vertical_diffusion
!------------------------------------------------------------------------------
subroutine implicit_horizontal_diffusion(km, jm, dt, dphi, r, nuv, cosphi, tanphi, U, Uinc)

implicit none

! In
integer, intent(in)                  :: km, jm
real, intent(in)                     :: dt, dphi, nuv, r
real, intent(in), dimension(jm)      :: cosphi, tanphi
real, intent(in), dimension(jm,km)   :: U

! Out
real, intent(out), dimension(jm,km) :: Uinc

! Local
integer             :: j,k
real                :: gamma
real, dimension(jm) :: sup,sub,dia,rhs,ans

! Initialise
sup=0.
sub=0.
dia=0.
gamma = 2.*dt/r/r*nuv

! Momentum
do k=1,km
   sup  =  gamma*tanphi/2./dphi - gamma/dphi/dphi
   sub  = -gamma*tanphi/2./dphi - gamma/dphi/dphi
   dia  = 1. + gamma/cosphi/cosphi + 2.*gamma/dphi/dphi
   rhs  = U(:,k)
   call trid(sup,dia,sub,rhs,ans,jm)
   Uinc(:,k) = ans - U(:,k)
enddo

end subroutine implicit_horizontal_diffusion
!------------------------------------------------------------------------------
subroutine trid(a,b,c,r,u,n)

real, dimension(n) :: a,b,c,r,u,gam

bet=b(1)
u(1)=r(1)/bet

do j=2,n
  gam(j)=c(j-1)/bet
   bet=b(j)-a(j)*gam(j)
   u(j)=(r(j)-a(j)*u(j-1))/bet
enddo

do j=n-1,1,-1
u(j)=u(j)-gam(j+1)*u(j+1)
enddo

end subroutine trid


c
c
c     ################################################################
c     ##  COPYRIGHT (C) 2006 by Chuanjie Wu and Jay William Ponder  ##
c     ##                    All Rights Reserved                     ##
c     ################################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##   subroutine nspline  --  nonperiodic natural cubic spline   ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "nspline" computes coefficients for an nonperiodic cubic spline
c     with natural boundary conditions where the first and last second
c     derivatives are already known
c
c
      subroutine nspline (n,x0,y0,s1,s2,h,g,dy,dla,dmu)
      implicit none
      integer i,n
      real*8 t,y21,y2n
      real*8 x0(0:*)
      real*8 y0(0:*)
      real*8 s1(0:*)
      real*8 s2(0:*)
      real*8 h(0:*)
      real*8 g(0:*)
      real*8 dy(0:*)
      real*8 dla(0:*)
      real*8 dmu(0:*)
c
c
c     set first and last second deriviatives to zero
c
      y21 = 0.0d0
      y2n = 0.0d0
c
c     find the intervals to be used
c
      do i = 0, n-1
         h(i) = x0(i+1) - x0(i)
         dy(i) = (y0(i+1)-y0(i)) / h(i)
      end do
c
c     calculate the spline coeffcients
c
      do i = 1, n-1
         dla(i) = h(i) / (h(i)+h(i-1))
         dmu(i) = 1.0d0 - dla(i)
         g(i) = 3.0d0 * (dla(i)*dy(i-1)+dmu(i)*dy(i))
      end do
c
c     set the initial value via natural boundary condition
c
      dla(n) = 1.0d0
      dla(0) = 0.0d0
      dmu(n) = 0.0d0
      dmu(0) = 1.0d0
      g(0) = 3.0d0*dy(0) - 0.5d0*h(0)*y21
      g(n) = 3.0d0*dy(n-1) + 0.5d0*h(n-1)*y2n
c
c     solve the triagonal system of linear equations
c
      dmu(0) = 0.5d0 * dmu(0)
      g(0) = 0.5d0 * g(0)
      do i = 1, n
         t = 2.0d0 - dmu(i-1)*dla(i)
         dmu(i) = dmu(i) / t
         g(i) = (g(i)-g(i-1)*dla(i)) / t
      end do
      do i = n-1, 0, -1
         g(i) = g(i) - dmu(i)*g(i+1)
      end do
c
c     get the first derivative at each grid point
c
      do i = 0, n
         s1(i) = g(i)
      end do
c
c     get the second derivative at each grid point
c
      s2(0) = y21
      s2(n) = y2n
      do i = 1, n-1
         s2(i) = 6.0d0*(y0(i+1)-y0(i))/(h(i)*h(i))
     &              - 4.0d0*s1(i)/h(i) - 2.0d0*s1(i+1)/h(i)
      end do
      return
      end


      subroutine slant(p,zstat,zzero,vzero,time,dist)
c---------------------------------------------------------------------
c     slant calculates simple slant path travel time and distance
c  corrections for stations with nonzero elevations.
c
c  arguments-(input)
c
c     p-ray parameter
c     zstat-station depth (note positive station elevations are
c           negative depths so zstat is almost always negative
c     zzero-depth to correct travel time and distance to
c     vzero-stripping velocity for upper layer (assumed constant)
c
c  arguments-(output)
c
c     time-travel time correction
c     dist-distance correction
c
c---------------------------------------------------------------------
      if(zzero.eq.zstat) then
            time = 0.0
            dist = 0.0
      else
            dz = zzero - zstat
            rad = sqrt(1. - (p*vzero)**2)
            time = dz/(vzero*rad)
            dist = p*vzero*dz/rad
      endif
      return
      end

c $Id$


! This Software is property of University College London. The Licensee shall reproduce a copyright notice on every
! copy of the Software (including partial copies) and on any accompanying manuals and documentation in the form
! "Copyright (c) University College London, All rights reserved". Trademark and other proprietary notices must also
! be reproduced but the Licensee has no other right to use the name, arms, trademark, logo or other designation
! of University College London.

module constants_module

implicit none

! every how many seconds a restart file will be written
integer, parameter :: dtwrestart = 3600

! for repetitive warnings: the maximum number of message that will be issued for each such warning
integer, parameter :: maxrepwarnings = 10

! *** Mathematical constants

! pi value
real(8), parameter :: pi = 3.141592653589793d0
! e value
real(8), parameter :: e = 2.718281828459046d0

! *** Physical constants (in SI or SI-derived units)

! ~ Speed of light
real(8), parameter :: clight = 2.99792458d+08 ! m/s

! ~ Avogadro's number
real(8), parameter :: navog = 6.02214179d+23 ! 1/mol

! ~ Gas constant
real(8), parameter :: rgas = 8.314472d+00   ! J/K/mol

! ~ Plank's constant
real(8), parameter :: hplank = 6.62606896d-34 ! J*s

! ~ Boltzmann's constant
real(8), parameter :: kboltz = rgas/navog ! J/K

! *** Conversion factors

! ~ Energy: 1 J = engconv User_units
!real(8), parameter :: enrgconv = 1.d0 ! J
!real(8), parameter :: enrgconv = 1.d-3*navog ! kJ/mol
real(8), parameter :: enrgconv = 6.24150974d+18 ! eV
!real(8), parameter :: enrgconv = 1.d+07 ! erg
!real(8), parameter :: enrgconv = 2.3901d-4 ! kcal
!real(8), parameter :: enrgconv = 2.3901d-4*navog ! kcal/mol
!real(8), parameter :: enrgconv = 2.3901d-1 ! cal

! ~ Distanse: 1 m = engconv User_units
!real(8), parameter :: distconv = 1.d0 ! m
!real(8), parameter :: distconv = 1.d+02 ! cm
real(8), parameter :: distconv = 1.d+10 ! Angstrom

! ~ Time: 1 s = engconv User_units
real(8), parameter :: timeconv = 1.d0 ! s
!real(8), parameter :: timeconv = 2.7777777777777778d-4 ! h
!real(8), parameter :: timeconv = 1.6666666666666667d-2 ! min
!real(8), parameter :: timeconv = 1.d+09 ! ns
!real(8), parameter :: timeconv = 1.d+12 ! ps

! ~ Mass:
real(8), parameter :: massconv = 1.d+0 ! kg

! ~ Pressure:
!real(8), parameter :: presconv = 1.d+0 ! Pa
real(8), parameter :: presconv = 1.d-5 ! bar
!real(8), parameter :: presconv = 9.8692d-06 ! atm

! *** KMC code parameters

real(8), parameter :: angletol = 1e-3

! commenting character
character(1), parameter :: remchar = '#'

! double the maximum number of words separated by a delimiter that can be read
integer, parameter :: maxwords2 = 6000

! record length (in number of characters) that can be read
integer, parameter :: lengthrecinp = 8192

! allowed length (in characters) of the species', site-types' and mechanism-steps' names
integer, parameter :: nnam0 = 64

! *** File names and unit numbers

! simulation input file
character(30), parameter :: csimfname = 'simulation_input.dat'
integer, parameter :: iread = 101

! lattice specification input file name and unit number
character(30), parameter :: clatfname = 'lattice_input.dat'
integer, parameter :: ilatread = 102

! mechanism specification input file name and unit number
character(30), parameter :: cmechfname = 'mechanism_input.dat'
integer, parameter :: imechread = 103

! energetics specification input file name and unit number
character(30), parameter :: cenergfname = 'energetics_input.dat'
integer, parameter :: ienergread = 103

! initial state specification input file name and unit number
character(30), parameter :: cstatefname = 'state_input.dat'
integer, parameter :: istateread = 104

! restart file
character(30), parameter :: crestartfname = 'restart.inf'
integer, parameter :: irestart = 201

! general output file
character(30), parameter :: cgenoutfname = 'general_output.txt'
integer, parameter :: iwrite = 202

! lattice specification output file
character(30), parameter :: clatoutfname = 'lattice_output.txt'
integer, parameter :: ilatwrite = 203

! lattice state snapshots (history) output file
character(30), parameter :: chistoryfname = 'history_output.txt'
integer, parameter :: ihistory = 204

! process statistics output file
character(30), parameter :: cprocstatfname = 'procstat_output.txt'
integer, parameter :: iprocstat = 205

! species numbers (transiently) output file
character(30), parameter :: cspecnumfname = 'specnum_output.txt'
integer, parameter :: ispecnum = 206

! output file for computing sensitivity coefficients
character(30), parameter :: SAfname = 'trajderiv_output.txt'
integer, parameter :: SAfnum = 207

! output file for reaction propensities
character(30), parameter :: Propfname = 'propensities_output.txt'
integer, parameter :: Propfnum = 209

! Running counter of reaction propensity * dt
character(30), parameter :: PropCountfname = 'timeintprop_output.txt'
integer, parameter :: PropCountfnum = 210

! Running counter of species count * dt
character(30), parameter :: IntegSpecfname = 'timeintspecs_output.txt'
integer, parameter :: IntegSpecfnum = 215

! process debug data output file
character(30), parameter :: cprocdbgfname = 'process_debug.txt'
integer, parameter :: iprocdbg = 301

! global energetics debug data output file
character(30), parameter :: cglbenerdbgfname = 'globalenerg_debug.txt'
integer, parameter :: iglbenergdbg = 302

! Newton's method debug data output file
character(30), parameter :: cnewtndbgfname = 'newton_debug.txt'
integer, parameter :: inewtndbg = 303

! process propensities debug data output file
character(30), parameter :: cprocpropensdbgfname = 'propens_debug.txt'
integer, parameter :: iprocpropensdbg = 304

! process propensities initial catalogue debug data output file
character(30), parameter :: cprocinicatpropensdbgfname = 'propens_inicatalogue.txt'
integer, parameter :: iprocinicatpropensdbg = 305

! cluster contributions debug data output file
character(30), parameter :: cclusterdbgfname = 'cluster_debug.txt'
integer, parameter :: iclusterdbg = 306

! cluster contributions initial catalogue debug data output file
character(30), parameter :: cclusterinidbgfname = 'cluster_inicatalogue.txt'
integer, parameter :: iclusterinidbg = 307

! process propensities debug data state-input generated file
character(30), parameter :: cprocpropensstatedbgfname = 'state_input_inikmc_debug.txt'
integer, parameter :: iprocpropensstatedbg = 308

end module constants_module