*> \brief \b ZDRVSX
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE ZDRVSX( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
*                          NIUNIT, NOUNIT, A, LDA, H, HT, W, WT, WTMP, VS,
*                          LDVS, VS1, RESULT, WORK, LWORK, RWORK, BWORK,
*                          INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            INFO, LDA, LDVS, LWORK, NIUNIT, NOUNIT, NSIZES,
*      $                   NTYPES
*       DOUBLE PRECISION   THRESH
*       ..
*       .. Array Arguments ..
*       LOGICAL            BWORK( * ), DOTYPE( * )
*       INTEGER            ISEED( 4 ), NN( * )
*       DOUBLE PRECISION   RESULT( 17 ), RWORK( * )
*       COMPLEX*16         A( LDA, * ), H( LDA, * ), HT( LDA, * ),
*      $                   VS( LDVS, * ), VS1( LDVS, * ), W( * ),
*      $                   WORK( * ), WT( * ), WTMP( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*>    ZDRVSX checks the nonsymmetric eigenvalue (Schur form) problem
*>    expert driver ZGEESX.
*>
*>    ZDRVSX uses both test matrices generated randomly depending on
*>    data supplied in the calling sequence, as well as on data
*>    read from an input file and including precomputed condition
*>    numbers to which it compares the ones it computes.
*>
*>    When ZDRVSX is called, a number of matrix "sizes" ("n's") and a
*>    number of matrix "types" are specified.  For each size ("n")
*>    and each type of matrix, one matrix will be generated and used
*>    to test the nonsymmetric eigenroutines.  For each matrix, 15
*>    tests will be performed:
*>
*>    (1)     0 if T is in Schur form, 1/ulp otherwise
*>           (no sorting of eigenvalues)
*>
*>    (2)     | A - VS T VS' | / ( n |A| ulp )
*>
*>      Here VS is the matrix of Schur eigenvectors, and T is in Schur
*>      form  (no sorting of eigenvalues).
*>
*>    (3)     | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues).
*>
*>    (4)     0     if W are eigenvalues of T
*>            1/ulp otherwise
*>            (no sorting of eigenvalues)
*>
*>    (5)     0     if T(with VS) = T(without VS),
*>            1/ulp otherwise
*>            (no sorting of eigenvalues)
*>
*>    (6)     0     if eigenvalues(with VS) = eigenvalues(without VS),
*>            1/ulp otherwise
*>            (no sorting of eigenvalues)
*>
*>    (7)     0 if T is in Schur form, 1/ulp otherwise
*>            (with sorting of eigenvalues)
*>
*>    (8)     | A - VS T VS' | / ( n |A| ulp )
*>
*>      Here VS is the matrix of Schur eigenvectors, and T is in Schur
*>      form  (with sorting of eigenvalues).
*>
*>    (9)     | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues).
*>
*>    (10)    0     if W are eigenvalues of T
*>            1/ulp otherwise
*>            If workspace sufficient, also compare W with and
*>            without reciprocal condition numbers
*>            (with sorting of eigenvalues)
*>
*>    (11)    0     if T(with VS) = T(without VS),
*>            1/ulp otherwise
*>            If workspace sufficient, also compare T with and without
*>            reciprocal condition numbers
*>            (with sorting of eigenvalues)
*>
*>    (12)    0     if eigenvalues(with VS) = eigenvalues(without VS),
*>            1/ulp otherwise
*>            If workspace sufficient, also compare VS with and without
*>            reciprocal condition numbers
*>            (with sorting of eigenvalues)
*>
*>    (13)    if sorting worked and SDIM is the number of
*>            eigenvalues which were SELECTed
*>            If workspace sufficient, also compare SDIM with and
*>            without reciprocal condition numbers
*>
*>    (14)    if RCONDE the same no matter if VS and/or RCONDV computed
*>
*>    (15)    if RCONDV the same no matter if VS and/or RCONDE computed
*>
*>    The "sizes" are specified by an array NN(1:NSIZES); the value of
*>    each element NN(j) specifies one size.
*>    The "types" are specified by a logical array DOTYPE( 1:NTYPES );
*>    if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
*>    Currently, the list of possible types is:
*>
*>    (1)  The zero matrix.
*>    (2)  The identity matrix.
*>    (3)  A (transposed) Jordan block, with 1's on the diagonal.
*>
*>    (4)  A diagonal matrix with evenly spaced entries
*>         1, ..., ULP  and random complex angles.
*>         (ULP = (first number larger than 1) - 1 )
*>    (5)  A diagonal matrix with geometrically spaced entries
*>         1, ..., ULP  and random complex angles.
*>    (6)  A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
*>         and random complex angles.
*>
*>    (7)  Same as (4), but multiplied by a constant near
*>         the overflow threshold
*>    (8)  Same as (4), but multiplied by a constant near
*>         the underflow threshold
*>
*>    (9)  A matrix of the form  U' T U, where U is unitary and
*>         T has evenly spaced entries 1, ..., ULP with random
*>         complex angles on the diagonal and random O(1) entries in
*>         the upper triangle.
*>
*>    (10) A matrix of the form  U' T U, where U is unitary and
*>         T has geometrically spaced entries 1, ..., ULP with random
*>         complex angles on the diagonal and random O(1) entries in
*>         the upper triangle.
*>
*>    (11) A matrix of the form  U' T U, where U is orthogonal and
*>         T has "clustered" entries 1, ULP,..., ULP with random
*>         complex angles on the diagonal and random O(1) entries in
*>         the upper triangle.
*>
*>    (12) A matrix of the form  U' T U, where U is unitary and
*>         T has complex eigenvalues randomly chosen from
*>         ULP < |z| < 1   and random O(1) entries in the upper
*>         triangle.
*>
*>    (13) A matrix of the form  X' T X, where X has condition
*>         SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP
*>         with random complex angles on the diagonal and random O(1)
*>         entries in the upper triangle.
*>
*>    (14) A matrix of the form  X' T X, where X has condition
*>         SQRT( ULP ) and T has geometrically spaced entries
*>         1, ..., ULP with random complex angles on the diagonal
*>         and random O(1) entries in the upper triangle.
*>
*>    (15) A matrix of the form  X' T X, where X has condition
*>         SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP
*>         with random complex angles on the diagonal and random O(1)
*>         entries in the upper triangle.
*>
*>    (16) A matrix of the form  X' T X, where X has condition
*>         SQRT( ULP ) and T has complex eigenvalues randomly chosen
*>         from ULP < |z| < 1 and random O(1) entries in the upper
*>         triangle.
*>
*>    (17) Same as (16), but multiplied by a constant
*>         near the overflow threshold
*>    (18) Same as (16), but multiplied by a constant
*>         near the underflow threshold
*>
*>    (19) Nonsymmetric matrix with random entries chosen from (-1,1).
*>         If N is at least 4, all entries in first two rows and last
*>         row, and first column and last two columns are zero.
*>    (20) Same as (19), but multiplied by a constant
*>         near the overflow threshold
*>    (21) Same as (19), but multiplied by a constant
*>         near the underflow threshold
*>
*>    In addition, an input file will be read from logical unit number
*>    NIUNIT. The file contains matrices along with precomputed
*>    eigenvalues and reciprocal condition numbers for the eigenvalue
*>    average and right invariant subspace. For these matrices, in
*>    addition to tests (1) to (15) we will compute the following two
*>    tests:
*>
*>   (16)  |RCONDE - RCDEIN| / cond(RCONDE)
*>
*>      RCONDE is the reciprocal average eigenvalue condition number
*>      computed by ZGEESX and RCDEIN (the precomputed true value)
*>      is supplied as input.  cond(RCONDE) is the condition number
*>      of RCONDE, and takes errors in computing RCONDE into account,
*>      so that the resulting quantity should be O(ULP). cond(RCONDE)
*>      is essentially given by norm(A)/RCONDV.
*>
*>   (17)  |RCONDV - RCDVIN| / cond(RCONDV)
*>
*>      RCONDV is the reciprocal right invariant subspace condition
*>      number computed by ZGEESX and RCDVIN (the precomputed true
*>      value) is supplied as input. cond(RCONDV) is the condition
*>      number of RCONDV, and takes errors in computing RCONDV into
*>      account, so that the resulting quantity should be O(ULP).
*>      cond(RCONDV) is essentially given by norm(A)/RCONDE.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] NSIZES
*> \verbatim
*>          NSIZES is INTEGER
*>          The number of sizes of matrices to use.  NSIZES must be at
*>          least zero. If it is zero, no randomly generated matrices
*>          are tested, but any test matrices read from NIUNIT will be
*>          tested.
*> \endverbatim
*>
*> \param[in] NN
*> \verbatim
*>          NN is INTEGER array, dimension (NSIZES)
*>          An array containing the sizes to be used for the matrices.
*>          Zero values will be skipped.  The values must be at least
*>          zero.
*> \endverbatim
*>
*> \param[in] NTYPES
*> \verbatim
*>          NTYPES is INTEGER
*>          The number of elements in DOTYPE. NTYPES must be at least
*>          zero. If it is zero, no randomly generated test matrices
*>          are tested, but and test matrices read from NIUNIT will be
*>          tested. If it is MAXTYP+1 and NSIZES is 1, then an
*>          additional type, MAXTYP+1 is defined, which is to use
*>          whatever matrix is in A.  This is only useful if
*>          DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. .
*> \endverbatim
*>
*> \param[in] DOTYPE
*> \verbatim
*>          DOTYPE is LOGICAL array, dimension (NTYPES)
*>          If DOTYPE(j) is .TRUE., then for each size in NN a
*>          matrix of that size and of type j will be generated.
*>          If NTYPES is smaller than the maximum number of types
*>          defined (PARAMETER MAXTYP), then types NTYPES+1 through
*>          MAXTYP will not be generated.  If NTYPES is larger
*>          than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
*>          will be ignored.
*> \endverbatim
*>
*> \param[in,out] ISEED
*> \verbatim
*>          ISEED is INTEGER array, dimension (4)
*>          On entry ISEED specifies the seed of the random number
*>          generator. The array elements should be between 0 and 4095;
*>          if not they will be reduced mod 4096.  Also, ISEED(4) must
*>          be odd.  The random number generator uses a linear
*>          congruential sequence limited to small integers, and so
*>          should produce machine independent random numbers. The
*>          values of ISEED are changed on exit, and can be used in the
*>          next call to ZDRVSX to continue the same random number
*>          sequence.
*> \endverbatim
*>
*> \param[in] THRESH
*> \verbatim
*>          THRESH is DOUBLE PRECISION
*>          A test will count as "failed" if the "error", computed as
*>          described above, exceeds THRESH.  Note that the error
*>          is scaled to be O(1), so THRESH should be a reasonably
*>          small multiple of 1, e.g., 10 or 100.  In particular,
*>          it should not depend on the precision (single vs. double)
*>          or the size of the matrix.  It must be at least zero.
*> \endverbatim
*>
*> \param[in] NIUNIT
*> \verbatim
*>          NIUNIT is INTEGER
*>          The FORTRAN unit number for reading in the data file of
*>          problems to solve.
*> \endverbatim
*>
*> \param[in] NOUNIT
*> \verbatim
*>          NOUNIT is INTEGER
*>          The FORTRAN unit number for printing out error messages
*>          (e.g., if a routine returns INFO not equal to 0.)
*> \endverbatim
*>
*> \param[out] A
*> \verbatim
*>          A is COMPLEX*16 array, dimension (LDA, max(NN))
*>          Used to hold the matrix whose eigenvalues are to be
*>          computed.  On exit, A contains the last matrix actually used.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of A, and H. LDA must be at
*>          least 1 and at least max( NN ).
*> \endverbatim
*>
*> \param[out] H
*> \verbatim
*>          H is COMPLEX*16 array, dimension (LDA, max(NN))
*>          Another copy of the test matrix A, modified by ZGEESX.
*> \endverbatim
*>
*> \param[out] HT
*> \verbatim
*>          HT is COMPLEX*16 array, dimension (LDA, max(NN))
*>          Yet another copy of the test matrix A, modified by ZGEESX.
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*>          W is COMPLEX*16 array, dimension (max(NN))
*>          The computed eigenvalues of A.
*> \endverbatim
*>
*> \param[out] WT
*> \verbatim
*>          WT is COMPLEX*16 array, dimension (max(NN))
*>          Like W, this array contains the eigenvalues of A,
*>          but those computed when ZGEESX only computes a partial
*>          eigendecomposition, i.e. not Schur vectors
*> \endverbatim
*>
*> \param[out] WTMP
*> \verbatim
*>          WTMP is COMPLEX*16 array, dimension (max(NN))
*>          More temporary storage for eigenvalues.
*> \endverbatim
*>
*> \param[out] VS
*> \verbatim
*>          VS is COMPLEX*16 array, dimension (LDVS, max(NN))
*>          VS holds the computed Schur vectors.
*> \endverbatim
*>
*> \param[in] LDVS
*> \verbatim
*>          LDVS is INTEGER
*>          Leading dimension of VS. Must be at least max(1,max(NN)).
*> \endverbatim
*>
*> \param[out] VS1
*> \verbatim
*>          VS1 is COMPLEX*16 array, dimension (LDVS, max(NN))
*>          VS1 holds another copy of the computed Schur vectors.
*> \endverbatim
*>
*> \param[out] RESULT
*> \verbatim
*>          RESULT is DOUBLE PRECISION array, dimension (17)
*>          The values computed by the 17 tests described above.
*>          The values are currently limited to 1/ulp, to avoid overflow.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is COMPLEX*16 array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The number of entries in WORK.  This must be at least
*>          max(1,2*NN(j)**2) for all j.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*>          RWORK is DOUBLE PRECISION array, dimension (max(NN))
*> \endverbatim
*>
*> \param[out] BWORK
*> \verbatim
*>          BWORK is LOGICAL array, dimension (max(NN))
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          If 0,  successful exit.
*>            <0,  input parameter -INFO is incorrect
*>            >0,  ZLATMR, CLATMS, CLATME or ZGET24 returned an error
*>                 code and INFO is its absolute value
*>
*>-----------------------------------------------------------------------
*>
*>     Some Local Variables and Parameters:
*>     ---- ----- --------- --- ----------
*>     ZERO, ONE       Real 0 and 1.
*>     MAXTYP          The number of types defined.
*>     NMAX            Largest value in NN.
*>     NERRS           The number of tests which have exceeded THRESH
*>     COND, CONDS,
*>     IMODE           Values to be passed to the matrix generators.
*>     ANORM           Norm of A; passed to matrix generators.
*>
*>     OVFL, UNFL      Overflow and underflow thresholds.
*>     ULP, ULPINV     Finest relative precision and its inverse.
*>     RTULP, RTULPI   Square roots of the previous 4 values.
*>             The following four arrays decode JTYPE:
*>     KTYPE(j)        The general type (1-10) for type "j".
*>     KMODE(j)        The MODE value to be passed to the matrix
*>                     generator for type "j".
*>     KMAGN(j)        The order of magnitude ( O(1),
*>                     O(overflow^(1/2) ), O(underflow^(1/2) )
*>     KCONDS(j)       Selectw whether CONDS is to be 1 or
*>                     1/sqrt(ulp).  (0 means irrelevant.)
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2016
*
*> \ingroup complex16_eig
*
*  =====================================================================
      SUBROUTINE ZDRVSX( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
     $                   NIUNIT, NOUNIT, A, LDA, H, HT, W, WT, WTMP, VS,
     $                   LDVS, VS1, RESULT, WORK, LWORK, RWORK, BWORK,
     $                   INFO )
*
*  -- LAPACK test routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     June 2016
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDVS, LWORK, NIUNIT, NOUNIT, NSIZES,
     $                   NTYPES
      DOUBLE PRECISION   THRESH
*     ..
*     .. Array Arguments ..
      LOGICAL            BWORK( * ), DOTYPE( * )
      INTEGER            ISEED( 4 ), NN( * )
      DOUBLE PRECISION   RESULT( 17 ), RWORK( * )
      COMPLEX*16         A( LDA, * ), H( LDA, * ), HT( LDA, * ),
     $                   VS( LDVS, * ), VS1( LDVS, * ), W( * ),
     $                   WORK( * ), WT( * ), WTMP( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX*16         CZERO
      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ) )
      COMPLEX*16         CONE
      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ) )
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
      INTEGER            MAXTYP
      PARAMETER          ( MAXTYP = 21 )
*     ..
*     .. Local Scalars ..
      LOGICAL            BADNN
      CHARACTER*3        PATH
      INTEGER            I, IINFO, IMODE, ISRT, ITYPE, IWK, J, JCOL,
     $                   JSIZE, JTYPE, MTYPES, N, NERRS, NFAIL, NMAX,
     $                   NNWORK, NSLCT, NTEST, NTESTF, NTESTT
      DOUBLE PRECISION   ANORM, COND, CONDS, OVFL, RCDEIN, RCDVIN,
     $                   RTULP, RTULPI, ULP, ULPINV, UNFL
*     ..
*     .. Local Arrays ..
      INTEGER            IDUMMA( 1 ), IOLDSD( 4 ), ISLCT( 20 ),
     $                   KCONDS( MAXTYP ), KMAGN( MAXTYP ),
     $                   KMODE( MAXTYP ), KTYPE( MAXTYP )
*     ..
*     .. Arrays in Common ..
      LOGICAL            SELVAL( 20 )
      DOUBLE PRECISION   SELWI( 20 ), SELWR( 20 )
*     ..
*     .. Scalars in Common ..
      INTEGER            SELDIM, SELOPT
*     ..
*     .. Common blocks ..
      COMMON             / SSLCT / SELOPT, SELDIM, SELVAL, SELWR, SELWI
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLABAD, DLASUM, XERBLA, ZGET24, ZLASET, ZLATME,
     $                   ZLATMR, ZLATMS
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SQRT
*     ..
*     .. Data statements ..
      DATA               KTYPE / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
      DATA               KMAGN / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
     $                   3, 1, 2, 3 /
      DATA               KMODE / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
     $                   1, 5, 5, 5, 4, 3, 1 /
      DATA               KCONDS / 3*0, 5*0, 4*1, 6*2, 3*0 /
*     ..
*     .. Executable Statements ..
*
      PATH( 1: 1 ) = 'Zomplex precision'
      PATH( 2: 3 ) = 'SX'
*
*     Check for errors
*
      NTESTT = 0
      NTESTF = 0
      INFO = 0
*
*     Important constants
*
      BADNN = .FALSE.
*
*     8 is the largest dimension in the input file of precomputed
*     problems
*
      NMAX = 8
      DO 10 J = 1, NSIZES
         NMAX = MAX( NMAX, NN( J ) )
         IF( NN( J ).LT.0 )
     $      BADNN = .TRUE.
   10 CONTINUE
*
*     Check for errors
*
      IF( NSIZES.LT.0 ) THEN
         INFO = -1
      ELSE IF( BADNN ) THEN
         INFO = -2
      ELSE IF( NTYPES.LT.0 ) THEN
         INFO = -3
      ELSE IF( THRESH.LT.ZERO ) THEN
         INFO = -6
      ELSE IF( NIUNIT.LE.0 ) THEN
         INFO = -7
      ELSE IF( NOUNIT.LE.0 ) THEN
         INFO = -8
      ELSE IF( LDA.LT.1 .OR. LDA.LT.NMAX ) THEN
         INFO = -10
      ELSE IF( LDVS.LT.1 .OR. LDVS.LT.NMAX ) THEN
         INFO = -20
      ELSE IF( MAX( 3*NMAX, 2*NMAX**2 ).GT.LWORK ) THEN
         INFO = -24
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZDRVSX', -INFO )
         RETURN
      END IF
*
*     If nothing to do check on NIUNIT
*
      IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
     $   GO TO 150
*
*     More Important constants
*
      UNFL = DLAMCH( 'Safe minimum' )
      OVFL = ONE / UNFL
      CALL DLABAD( UNFL, OVFL )
      ULP = DLAMCH( 'Precision' )
      ULPINV = ONE / ULP
      RTULP = SQRT( ULP )
      RTULPI = ONE / RTULP
*
*     Loop over sizes, types
*
      NERRS = 0
*
      DO 140 JSIZE = 1, NSIZES
         N = NN( JSIZE )
         IF( NSIZES.NE.1 ) THEN
            MTYPES = MIN( MAXTYP, NTYPES )
         ELSE
            MTYPES = MIN( MAXTYP+1, NTYPES )
         END IF
*
         DO 130 JTYPE = 1, MTYPES
            IF( .NOT.DOTYPE( JTYPE ) )
     $         GO TO 130
*
*           Save ISEED in case of an error.
*
            DO 20 J = 1, 4
               IOLDSD( J ) = ISEED( J )
   20       CONTINUE
*
*           Compute "A"
*
*           Control parameters:
*
*           KMAGN  KCONDS  KMODE        KTYPE
*       =1  O(1)   1       clustered 1  zero
*       =2  large  large   clustered 2  identity
*       =3  small          exponential  Jordan
*       =4                 arithmetic   diagonal, (w/ eigenvalues)
*       =5                 random log   symmetric, w/ eigenvalues
*       =6                 random       general, w/ eigenvalues
*       =7                              random diagonal
*       =8                              random symmetric
*       =9                              random general
*       =10                             random triangular
*
            IF( MTYPES.GT.MAXTYP )
     $         GO TO 90
*
            ITYPE = KTYPE( JTYPE )
            IMODE = KMODE( JTYPE )
*
*           Compute norm
*
            GO TO ( 30, 40, 50 )KMAGN( JTYPE )
*
   30       CONTINUE
            ANORM = ONE
            GO TO 60
*
   40       CONTINUE
            ANORM = OVFL*ULP
            GO TO 60
*
   50       CONTINUE
            ANORM = UNFL*ULPINV
            GO TO 60
*
   60       CONTINUE
*
            CALL ZLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA )
            IINFO = 0
            COND = ULPINV
*
*           Special Matrices -- Identity & Jordan block
*
            IF( ITYPE.EQ.1 ) THEN
*
*              Zero
*
               IINFO = 0
*
            ELSE IF( ITYPE.EQ.2 ) THEN
*
*              Identity
*
               DO 70 JCOL = 1, N
                  A( JCOL, JCOL ) = ANORM
   70          CONTINUE
*
            ELSE IF( ITYPE.EQ.3 ) THEN
*
*              Jordan Block
*
               DO 80 JCOL = 1, N
                  A( JCOL, JCOL ) = ANORM
                  IF( JCOL.GT.1 )
     $               A( JCOL, JCOL-1 ) = CONE
   80          CONTINUE
*
            ELSE IF( ITYPE.EQ.4 ) THEN
*
*              Diagonal Matrix, [Eigen]values Specified
*
               CALL ZLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND,
     $                      ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ),
     $                      IINFO )
*
            ELSE IF( ITYPE.EQ.5 ) THEN
*
*              Symmetric, eigenvalues specified
*
               CALL ZLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND,
     $                      ANORM, N, N, 'N', A, LDA, WORK( N+1 ),
     $                      IINFO )
*
            ELSE IF( ITYPE.EQ.6 ) THEN
*
*              General, eigenvalues specified
*
               IF( KCONDS( JTYPE ).EQ.1 ) THEN
                  CONDS = ONE
               ELSE IF( KCONDS( JTYPE ).EQ.2 ) THEN
                  CONDS = RTULPI
               ELSE
                  CONDS = ZERO
               END IF
*
               CALL ZLATME( N, 'D', ISEED, WORK, IMODE, COND, CONE,
     $                      'T', 'T', 'T', RWORK, 4, CONDS, N, N, ANORM,
     $                      A, LDA, WORK( 2*N+1 ), IINFO )
*
            ELSE IF( ITYPE.EQ.7 ) THEN
*
*              Diagonal, random eigenvalues
*
               CALL ZLATMR( N, N, 'D', ISEED, 'N', WORK, 6, ONE, CONE,
     $                      'T', 'N', WORK( N+1 ), 1, ONE,
     $                      WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0,
     $                      ZERO, ANORM, 'NO', A, LDA, IDUMMA, IINFO )
*
            ELSE IF( ITYPE.EQ.8 ) THEN
*
*              Symmetric, random eigenvalues
*
               CALL ZLATMR( N, N, 'D', ISEED, 'H', WORK, 6, ONE, CONE,
     $                      'T', 'N', WORK( N+1 ), 1, ONE,
     $                      WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
     $                      ZERO, ANORM, 'NO', A, LDA, IDUMMA, IINFO )
*
            ELSE IF( ITYPE.EQ.9 ) THEN
*
*              General, random eigenvalues
*
               CALL ZLATMR( N, N, 'D', ISEED, 'N', WORK, 6, ONE, CONE,
     $                      'T', 'N', WORK( N+1 ), 1, ONE,
     $                      WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
     $                      ZERO, ANORM, 'NO', A, LDA, IDUMMA, IINFO )
               IF( N.GE.4 ) THEN
                  CALL ZLASET( 'Full', 2, N, CZERO, CZERO, A, LDA )
                  CALL ZLASET( 'Full', N-3, 1, CZERO, CZERO, A( 3, 1 ),
     $                         LDA )
                  CALL ZLASET( 'Full', N-3, 2, CZERO, CZERO,
     $                         A( 3, N-1 ), LDA )
                  CALL ZLASET( 'Full', 1, N, CZERO, CZERO, A( N, 1 ),
     $                         LDA )
               END IF
*
            ELSE IF( ITYPE.EQ.10 ) THEN
*
*              Triangular, random eigenvalues
*
               CALL ZLATMR( N, N, 'D', ISEED, 'N', WORK, 6, ONE, CONE,
     $                      'T', 'N', WORK( N+1 ), 1, ONE,
     $                      WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, 0,
     $                      ZERO, ANORM, 'NO', A, LDA, IDUMMA, IINFO )
*
            ELSE
*
               IINFO = 1
            END IF
*
            IF( IINFO.NE.0 ) THEN
               WRITE( NOUNIT, FMT = 9991 )'Generator', IINFO, N, JTYPE,
     $            IOLDSD
               INFO = ABS( IINFO )
               RETURN
            END IF
*
   90       CONTINUE
*
*           Test for minimal and generous workspace
*
            DO 120 IWK = 1, 2
               IF( IWK.EQ.1 ) THEN
                  NNWORK = 2*N
               ELSE
                  NNWORK = MAX( 2*N, N*( N+1 ) / 2 )
               END IF
               NNWORK = MAX( NNWORK, 1 )
*
               CALL ZGET24( .FALSE., JTYPE, THRESH, IOLDSD, NOUNIT, N,
     $                      A, LDA, H, HT, W, WT, WTMP, VS, LDVS, VS1,
     $                      RCDEIN, RCDVIN, NSLCT, ISLCT, 0, RESULT,
     $                      WORK, NNWORK, RWORK, BWORK, INFO )
*
*              Check for RESULT(j) > THRESH
*
               NTEST = 0
               NFAIL = 0
               DO 100 J = 1, 15
                  IF( RESULT( J ).GE.ZERO )
     $               NTEST = NTEST + 1
                  IF( RESULT( J ).GE.THRESH )
     $               NFAIL = NFAIL + 1
  100          CONTINUE
*
               IF( NFAIL.GT.0 )
     $            NTESTF = NTESTF + 1
               IF( NTESTF.EQ.1 ) THEN
                  WRITE( NOUNIT, FMT = 9999 )PATH
                  WRITE( NOUNIT, FMT = 9998 )
                  WRITE( NOUNIT, FMT = 9997 )
                  WRITE( NOUNIT, FMT = 9996 )
                  WRITE( NOUNIT, FMT = 9995 )THRESH
                  WRITE( NOUNIT, FMT = 9994 )
                  NTESTF = 2
               END IF
*
               DO 110 J = 1, 15
                  IF( RESULT( J ).GE.THRESH ) THEN
                     WRITE( NOUNIT, FMT = 9993 )N, IWK, IOLDSD, JTYPE,
     $                  J, RESULT( J )
                  END IF
  110          CONTINUE
*
               NERRS = NERRS + NFAIL
               NTESTT = NTESTT + NTEST
*
  120       CONTINUE
  130    CONTINUE
  140 CONTINUE
*
  150 CONTINUE
*
*     Read in data from file to check accuracy of condition estimation
*     Read input data until N=0
*
      JTYPE = 0
  160 CONTINUE
      READ( NIUNIT, FMT = *, END = 200 )N, NSLCT, ISRT
      IF( N.EQ.0 )
     $   GO TO 200
      JTYPE = JTYPE + 1
      ISEED( 1 ) = JTYPE
      READ( NIUNIT, FMT = * )( ISLCT( I ), I = 1, NSLCT )
      DO 170 I = 1, N
         READ( NIUNIT, FMT = * )( A( I, J ), J = 1, N )
  170 CONTINUE
      READ( NIUNIT, FMT = * )RCDEIN, RCDVIN
*
      CALL ZGET24( .TRUE., 22, THRESH, ISEED, NOUNIT, N, A, LDA, H, HT,
     $             W, WT, WTMP, VS, LDVS, VS1, RCDEIN, RCDVIN, NSLCT,
     $             ISLCT, ISRT, RESULT, WORK, LWORK, RWORK, BWORK,
     $             INFO )
*
*     Check for RESULT(j) > THRESH
*
      NTEST = 0
      NFAIL = 0
      DO 180 J = 1, 17
         IF( RESULT( J ).GE.ZERO )
     $      NTEST = NTEST + 1
         IF( RESULT( J ).GE.THRESH )
     $      NFAIL = NFAIL + 1
  180 CONTINUE
*
      IF( NFAIL.GT.0 )
     $   NTESTF = NTESTF + 1
      IF( NTESTF.EQ.1 ) THEN
         WRITE( NOUNIT, FMT = 9999 )PATH
         WRITE( NOUNIT, FMT = 9998 )
         WRITE( NOUNIT, FMT = 9997 )
         WRITE( NOUNIT, FMT = 9996 )
         WRITE( NOUNIT, FMT = 9995 )THRESH
         WRITE( NOUNIT, FMT = 9994 )
         NTESTF = 2
      END IF
      DO 190 J = 1, 17
         IF( RESULT( J ).GE.THRESH ) THEN
            WRITE( NOUNIT, FMT = 9992 )N, JTYPE, J, RESULT( J )
         END IF
  190 CONTINUE
*
      NERRS = NERRS + NFAIL
      NTESTT = NTESTT + NTEST
      GO TO 160
  200 CONTINUE
*
*     Summary
*
      CALL DLASUM( PATH, NOUNIT, NERRS, NTESTT )
*
 9999 FORMAT( / 1X, A3, ' -- Complex Schur Form Decomposition Expert ',
     $      'Driver', / ' Matrix types (see ZDRVSX for details): ' )
*
 9998 FORMAT( / ' Special Matrices:', / '  1=Zero matrix.             ',
     $      '           ', '  5=Diagonal: geometr. spaced entries.',
     $      / '  2=Identity matrix.                    ', '  6=Diagona',
     $      'l: clustered entries.', / '  3=Transposed Jordan block.  ',
     $      '          ', '  7=Diagonal: large, evenly spaced.', / '  ',
     $      '4=Diagonal: evenly spaced entries.    ', '  8=Diagonal: s',
     $      'mall, evenly spaced.' )
 9997 FORMAT( ' Dense, Non-Symmetric Matrices:', / '  9=Well-cond., ev',
     $      'enly spaced eigenvals.', ' 14=Ill-cond., geomet. spaced e',
     $      'igenals.', / ' 10=Well-cond., geom. spaced eigenvals. ',
     $      ' 15=Ill-conditioned, clustered e.vals.', / ' 11=Well-cond',
     $      'itioned, clustered e.vals. ', ' 16=Ill-cond., random comp',
     $      'lex ', / ' 12=Well-cond., random complex ', '         ',
     $      ' 17=Ill-cond., large rand. complx ', / ' 13=Ill-condi',
     $      'tioned, evenly spaced.     ', ' 18=Ill-cond., small rand.',
     $      ' complx ' )
 9996 FORMAT( ' 19=Matrix with random O(1) entries.    ', ' 21=Matrix ',
     $      'with small random entries.', / ' 20=Matrix with large ran',
     $      'dom entries.   ', / )
 9995 FORMAT( ' Tests performed with test threshold =', F8.2,
     $      / ' ( A denotes A on input and T denotes A on output)',
     $      / / ' 1 = 0 if T in Schur form (no sort), ',
     $      '  1/ulp otherwise', /
     $      ' 2 = | A - VS T transpose(VS) | / ( n |A| ulp ) (no sort)',
     $      / ' 3 = | I - VS transpose(VS) | / ( n ulp ) (no sort) ',
     $      / ' 4 = 0 if W are eigenvalues of T (no sort),',
     $      '  1/ulp otherwise', /
     $      ' 5 = 0 if T same no matter if VS computed (no sort),',
     $      '  1/ulp otherwise', /
     $      ' 6 = 0 if W same no matter if VS computed (no sort)',
     $      ',  1/ulp otherwise' )
 9994 FORMAT( ' 7 = 0 if T in Schur form (sort), ', '  1/ulp otherwise',
     $      / ' 8 = | A - VS T transpose(VS) | / ( n |A| ulp ) (sort)',
     $      / ' 9 = | I - VS transpose(VS) | / ( n ulp ) (sort) ',
     $      / ' 10 = 0 if W are eigenvalues of T (sort),',
     $      '  1/ulp otherwise', /
     $      ' 11 = 0 if T same no matter what else computed (sort),',
     $      '  1/ulp otherwise', /
     $      ' 12 = 0 if W same no matter what else computed ',
     $      '(sort), 1/ulp otherwise', /
     $      ' 13 = 0 if sorting successful, 1/ulp otherwise',
     $      / ' 14 = 0 if RCONDE same no matter what else computed,',
     $      ' 1/ulp otherwise', /
     $      ' 15 = 0 if RCONDv same no matter what else computed,',
     $      ' 1/ulp otherwise', /
     $      ' 16 = | RCONDE - RCONDE(precomputed) | / cond(RCONDE),',
     $      / ' 17 = | RCONDV - RCONDV(precomputed) | / cond(RCONDV),' )
 9993 FORMAT( ' N=', I5, ', IWK=', I2, ', seed=', 4( I4, ',' ),
     $      ' type ', I2, ', test(', I2, ')=', G10.3 )
 9992 FORMAT( ' N=', I5, ', input example =', I3, ',  test(', I2, ')=',
     $      G10.3 )
 9991 FORMAT( ' ZDRVSX: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
     $      I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
*
      RETURN
*
*     End of ZDRVSX
*
      END


module splay_node_mod
    use,intrinsic :: iso_fortran_env
    implicit none
    type:: splay_node
        type(splay_node),pointer:: left => null()
        type(splay_node),pointer:: right => null()
        type(splay_node),pointer:: parent => null()
        integer(int32):: size = 1
        integer(int32):: value, minimum
    end type

contains
    function sn_state(sn)
        type(splay_node), pointer:: sn
        integer(int32):: sn_state

        sn_state=0
        if (associated(sn%parent)) then
            if (associated(sn%parent%left, sn)) sn_state=1
            if (associated(sn%parent%right, sn)) sn_state=-1
        end if
    end function

    subroutine sn_rotate(sn)
        type(splay_node),pointer:: sn
        type(splay_node),pointer:: pp, p, c

        ! 登場人物:: 自分(sn), 子供(c), 親(p), 親親(pp)
        ! 自分と親の存在は確定。親親の存在は未定

        ! 自分=子供の片方, 自分=親, 親=親親 それぞれ双方向
        ! 計6本の辺を張り替える。

        p => sn%parent
        pp => p%parent

        if (associated(p%left, sn)) then ! 左回転
            c => sn%right
            sn%right => p
            p%left => c
        else ! 右回転
            c => sn%left
            sn%left => p
            p%right => c
        end if

        if (associated(pp)) then
            if (associated(pp%left, p)) pp%left => sn
            if (associated(pp%right, p)) pp%right => sn
        end if

        sn%parent => pp
        p%parent => sn
        if (associated(c)) c%parent => p

        ! 回転後は自分と親のサイズが変わっている。
        ! 回転後は自分は親より上にいるので、親->自分の順にsize_update
        call sn_size_update(p)
        call sn_size_update(sn)
    end subroutine

    subroutine sn_splay(sn)
        type(splay_node),pointer:: sn

        ! 自分の親がいなくなるまで(=自分が根になるまで)続ける
        do while(associated(sn%parent))
            if (sn_state(sn%parent) == 0) then
                ! 親の親がいない
                call sn_rotate(sn)
            else if (sn_state(sn) == sn_state(sn%parent)) then
                ! me->p->ppが直線 => 親->自分の順にrotate
                call sn_rotate(sn%parent)
                call sn_rotate(sn)
            else ! me->p->ppが折れ線 => 自分を2回rotate
                call sn_rotate(sn)
                call sn_rotate(sn)
            end if
        end do
    end subroutine

    subroutine sn_size_update(sn)
        class(splay_node):: sn

        sn%size = 1
        sn%minimum = sn%value
        if (associated(sn%left)) then
            sn%size = sn%size+sn%left%size
            sn%minimum = min(sn%minimum, sn%left%minimum)
        end if
        if (associated(sn%right)) then
            sn%size = sn%size+sn%right%size
            sn%minimum = min(sn%minimum, sn%right%minimum)
        end if
    end subroutine

    subroutine sn_rooting(root, ind)
        type(splay_node),pointer:: root
        type(splay_node),pointer:: now
        integer(int32),value:: ind
        integer(int32):: now_ind

        now => root
        ! ind番目のノードを探しに、根から降りていく
        ! nowは今いるノード, now_indは今いるノードが何番目のノードか。
        do while(.true.)

            if (associated(now%left))then
                now_ind = now%left%size + 1
            else
                now_ind = 1
            end if
            if (ind < now_ind) then
                now => now%left
            end if
            if (ind == now_ind) then
                call sn_splay(now)
                root => now
                return
            end if
            if (ind > now_ind) then
                now => now%right
                ind = ind-now_ind
            end if
        end do
    end subroutine
end module


*
*     ------------------------------------------------------------------
*       B L O C K   D A T A    G L C O N S
*     ------------------------------------------------------------------
*
      BLOCK DATA GLCONS
C
      IMPLICIT DOUBLEPRECISION (A-H,O-Z)
C
      COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS
C
C     SET GLOBAL REAL CONSTANTS
C
      DATA ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS/
     :     0.0D 00,0.1D 00,0.5D 00,
     :     1.0D 00,2.0D 00,3.0D 00,
     :     4.0D 00,
     :     7.0D 00,1.1D 01,1.0D-08/
C
      END


!*==zsymm.f90  processed by SPAG 7.51RB at 20:37 on  3 Mar 2022
!> \brief \b ZSYMM
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       SUBROUTINE ZSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
!
!       .. Scalar Arguments ..
!       COMPLEX*16 ALPHA,BETA
!       INTEGER LDA,LDB,LDC,M,N
!       CHARACTER SIDE,UPLO
!       ..
!       .. Array Arguments ..
!       COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*)
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> ZSYMM  performs one of the matrix-matrix operations
!>
!>    C := alpha*A*B + beta*C,
!>
!> or
!>
!>    C := alpha*B*A + beta*C,
!>
!> where  alpha and beta are scalars, A is a symmetric matrix and  B and
!> C are m by n matrices.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] SIDE
!> \verbatim
!>          SIDE is CHARACTER*1
!>           On entry,  SIDE  specifies whether  the  symmetric matrix  A
!>           appears on the  left or right  in the  operation as follows:
!>
!>              SIDE = 'L' or 'l'   C := alpha*A*B + beta*C,
!>
!>              SIDE = 'R' or 'r'   C := alpha*B*A + beta*C,
!> \endverbatim
!>
!> \param[in] UPLO
!> \verbatim
!>          UPLO is CHARACTER*1
!>           On  entry,   UPLO  specifies  whether  the  upper  or  lower
!>           triangular  part  of  the  symmetric  matrix   A  is  to  be
!>           referenced as follows:
!>
!>              UPLO = 'U' or 'u'   Only the upper triangular part of the
!>                                  symmetric matrix is to be referenced.
!>
!>              UPLO = 'L' or 'l'   Only the lower triangular part of the
!>                                  symmetric matrix is to be referenced.
!> \endverbatim
!>
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>           On entry,  M  specifies the number of rows of the matrix  C.
!>           M  must be at least zero.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>           On entry, N specifies the number of columns of the matrix C.
!>           N  must be at least zero.
!> \endverbatim
!>
!> \param[in] ALPHA
!> \verbatim
!>          ALPHA is COMPLEX*16
!>           On entry, ALPHA specifies the scalar alpha.
!> \endverbatim
!>
!> \param[in] A
!> \verbatim
!>          A is COMPLEX*16 array, dimension ( LDA, ka ), where ka is
!>           m  when  SIDE = 'L' or 'l'  and is n  otherwise.
!>           Before entry  with  SIDE = 'L' or 'l',  the  m by m  part of
!>           the array  A  must contain the  symmetric matrix,  such that
!>           when  UPLO = 'U' or 'u', the leading m by m upper triangular
!>           part of the array  A  must contain the upper triangular part
!>           of the  symmetric matrix and the  strictly  lower triangular
!>           part of  A  is not referenced,  and when  UPLO = 'L' or 'l',
!>           the leading  m by m  lower triangular part  of the  array  A
!>           must  contain  the  lower triangular part  of the  symmetric
!>           matrix and the  strictly upper triangular part of  A  is not
!>           referenced.
!>           Before entry  with  SIDE = 'R' or 'r',  the  n by n  part of
!>           the array  A  must contain the  symmetric matrix,  such that
!>           when  UPLO = 'U' or 'u', the leading n by n upper triangular
!>           part of the array  A  must contain the upper triangular part
!>           of the  symmetric matrix and the  strictly  lower triangular
!>           part of  A  is not referenced,  and when  UPLO = 'L' or 'l',
!>           the leading  n by n  lower triangular part  of the  array  A
!>           must  contain  the  lower triangular part  of the  symmetric
!>           matrix and the  strictly upper triangular part of  A  is not
!>           referenced.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>           On entry, LDA specifies the first dimension of A as declared
!>           in the  calling (sub) program. When  SIDE = 'L' or 'l'  then
!>           LDA must be at least  max( 1, m ), otherwise  LDA must be at
!>           least max( 1, n ).
!> \endverbatim
!>
!> \param[in] B
!> \verbatim
!>          B is COMPLEX*16 array, dimension ( LDB, N )
!>           Before entry, the leading  m by n part of the array  B  must
!>           contain the matrix B.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>           On entry, LDB specifies the first dimension of B as declared
!>           in  the  calling  (sub)  program.   LDB  must  be  at  least
!>           max( 1, m ).
!> \endverbatim
!>
!> \param[in] BETA
!> \verbatim
!>          BETA is COMPLEX*16
!>           On entry,  BETA  specifies the scalar  beta.  When  BETA  is
!>           supplied as zero then C need not be set on input.
!> \endverbatim
!>
!> \param[in,out] C
!> \verbatim
!>          C is COMPLEX*16 array, dimension ( LDC, N )
!>           Before entry, the leading  m by n  part of the array  C must
!>           contain the matrix  C,  except when  beta  is zero, in which
!>           case C need not be set on entry.
!>           On exit, the array  C  is overwritten by the  m by n updated
!>           matrix.
!> \endverbatim
!>
!> \param[in] LDC
!> \verbatim
!>          LDC is INTEGER
!>           On entry, LDC specifies the first dimension of C as declared
!>           in  the  calling  (sub)  program.   LDC  must  be  at  least
!>           max( 1, m ).
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complex16_blas_level3
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  Level 3 Blas routine.
!>
!>  -- Written on 8-February-1989.
!>     Jack Dongarra, Argonne National Laboratory.
!>     Iain Duff, AERE Harwell.
!>     Jeremy Du Croz, Numerical Algorithms Group Ltd.
!>     Sven Hammarling, Numerical Algorithms Group Ltd.
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE ZSYMM(Side,Uplo,M,N,Alpha,A,Lda,B,Ldb,Beta,C,Ldc)
      IMPLICIT NONE
!*--ZSYMM193
!
!  -- Reference BLAS level3 routine (version 3.7.0) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      COMPLEX*16 Alpha , Beta
      INTEGER Lda , Ldb , Ldc , M , N
      CHARACTER Side , Uplo
!     ..
!     .. Array Arguments ..
      COMPLEX*16 A(Lda,*) , B(Ldb,*) , C(Ldc,*)
!     ..
!
!  =====================================================================
!
!     .. External Functions ..
      LOGICAL LSAME
      EXTERNAL LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX
!     ..
!     .. Local Scalars ..
      COMPLEX*16 temp1 , temp2
      INTEGER i , info , j , k , nrowa
      LOGICAL upper
!     ..
!     .. Parameters ..
      COMPLEX*16 ONE
      PARAMETER (ONE=(1.0D+0,0.0D+0))
      COMPLEX*16 ZERO
      PARAMETER (ZERO=(0.0D+0,0.0D+0))
!     ..
!
!     Set NROWA as the number of rows of A.
!
      IF ( LSAME(Side,'L') ) THEN
         nrowa = M
      ELSE
         nrowa = N
      ENDIF
      upper = LSAME(Uplo,'U')
!
!     Test the input parameters.
!
      info = 0
      IF ( (.NOT.LSAME(Side,'L')) .AND. (.NOT.LSAME(Side,'R')) ) THEN
         info = 1
      ELSEIF ( (.NOT.upper) .AND. (.NOT.LSAME(Uplo,'L')) ) THEN
         info = 2
      ELSEIF ( M<0 ) THEN
         info = 3
      ELSEIF ( N<0 ) THEN
         info = 4
      ELSEIF ( Lda<MAX(1,nrowa) ) THEN
         info = 7
      ELSEIF ( Ldb<MAX(1,M) ) THEN
         info = 9
      ELSEIF ( Ldc<MAX(1,M) ) THEN
         info = 12
      ENDIF
      IF ( info/=0 ) THEN
         CALL XERBLA('ZSYMM ',info)
         RETURN
      ENDIF
!
!     Quick return if possible.
!
      IF ( (M==0) .OR. (N==0) .OR. ((Alpha==ZERO) .AND. (Beta==ONE)) )  &
     &     RETURN
!
!     And when  alpha.eq.zero.
!
      IF ( Alpha==ZERO ) THEN
         IF ( Beta==ZERO ) THEN
            DO j = 1 , N
               DO i = 1 , M
                  C(i,j) = ZERO
               ENDDO
            ENDDO
         ELSE
            DO j = 1 , N
               DO i = 1 , M
                  C(i,j) = Beta*C(i,j)
               ENDDO
            ENDDO
         ENDIF
         RETURN
      ENDIF
!
!     Start the operations.
!
      IF ( .NOT.(LSAME(Side,'L')) ) THEN
!
!        Form  C := alpha*B*A + beta*C.
!
         DO j = 1 , N
            temp1 = Alpha*A(j,j)
            IF ( Beta==ZERO ) THEN
               DO i = 1 , M
                  C(i,j) = temp1*B(i,j)
               ENDDO
            ELSE
               DO i = 1 , M
                  C(i,j) = Beta*C(i,j) + temp1*B(i,j)
               ENDDO
            ENDIF
            DO k = 1 , j - 1
               IF ( upper ) THEN
                  temp1 = Alpha*A(k,j)
               ELSE
                  temp1 = Alpha*A(j,k)
               ENDIF
               DO i = 1 , M
                  C(i,j) = C(i,j) + temp1*B(i,k)
               ENDDO
            ENDDO
            DO k = j + 1 , N
               IF ( upper ) THEN
                  temp1 = Alpha*A(j,k)
               ELSE
                  temp1 = Alpha*A(k,j)
               ENDIF
               DO i = 1 , M
                  C(i,j) = C(i,j) + temp1*B(i,k)
               ENDDO
            ENDDO
         ENDDO
!
!        Form  C := alpha*A*B + beta*C.
!
      ELSEIF ( upper ) THEN
         DO j = 1 , N
            DO i = 1 , M
               temp1 = Alpha*B(i,j)
               temp2 = ZERO
               DO k = 1 , i - 1
                  C(k,j) = C(k,j) + temp1*A(k,i)
                  temp2 = temp2 + B(k,j)*A(k,i)
               ENDDO
               IF ( Beta==ZERO ) THEN
                  C(i,j) = temp1*A(i,i) + Alpha*temp2
               ELSE
                  C(i,j) = Beta*C(i,j) + temp1*A(i,i) + Alpha*temp2
               ENDIF
            ENDDO
         ENDDO
      ELSE
         DO j = 1 , N
            DO i = M , 1 , -1
               temp1 = Alpha*B(i,j)
               temp2 = ZERO
               DO k = i + 1 , M
                  C(k,j) = C(k,j) + temp1*A(k,i)
                  temp2 = temp2 + B(k,j)*A(k,i)
               ENDDO
               IF ( Beta==ZERO ) THEN
                  C(i,j) = temp1*A(i,i) + Alpha*temp2
               ELSE
                  C(i,j) = Beta*C(i,j) + temp1*A(i,i) + Alpha*temp2
               ENDIF
            ENDDO
         ENDDO
      ENDIF
!
!
!     End of ZSYMM .
!
      END SUBROUTINE ZSYMM


c     program DRDPRPL2
c>> 1996-06-27 DRDPRPL2  Krogh Special code for C conversion.
c>> 1994-10-19 DRDPRPL2  Krogh  Changes to use M77CON
c>> 1992-02-14 DRDPRPL2  CLL
c     ------------------------------------------------------------------
c--D replaces "?": DR?PRPL2, ?PRPL2
c     ------------------------------------------------------------------
      integer I, IERR, KC, LINE, NCMAX, NLMAX
      parameter(KC = 3, NLMAX = 45, NCMAX = 110)
      integer JX(KC), JY(KC), NP(KC)
      double precision DX, S, X, XY(15,4)
      character SYMBOL(KC)
c%%    long int ierr, line;
c%%    char image[45][111], image2[45][80];
      character IMAGE(NLMAX)*(NCMAX)
      data JX/1,1,1/
      data JY/2,3,4/
      data NP/15,15,15/
      data SYMBOL/'A','B','C'/
c     ------------------------------------------------------------------
      X = -3.14d0
      DX = 21.0d0/49.0d0
      do 10 I=1,15
        S = sin(X)
        XY(I,1) = X
        XY(I,2) = S+1.0d0 + 0.5d0*X
        XY(I,3) = 1.0d0 + 0.5d0*X
        XY(I,4) = S + 2.0d0 +X
        X = X+DX
   10 continue

c++ Code for ~.C. is active
      call DPRPL2(XY,15,KC,JX,JY,NP,SYMBOL,
     *   'Demo of DPRPL2 with NLINES = 45 and NCHARS = 110',
     *   'X VALUES','Y VALUES', 45, 110, IMAGE, IERR)
      print'(1x,a)',IMAGE
      print'(1x/1x)'
c
      call DPRPL2(XY,15,KC,JX,JY,NP,SYMBOL,
     *   'Demo of DPRPL2 with NLINES = 22 and NCHARS = 79',
     *   'X VALUES','Y VALUES', 22, 79, IMAGE, IERR)
      print'(1x,a)',(IMAGE(LINE)(1:79), LINE = 1,22)
c++ Code for .C. is inactive
c%%   dprpl2( (double*)xy, 15, KC, jx, jy, np, symbol,
c%%      "Demo of DPRPL2 with NLINES = 45 and NCHARS = 110",
c%%      "X VALUES", "Y VALUES", 45, 111, (byte*)image, &ierr );
c%%   for(line=0; line < 45; line++)
c%%      printf( "\n%111.111s", image[line] );
c%%   printf( " \n\n" );
c%%   dprpl2( (double*)xy, 15, KC, jx, jy, np, symbol,
c%%   "Demo of DPRPL2 with NLINES = 22 and NCHARS = 79",
c%%   "X VALUES", "Y VALUES", 22, 80, (byte*)image2, &ierr );
c%%   for (line = 0; line < 22; line++)
c%%      printf( "\n%80.80s", image2[line]);
c%%   printf( "\n" );
c++ End
      stop
      end


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

module eikonal

    use util
    use heap

    implicit none

    private
    public eikonal_solver_fmm

  contains

    subroutine eikonal_solver_fmm( speed, origin, delta, initialpoint, times )

      ! Fast marching level set method solver (sethian 1996)

      ! On a 2D-grid with spacing delta(2) and speeds 'speed' and a signal
      ! starting at initialpoint(2), calculate arrival times 'times'.

        real, dimension(:,:), intent(in)  :: speed
        real, dimension(2),   intent(in)  :: origin
        real, dimension(2),   intent(in)  :: delta
        real, dimension(2),   intent(in)  :: initialpoint
        real, dimension(:,:), intent(out) :: times

        integer :: nalive

        integer, dimension(size(speed,1),size(speed,2)) :: backpointers

      ! backpointers are set to two different invalid values:
        integer, parameter :: FARAWAY = -1
        integer, parameter :: ALIVE = 0

        type(t_index_heap) :: heap

        real :: dx,dy
        integer :: ix, iy, nx, ny
        integer :: imin
        real :: infinity

        infinity = huge(infinity) * 0.1

        nx = size(speed,1)
        ny = size(speed,2)
        dx = delta(1)
        dy = delta(2)

        if (size(times,1) /= nx .or. size(times,2) /= ny) then
            call die("eikonal_solver_fmm(): sizes of times and speed arrays do not match.")
        end if

      ! initialize

        backpointers(:,:) = FARAWAY

        ix = int((initialpoint(1)-origin(1))/dx) + 1
        iy = int((initialpoint(2)-origin(2))/dy) + 1

        if (ix < 1) ix = 1
        if (nx < ix) ix = nx
        if (iy < 1) iy = 1
        if (ny < iy) iy = ny

        times(:,:) = infinity

      ! alive points

        times(ix,iy) = 0.0
        if (nx==1 .and. ny==1) return

        backpointers(ix,iy) = ALIVE
        nalive = 1

      ! narrowband points

        call initheap( heap, nx*ny )

        if (1 < ix)  times(ix-1,iy) = dx/speed(ix-1,iy)
        if (ix < nx) times(ix+1,iy) = dx/speed(ix+1,iy)
        if (1 < iy)  times(ix,iy-1) = dy/speed(ix,iy-1)
        if (iy < ny) times(ix,iy+1) = dy/speed(ix,iy+1)

        if (1 < ix)  call pushheap( heap, ind(ix-1,iy), times, backpointers )
        if (ix < nx) call pushheap( heap, ind(ix+1,iy), times, backpointers )
        if (1 < iy)  call pushheap( heap, ind(ix,iy-1), times, backpointers )
        if (iy < ny) call pushheap( heap, ind(ix,iy+1), times, backpointers )

      ! propagate solution

        do while (nalive <= nx*ny)

          ! get the narrowband element with the smallest value for T
	      ! and make it alive

            call popheap( heap, imin, times, backpointers )
            if (imin == 0) exit
            ix = mod(imin-1,nx) + 1
            iy = (imin-1)/nx + 1
            backpointers(ix,iy) = ALIVE
            nalive = nalive + 1

          ! update neighbors
            if (1 < ix)  call update_neighbor(ix-1,iy)
            if (ix < nx) call update_neighbor(ix+1,iy)
            if (1 < iy)  call update_neighbor(ix,iy-1)
            if (iy < ny) call update_neighbor(ix,iy+1)

        end do

      contains

        subroutine update_neighbor(ix,iy)

            integer, intent(in) :: ix, iy
            real :: a,b,c,d,aa,cc
            real :: t, s, told
            integer :: i

            i = (iy-1)*nx+ix

            if (backpointers(ix,iy) .eq. ALIVE) return
            if (backpointers(ix,iy) .eq. FARAWAY) then
                call pushheap( heap, i, times, backpointers )
            end if

            a = infinity
            b = infinity
            c = infinity
            d = infinity

            told = times(ix,iy)

          ! values of t at neighbors
            if (1 < ix)  a = times(ix-1,iy)
            if (ix < nx) b = times(ix+1,iy)
            if (1 < iy)  c = times(ix,iy-1)
            if (iy < ny) d = times(ix,iy+1)

          ! pick maximum solution
            t = 0.
            aa = min(a,b)
            cc = min(c,d)
            if (max(aa,cc) /= infinity) then
                s = dx**2*dy**2*(dx**2+dy**2-((aa-cc)*speed(ix,iy))**2)
                if (s>=0.) then
                    t = max(t, ( (aa*dy**2+cc*dx**2)*speed(ix,iy)+sqrt(s) ) / &
                               ( speed(ix,iy)*(dx**2+dy**2) ) &
                           )
                end if
            end if
            if (min(c,d) == infinity) then
                if (a < infinity) t = max(t, a+dx/speed(ix,iy))
                if (b < infinity) t = max(t, b+dx/speed(ix,iy))
            end if
            if (min(a,b) == infinity) then
                if (c < infinity) t = max(t, c+dy/speed(ix,iy))
                if (d < infinity) t = max(t, d+dy/speed(ix,iy))
            end if

            if (t == 0.) then  ! fallback condition, should rarely happen.
                               ! may happen at sharp edges in speed function.
                t = infinity
                if (a < infinity) t = min(t, a+dx/speed(ix,iy))
                if (b < infinity) t = min(t, b+dx/speed(ix,iy))
                if (c < infinity) t = min(t, c+dy/speed(ix,iy))
                if (d < infinity) t = min(t, d+dy/speed(ix,iy))
            end if

            if (t /= 0. .and. told /= t) then
                call updateheap( heap, ind(ix,iy), t, times, backpointers )
            end if

        end subroutine

        function ind(ixl,iyl)
            integer, intent(in) :: ixl, iyl
            integer :: ind

            ind = (iyl-1)*nx+ ixl

        end function

    end subroutine

end module


module tsunami_arrival_time_mod
    !!
    !! Computing tsunami arrival times, maxima, and exceedance-rates for
    !! tsunami scenarios with "maxima >= wave_threshold" and "arrival_time <= time_threshold"
    !!
    use iso_c_binding, only: C_DOUBLE, C_INT
    implicit none

    integer, parameter :: dp = C_DOUBLE, ip = C_INT
        !! Control precision of reals and integers by using real(dp) and integer(ip)

    contains

    subroutine tsunami_arrival_time_and_maxima_f(n, stage, time, msl, arrival_fraction_of_maxima, &
        tsunami_maxima, tsunami_arrival_time) bind(C, name='tsunami_arrival_time_and_maxima_fortran')
        !!
        !! Given a tsunami time-series, and a definition of the mean-sea-level and arrival time
        !! (determined as a fraction of the tsunami maxima), compute the tsunami arrival time and maxima.
        !!
        integer(ip), intent(in) :: n
            !! Length of stage(:) and time(:)
        real(dp), intent(in) :: stage(n)
            !! Array of tsunami stage values (in m). The tsunami waveform is taken to be (stage - msl).
        real(dp), intent(in) :: time(n)
            !! Array of times (seconds post-earthquake) with length equal to stage
        real(dp), intent(in) ::  msl(1)
            !! Value of mean sea level (typically 0.0_dp), used to define the tsunami waveform as (stage - msl)
        real(dp), intent(in) ::  arrival_fraction_of_maxima(1)
            !! The arrival time is defined as the first time that (stage - msl) >= (arrival_fraction_of_maxima * tsunami_maxima)
        real(dp), intent(out) :: tsunami_maxima(1)
            !! Output tsunami maxima ( maxval(stage) - msl )
        real(dp), intent(out) :: tsunami_arrival_time(1)
            !! Output the first time when the (stage - msl) >= (arrival_fraction_of_maxima * tsunami_maxima)

        real(dp) :: arrival_stage_threshold
        integer(ip) :: i, arrival_index

        if((arrival_fraction_of_maxima(1) > 1.0_dp) .or. (arrival_fraction_of_maxima(1) < 0.0_dp)) then
            !stop 'arrival_fraction_of_maxima must be within [0.0, 1.0]'
            tsunami_maxima(1) = -HUGE(1.0_dp)
            tsunami_arrival_time(1) = -HUGE(1.0_dp)
            return
        end if

        tsunami_maxima(1) = maxval(stage) - msl(1)

        ! The tsunami arrival is defined by the stage exceedng this value
        arrival_stage_threshold = arrival_fraction_of_maxima(1) * tsunami_maxima(1) + msl(1)

        ! Find the index when the tsunami arrives
        do i = 1, size(stage)
            if( stage(i) >= arrival_stage_threshold) then
                arrival_index = i
                exit
            end if
        end do

        !if(size(time) == 1) then
        !    ! Case where time(1) gives the timestep
        !    tsunami_arrival_time = (arrival_index - 1)*time(1)
        !else if(size(time) == size(stage)) then
            ! Case where time(:) is an array of times
            tsunami_arrival_time(1) = time(arrival_index)
        !else
        !    stop ' "time" must either be an array of times with length equal to "stage", ' // &
        !         'or an array of length=1 giving the timestep'
        !endif

    end subroutine

    subroutine exceedance_rate_given_maxima_and_arrival_time_f(ns, scenario_maxima, scenario_arrival_times, scenario_rates, &
            nmax, tsunami_maxima_in_output, narrival, arrival_times_in_output, output_exceedance_rate_by_maxima_time) &
            bind(C, name='exceedance_rate_given_maxima_and_arrival_time_fortran')
            !!
            !! Suppose we have a set of scenarios with known maxima, arrival_times, and occurrance rates.
            !! This routine computes a matrix of exceedance_rates, for every combination of "tsunami_maxima_in_output"
            !! and "arrival_times_in_output".
            !!
        integer(ip), intent(in) :: ns
            !! Number of scenarios, size of scenario_maxima, scenario_arrival_times, scenario_rates
        real(dp), intent(in) :: scenario_maxima(ns)
            !! The tsunami maxima for each scenario
        real(dp), intent(in) :: scenario_arrival_times(ns)
            !! The arrival time for each scenario
        real(dp), intent(in) :: scenario_rates(ns)
            !! The occurrance rate of each individual scenario (events/year). So sum(scenario_rates) gives the rate of any scenario,
            !! and (scenario_rates)/sum(scenario_rates) gives the scenario conditional probabilitiy
        integer(ip), intent(in) :: nmax
            !! size of the tsunami_maxima_in_output array
        real(dp), intent(in) :: tsunami_maxima_in_output(nmax)
            !! The tsunami maxima for which we wish to compute exceedance-rates for the given arrival times
        integer(ip), intent(in) :: narrival
            !! size of the arrival_times_in_output array
        real(dp), intent(in) :: arrival_times_in_output(narrival)
            !! The arrival times for which we wish to compute nonexceedance-rates for the given tsunami maxima
        real(dp), intent(out) :: output_exceedance_rate_by_maxima_time(nmax, narrival)
            !! On output, the i,j entry of this matrix will contain
            !!    sum(scenario_rates, &
            !!        mask=( (scenario_maxima >= tsunami_maxima_in_output(i)) &
            !!               (scenario_arrival_times <= arrival_times_in_output(j)) )
            !! NOTE the use of ">=" for scenario_maxima, but "<=" for arrival times. The idea is that large maxima, and small
            !! arrivals, are both "bad". Then this sign convention might be more useful (?).

        integer(ip) :: i, j

        !if(any(shape(output_exceedance_rate_by_maxima_time) /= &
        !     [size(tsunami_maxima_in_output), size(arrival_times_in_output)])) then
        !     stop ' Wrong shape for output exceedance_rate matrix '
        ! end if

        !if((size(scenario_maxima) /= size(scenario_arrival_times)) .or. &
        !   (size(scenario_rates)  /= size(scenario_arrival_times)) ) then
        !    stop 'scenario_maxima, scenario_rates, and scenario_arrival_times must all have the same size'
        !end if

        ! Compute the exceedance-rate for every pair of tsunami_maxima_in_output, arrival_times_in_output
        do i = 1, size(tsunami_maxima_in_output)
            do j = 1, size(arrival_times_in_output)
                ! This calculation might be sped-up with clever pre-sorting of data. But I doubt it will
                ! matter in the applications of interest.
                 output_exceedance_rate_by_maxima_time(i,j) = sum(scenario_rates, &
                     mask = ( (scenario_maxima >= tsunami_maxima_in_output(i)) .and. &
                              (scenario_arrival_times <= arrival_times_in_output(j))))
            end do
        end do

    end subroutine

end module


!===============================================================================
! One of Andy Nowacki's Fortran utility modules for dealing with seismic
! anisotropy and other problems.
!
! Andy Nowacki <andy.nowacki@bristol.ac.uk>
!
! See the file LICENCE for licence details.
!===============================================================================
program pitl
!===============================================================================
!  Wrapper to the CIJ_pitl routine.
!  The program computes the effective long-wavelength anisotropic equivalent
!  constants for a periodic, isotropic thin-layered medium, where two alternating
!  layers of constant relative thickness d1/(d1+d2) and d2/(d1+d2) are present.

   use anisotropy_ajn, only: CIJ_pitl

   implicit none

   integer, parameter :: rs = 8
   real(rs) :: C(6,6), vp1, vp2, vs1, vs2, d1, d2, rho1, rho2
   character(len=250) :: arg
   integer :: iostat, narg

   ! Get command line arguments if any
   narg = command_argument_count()
   if (narg /= 0 .and. narg /= 8) call usage

   if (narg == 0) then
      iostat = 0
      do while (iostat == 0)
         read(*,*,iostat=iostat) d1, vp1, vs1, rho1, d2, vp2, vs2, rho2
         if (iostat < 0) exit
         if (iostat > 0) then
            write(0,'(a)') 'CIJ_pitl: Error: Can''t get d1,Vp1,Vs1,rho1,d2,Vp2,Vs2,rho2 from stdin'
            stop 1
         endif
         call get_ptl_vals
         call output
      enddo

   else
      call get_arg(1, 'd1',   d1)
      call get_arg(2, 'vp1',  vp1)
      call get_arg(3, 'vs1',  vs1)
      call get_arg(4, 'rho1', rho1)
      call get_arg(5, 'd2',   d2)
      call get_arg(6, 'vp2',  vp2)
      call get_arg(7, 'vs2',  vs2)
      call get_arg(8, 'rho2', rho2)
      call get_ptl_vals
      call output
   endif

contains
   subroutine get_ptl_vals
      C = CIJ_pitl(d1, vp1, vs1, rho1, d2, vp2, vs2, rho2)
   end subroutine get_ptl_vals

   subroutine usage
      write(0,'(a)') &
         'Usage CIJ_pitl [d1] [Vp1] [Vs1] [rho1] [d2] [Vp2] [Vs2] [rho2]', &
         '      CIJ_pitl < ([d1] [Vp1] [Vs1] [rho1] [d2] [Vp2] [Vs2] [rho2] on stdin)', &
         'Calculate the long-wavelength equivalent elastic constants for a medium', &
         'made up of periodic layering of two isotropic layers, 1 and 2, where the', &
         'relative widths of the layers are d1 and d2.', &
         'Vp, Vs and rho are the P- and S-wave velocities and densities, respectively.', &
         'Uses formulae as given by Postma (1955), Geophysics, 20, 780-806.'
      stop 1
   end subroutine usage

   subroutine get_arg(i, name, var)
      integer, intent(in) :: i
      character(len=*), intent(in) :: name
      real(rs), intent(out) :: var
      call get_command_argument(i, arg)
      read(arg,*,iostat=iostat) var
      if (iostat /= 0) then
         write(0,'(a)') 'CIJ_pitl: Error: Can''t read value of '//trim(name) &
            //'from argument "'//trim(arg)//'"'
         stop 1
      endif
   end subroutine get_arg

   subroutine output
      write(*,*) C
   end subroutine output
end program pitl
!-------------------------------------------------------------------------------


SUBROUTINE ConstructTableCrossDerivatives_Curvilinear(CompGrid, DiffStencils, kappa, GhostGridX, GhostGridY, GhostGridZ)
! By Allan P. Engsig-Karup.
USE Precision
USE Constants
USE DataTypes
IMPLICIT NONE
TYPE (Level_def), INTENT(IN) :: CompGrid
TYPE (Diff_def)  :: DiffStencils
INTEGER :: alpha, beta, kappa, i, j, k, diffa, diffb, diffg, rank,ranka,rankb, Nxg, Nyg, Nzg, GhostGridX, GhostGridY, GhostGridZ
!
INTEGER, DIMENSION(2*kappa+1) :: idx, idxa, idxb, idxg
INTEGER :: Gidx
! GD: to exclude corner ghost points, define a global matrix clearer and more efficient?
INTEGER :: idxa_c, idxb_c, idxg_c, idxa_c2, idxb_c2, idxg_c2
! Local variables...
REAL(KIND=long), DIMENSION(2*kappa+1,2) :: stencilweightsZ
INTEGER, DIMENSION(CompGrid%Nz+GhostGridZ,CompGrid%Nx+2*GhostGridX,CompGrid%Ny+2*GhostGridY) :: L

Nxg = CompGrid%Nx + 2*GhostGridX
Nyg = CompGrid%Ny + 2*GhostGridY
Nzg = CompGrid%Nz + GhostGridZ

rank = 2*kappa+1
! ALLOCATE the corresponding DiffStencils elements... (assumed here that rank=ranka=rankb...)
ALLOCATE(DiffStencils%IndexesX_XZorXY(CompGrid%Nz+GhostGridZ,CompGrid%Nx+2*GhostGridX,CompGrid%Ny+2*GhostGridY,rank,2))
ALLOCATE(DiffStencils%IndexesY_YZorXY(CompGrid%Nz+GhostGridZ,CompGrid%Nx+2*GhostGridX,CompGrid%Ny+2*GhostGridY,rank,2))
ALLOCATE(DiffStencils%IndexesZ_XZorYZ(CompGrid%Nz+GhostGridZ,CompGrid%Nx+2*GhostGridX,CompGrid%Ny+2*GhostGridY,rank,2))
ALLOCATE(DiffStencils%StencilsX_XZorXY(CompGrid%Nz+GhostGridZ,CompGrid%Nx+2*GhostGridX,CompGrid%Ny+2*GhostGridY,rank,2))
ALLOCATE(DiffStencils%StencilsY_YZorXY(CompGrid%Nz+GhostGridZ,CompGrid%Nx+2*GhostGridX,CompGrid%Ny+2*GhostGridY,rank,2))
ALLOCATE(DiffStencils%StencilsZ_XZorYZ(CompGrid%Nz+GhostGridZ,CompGrid%Nx+2*GhostGridX,CompGrid%Ny+2*GhostGridY,rank,2))
!
idxa(1:rank)=0
idxb(1:rank)=0
idxg(1:rank)=0

DO i = -kappa, kappa
	idx(i+kappa+1) = i
END DO
!
IF (Nxg>1) THEN
	alpha = kappa
	ranka = rank
ELSE
	alpha = 0
	ranka = 1
END IF
IF (Nyg>1) THEN
	beta  = kappa
	rankb = rank
ELSE
	beta  = 0
	rankb = 1
END IF
! Generate array with global indices for every point in the domain
Gidx = 0
DO j = 1,Nyg
	DO i = 1, Nxg
		DO k = 1,Nzg
			Gidx = Gidx + 1
			L(k,i,j) = Gidx
		END DO
	END DO
END DO
!
idxa_c=0
idxb_c=0
idxg_c=0
idxa_c2=0
idxb_c2=0
idxg_c2=0
!
! Construction of the Indexes and Stencils needed
!
DO j = 1, Nyg !1+GhostGridY , Nyg-GhostGridY !
    IF (j<beta+1) THEN
        diffb = beta + 1 - j
    ELSE IF (j > Nyg - beta) THEN
        diffb = (Nyg - beta) - j
    ELSE
        diffb = 0
    ENDIF
    idxb = j + idx + diffb

    DO i = 1, Nxg !   1+GhostGridX , Nxg-GhostGridX !
        idxa_c2 = 0
        idxb_c2 = 0
        !
        IF (i<alpha+1) THEN
            diffa = alpha + 1 - i
        ELSE IF (i > Nxg - alpha) THEN
            diffa = (Nxg - alpha) - i
        ELSE
            diffa = 0
        ENDIF
        idxa = i + idx + diffa
        !
        IF ((j==1).OR.(j==Nyg)) THEN
          IF(idxa(1)==1) THEN
        	idxa_c2 = 1
          ENDIF
          IF(idxa(ranka)==Nxg) THEN
        	idxa_c2 = -1
          ENDIF
       ENDIF
       IF ((i==1).OR.(i==Nxg)) THEN
          IF(idxb(1)==1) THEN
        	idxb_c2 = 1
          ENDIF
          IF(idxb(rankb)==Nyg) THEN
        	idxb_c2 = -1
          ENDIF
       ENDIF
       !
        IF ((i == 1).OR.(i==Nxg)) THEN
            idxa_c2 = 0
        ENDIF
        IF ((j == 1).OR.(j==Nyg)) THEN
            idxb_c2 = 0
        ENDIF

        DO k = 1, Nzg ! 1+GhostGridZ , Nzg-1 !
           idxg_c  = 0
           idxg_c2 = 0
           idxa_c  = 0
           idxb_c  = 0
           !
           IF (k<kappa+1) THEN
                diffg = kappa + 1 - k
           ELSE IF (k > Nzg - kappa) THEN
                diffg = (Nzg - kappa) - k
           ELSE
                diffg = 0
           ENDIF
           idxg = k + idx + diffg
           !
           IF ((i==1).OR.(i==Nxg)) THEN
              IF(idxg(1)==1) THEN
                idxg_c = 1
              ENDIF
              ! We can use the ghost points on the FS (but not on the bottom: corner points not solved during resolution)
              !IF(idxg(rank)==Nzg) THEN
              !  idxg_c = -1
              !ENDIF
           ENDIF
		   IF ((j==1).OR.(j==Nyg)) THEN
              IF(idxg(1)==1) THEN
                idxg_c2 = 1
              ENDIF
              ! We can use the ghost points on the FS (but not on the bottom: corner points not solved during resolution)
              !IF(idxg(rank)==Nzg) THEN
              !  idxg_c2 = -1
              !ENDIF
           ENDIF
           !IF ((k==1).OR.(k==Nzg)) THEN
           IF ((k==1)) THEN  ! We can use the ghost points on the FS (but not on the bottom: corner points not solved during resolution)
              IF(idxa(1)==1) THEN
                idxa_c = 1
              ENDIF
              IF(idxa(ranka)==Nxg) THEN
                idxa_c = -1
              ENDIF
              IF(idxb(1)==1) THEN
                idxb_c = 1
              ENDIF
              IF(idxb(rankb)==Nyg) THEN
                idxb_c = -1
              ENDIF
           ENDIF
           !
           IF ((i == 1).OR.(i==Nxg)) THEN
            idxa_c = 0
           ELSE ! FIXME: This test has to be checked...
			!idxb_c  = 0
            !idxg_c2 = 0
            !IF (k == Nzg) THEN ! We can use the ghost points on the FS (but not on the bottom: corner points not solved during resolution)
            !   idxb_c  = 0
            !   idxg_c2 = 0
            !ENDIF
           ENDIF
           IF ((j == 1).OR.(j==Nyg)) THEN
            idxb_c = 0
           ELSE ! FIXME: This test has to be checked...
             !idxa_c = 0
             !idxg_c = 0
             !IF (k == Nzg) THEN ! We can use the ghost points on the FS (but not on the bottom: corner points not solved during resolution)
             !  idxa_c = 0
             !  idxg_c = 0
             !ENDIF
           ENDIF
           IF ((k == 1).OR.(k==Nzg)) THEN
            idxg_c = 0
            idxg_c2 = 0
           ELSE ! FIXME: This test has to be checked...
             ! Nothing to do because the corner edges are not resolved...
           ENDIF
           !test...
           !idxa_c=0;idxb_c=0;idxg_c=0;idxg_c2=0
           !idxa_c2=0;idxb_c2=0
           !
           ! For correction in XY derivative...
           !
           ! IndexesX in XY derivatives
           DiffStencils%IndexesX_XZorXY(k,i,j,1:ranka,2) = idxa(1:ranka)+idxa_c2
           ! IndexesY in XY derivatives
           DiffStencils%IndexesY_YZorXY(k,i,j,1:rankb,2) = idxb(1:rankb)+idxb_c2
           ! StencilsX in XY derivatives
           DiffStencils%StencilsX_XZorXY(k,i,j,1:ranka,2) = DiffStencils%StencilG(1:ranka,kappa+1-diffa-idxa_c2,1)
           ! StencilsY in XY derivatives
           DiffStencils%StencilsY_YZorXY(k,i,j,1:rankb,2) = DiffStencils%StencilG(1:rankb,kappa+1-diffb-idxb_c2,1)
           !
           ! For correction in XZ derivative...
           !
           ! IndexesX in XZ derivatives
           DiffStencils%IndexesX_XZorXY(k,i,j,1:ranka,1) = idxa(1:ranka)+idxa_c
           ! IndexesZ in XZ derivatives
           DiffStencils%IndexesZ_XZorYZ(k,i,j,1:rank,1) = idxg(1:rank)+idxg_c
           ! StencilsX in XZ derivatives
           DiffStencils%StencilsX_XZorXY(k,i,j,1:ranka,1) = DiffStencils%StencilG(1:ranka,kappa+1-diffa-idxa_c,1)
           ! StencilsZ in XZ derivatives
           IF (idxg_c == 0) THEN
            	!do nothing (Initial)
                stencilweightsZ = CompGrid%DiffStencils%StencilZ(k,1:rank,1:2)
           ELSE
              CALL DiffStencilsZ_modif(k,CompGrid%z,stencilweightsZ,CompGrid%Nz,GhostGridZ,kappa,idxg_c)
           ENDIF
           DiffStencils%StencilsZ_XZorYZ(k,i,j,1:rank,1) = stencilweightsZ(1:rank,1)
           !
           ! For correction in YZ derivative...
           !
           ! IndexesY in YZ derivatives
           DiffStencils%IndexesY_YZorXY(k,i,j,1:rankb,1) = idxb(1:rankb)+idxb_c
           ! IndexesZ in YZ derivatives
           DiffStencils%IndexesZ_XZorYZ(k,i,j,1:rank,2) = idxg(1:rank)+idxg_c2
          ! StencilsY in YZ derivatives
           DiffStencils%StencilsY_YZorXY(k,i,j,1:rankb,1) = DiffStencils%StencilG(1:rankb,kappa+1-diffb-idxb_c,1)
           ! StencilsZ in YZ derivatives
           IF (idxg_c2 == 0) THEN
                 !do nothing (initial)
                 stencilweightsZ = CompGrid%DiffStencils%StencilZ(k,1:rank,1:2)
           ELSE
              CALL DiffStencilsZ_modif(k,CompGrid%z,stencilweightsZ,CompGrid%Nz,GhostGridZ,kappa,idxg_c2)
           ENDIF
           DiffStencils%StencilsZ_XZorYZ(k,i,j,1:rank,2) = stencilweightsZ(1:rank,1)
       ENDDO
   ENDDO
ENDDO

END SUBROUTINE ConstructTableCrossDerivatives_Curvilinear


!========================================================================
!
!                   S P E C F E M 2 D  Version 7 . 0
!                   --------------------------------
!
!     Main historical authors: Dimitri Komatitsch and Jeroen Tromp
!                        Princeton University, USA
!                and CNRS / University of Marseille, France
!                 (there are currently many more authors!)
! (c) Princeton University and CNRS / University of Marseille, April 2014
!
! This software is a computer program whose purpose is to solve
! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
! using a spectral-element method (SEM).
!
! This program is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 2 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License along
! with this program; if not, write to the Free Software Foundation, Inc.,
! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
!
! The full text of the license is available in file "LICENSE".
!
!========================================================================

  subroutine setup_GLL_points()

! computes shape functions and their derivatives for SEM grid

  use specfem_par

  implicit none

  ! local parameters
  integer :: i,j,ier

  ! set up Gauss-Lobatto-Legendre points, weights and also derivation matrices (hprime_**,..)
  call define_derivation_matrices()

  if (AXISYM) then
    ! set up Gauss-Lobatto-Jacobi points, weights and also derivation matrices
    call define_GLJ_derivation_matrix()
  endif

  ! shape arrays
  allocate(shape2D(ngnod,NGLLX,NGLLZ), &
           dershape2D(NDIM,ngnod,NGLLX,NGLLZ),stat=ier)
  if (ier /= 0) stop 'Error allocating shape arrays'

  do j = 1,NGLLZ
    do i = 1,NGLLX
      call define_shape_functions(shape2D(:,i,j),dershape2D(:,:,i,j),xigll(i),zigll(j),ngnod)
    enddo
  enddo

  ! allocate 1-D Lagrange interpolators and derivatives
  ! for source and receivers
  allocate(hxir(NGLLX), &
           hxis(NGLLX), &
           hpxir(NGLLX), &
           hpxis(NGLLX), &
           hgammar(NGLLZ), &
           hgammas(NGLLZ), &
           hpgammar(NGLLZ), &
           hpgammas(NGLLZ),stat=ier)
  if (ier /= 0) stop 'error allocating arrays for interpolators'

  end subroutine setup_GLL_points


      SUBROUTINE EZFFTB (N,R,AZERO,A,B,WSAVE)
      DIMENSION       R(1)       ,A(1)       ,B(1)       ,WSAVE(1)
      IF (N-2) 101,102,103
  101 R(1) = AZERO
      RETURN
  102 R(1) = AZERO+A(1)
      R(2) = AZERO-A(1)
      RETURN
  103 NS2 = (N-1)/2
      DO 104 I=1,NS2
         R(2*I) = .5*A(I)
         R(2*I+1) = -.5*B(I)
  104 CONTINUE
      R(1) = AZERO
      IF (MOD(N,2) .EQ. 0) R(N) = A(NS2+1)
      CALL RFFTB (N,R,WSAVE(N+1))
      RETURN
      END


PROGRAM MAIN

  USE omp_lib

  ! Size of grid and number of iterations
  INTEGER, PARAMETER :: N = 30000, T =10
  INTEGER, PARAMETER :: M = 5 ! DO NOT change M without changing setup below!
  REAL, DIMENSION(:), ALLOCATABLE :: grid, forces
  REAL, DIMENSION(:), ALLOCATABLE :: posns
  INTEGER :: it, ix, ib, ix_f
  LOGICAL :: show = .FALSE.
  REAL :: force_retention = 0.1

  ! Grid of "potential" and grid for forces
  ! Use spare cells on potential grid that never update
  ALLOCATE(grid(0:N+1), forces(N))
  ALLOCATE(posns(5))

  grid = 0.0

  ! Make all grid edges value 1
  grid(0)   = 1.0
  grid(N+1) = 1.0

  ! Pick some "random" positions for the M blobs
  ! And place blobs on grid
  DO ib = 1, M
    posns(ib) = (REAL(N)/2.0) - (REAL(M)/2.0) + REAL(ib)
    grid(NINT(posns(ib))) = 1.0
  END DO

  IF(show) THEN
  ! Show to screen
    PRINT*, "_________________________________"
    PRINT*, "Time =", 0
    PRINT*, "_________________________________"
    PRINT*, MERGE('*', ' ', grid(:) > 0.0)
    PRINT*, "_________________________________"
  END IF

  !Iterate over time
  DO it = 1, T

    ! Damp out previous forces. If we reset to 0 we get a minimisation
    ! If just damp, we get some oscillations
!$OMP PARALLEL DO
    DO ix = 1, N
      forces(ix) = forces(ix) * force_retention
    END DO
!$OMP END PARALLEL DO
    ! Only apply forces within the domain, but make sure to include those
    ! from the edge cells!
!$OMP PARALLEL DO SCHEDULE(static, 1)
    DO ix = 1, N
       DO ix_f = 0, N+1
            IF(ix == ix_f) CYCLE
            ! Force falls off as square of distance
            forces(ix) = forces(ix) + grid(ix_f)/REAL(ix-ix_f)**2 &
                    * SIGN(1, ix-ix_f)
! NOTE : calculating all the forces like this is inefficient, but suppose for thi
! example that we have a good reason for it! For instance, imagine we really want
! the persistence of the forces or something
        END DO
    END DO
!$OMP END PARALLEL DO
   ! Zero out grid before moving and re-placing blobs
    grid(1:N) = 0.0

    ! Push blobs according to forces
    DO ib = 1, M
      ! Include a factor for how rapidly the "forces" move the "blobs"
      posns(ib) = posns(ib) + forces(NINT(posns(ib)))*0.9
      ! Forcibly keep in grid
      IF(posns(ib) < 1 ) posns(ib) = 1
      IF(posns(ib) >= N ) posns(ib) = N

      ! Place blob in new position
      grid(NINT(posns(ib))) = 1.0
    END DO

    IF(show) THEN
      ! Show to screen
            PRINT*, "_________________________________"
            PRINT*, "Time =", it
            PRINT*, "_________________________________"
            PRINT*, MERGE('*', ' ', grid(:) > 0.0)
            PRINT*, "_________________________________"
    END IF

  END DO

END PROGRAM


*     MD03BD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER           NIN, NOUT
      PARAMETER         ( NIN = 5, NOUT = 6 )
      INTEGER           MMAX, NMAX
      PARAMETER         ( MMAX = 20, NMAX = 20 )
      INTEGER           LDWORK
      PARAMETER         ( LDWORK = MMAX +
     $                             MAX( MMAX*NMAX + 5*NMAX + 1,
     $                                  NMAX*NMAX + NMAX +
     $                                  MAX( MMAX, 5*NMAX ) ) )
*     .. Local Scalars ..
      CHARACTER*1       COND, SCALE, XINIT
      INTEGER           I, INFO, ITMAX, IWARN, LDPAR1, LDPAR2, LIPAR, M,
     $                  N, NFEV, NJEV, NPRINT
      DOUBLE PRECISION  FACTOR, FTOL, GTOL, TOL, XTOL
*     .. Array Arguments ..
      INTEGER           IPAR(5), IWORK(NMAX+1)
      DOUBLE PRECISION  DIAG(NMAX), DPAR1(1), DPAR2(1), DWORK(LDWORK),
     $                  X(NMAX)
*     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
*     .. External Subroutines ..
      EXTERNAL          MD03BA, MD03BB, MD03BD, MD03BF
*     .. Intrinsic Functions ..
      INTRINSIC         MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) M, N, ITMAX, LIPAR, LDPAR1, LDPAR2, FACTOR,
     $                      NPRINT, FTOL, XTOL, GTOL, TOL, XINIT, SCALE,
     $                      COND
      IF( M.LE.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) M
      ELSE
         IF( N.LE.0 .OR. N.GT.NMAX ) THEN
            WRITE ( NOUT, FMT = 99992 ) N
         ELSE
            IF ( LSAME( SCALE, 'S' ) )
     $         READ ( NIN, FMT = * ) ( DIAG(I), I = 1,N )
            IF ( LSAME( XINIT, 'G' ) )
     $         READ ( NIN, FMT = * ) ( X(I), I = 1,N )
*           Solve a standard nonlinear least squares problem.
            IPAR(1) = M
            CALL MD03BD( XINIT, SCALE, COND, MD03BF, MD03BA, MD03BB,
     $                   M, N, ITMAX, FACTOR, NPRINT, IPAR, LIPAR,
     $                   DPAR1, LDPAR1, DPAR2, LDPAR2, X, DIAG, NFEV,
     $                   NJEV, FTOL, XTOL, GTOL, TOL, IWORK, DWORK,
     $                   LDWORK, IWARN, INFO )
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               IF( IWARN.NE.0) WRITE ( NOUT, FMT = 99991 ) IWARN
               WRITE ( NOUT, FMT = 99997 ) DWORK(2)
               WRITE ( NOUT, FMT = 99996 ) NFEV, NJEV
               WRITE ( NOUT, FMT = 99994 )
               WRITE ( NOUT, FMT = 99995 ) ( X(I), I = 1, N )
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' MD03BD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MD03BD = ',I2)
99997 FORMAT (/' Final 2-norm of the residuals = ',D15.7)
99996 FORMAT (/' The number of function and Jacobian evaluations = ',
     $           2I7)
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (/' Final approximate solution is ' )
99993 FORMAT (/' M is out of range.',/' M = ',I5)
99992 FORMAT (/' N is out of range.',/' N = ',I5)
99991 FORMAT (' IWARN on exit from MD03BD = ',I2)
      END
C
      SUBROUTINE MD03BF( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2,
     $                   LDPAR2, X, NFEVL, E, J, LDJ, DWORK, LDWORK,
     $                   INFO )
C
C     This is the FCN routine for solving a standard nonlinear least
C     squares problem using SLICOT Library routine MD03BD. See the
C     argument FCN in the routine MD03BD for the description of
C     parameters.
C
C     The example programmed in this routine is adapted from that
C     accompanying the MINPACK routine LMDER.
C
C     ******************************************************************
C
C     .. Parameters ..
C     .. NOUT is the unit number for printing intermediate results ..
      INTEGER           NOUT
      PARAMETER         ( NOUT = 6 )
      DOUBLE PRECISION  ONE
      PARAMETER         ( ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           IFLAG, INFO, LDJ, LDPAR1, LDPAR2, LDWORK, LIPAR,
     $                  M, N, NFEVL
C     .. Array Arguments ..
      INTEGER           IPAR(*)
      DOUBLE PRECISION  DPAR1(*), DPAR2(*), DWORK(*), E(*), J(LDJ,*),
     $                  X(*)
C     .. Local Scalars ..
      INTEGER           I
      DOUBLE PRECISION  ERR, TMP1, TMP2, TMP3, TMP4
C     .. External Functions ..
      DOUBLE PRECISION  DNRM2
      EXTERNAL          DNRM2
C     .. External Subroutines ..
      EXTERNAL          MD03BA, MD03BB
C     .. DATA Statements ..
      DOUBLE PRECISION  Y(15)
      DATA              Y(1), Y(2), Y(3), Y(4), Y(5), Y(6), Y(7), Y(8),
     $                  Y(9), Y(10), Y(11), Y(12), Y(13), Y(14), Y(15)
     $                  / 1.4D-1, 1.8D-1, 2.2D-1, 2.5D-1, 2.9D-1,
     $                    3.2D-1, 3.5D-1, 3.9D-1, 3.7D-1, 5.8D-1,
     $                    7.3D-1, 9.6D-1, 1.34D0, 2.1D0,  4.39D0 /
C
C     .. Executable Statements ..
C
      INFO = 0
      IF ( IFLAG.EQ.1 ) THEN
C
C        Compute the error function values.
C
         DO 10 I = 1, 15
            TMP1 = I
            TMP2 = 16 - I
            IF ( I.GT.8 ) THEN
               TMP3 = TMP2
            ELSE
               TMP3 = TMP1
            END IF
            E(I) = Y(I) - ( X(1) + TMP1/( X(2)*TMP2 + X(3)*TMP3 ) )
   10    CONTINUE
C
      ELSE IF ( IFLAG.EQ.2 ) THEN
C
C        Compute the Jacobian.
C
         DO 30 I = 1, 15
            TMP1 = I
            TMP2 = 16 - I
            IF ( I.GT.8 ) THEN
               TMP3 = TMP2
            ELSE
               TMP3 = TMP1
            END IF
            TMP4 = ( X(2)*TMP2 + X(3)*TMP3 )**2
            J(I,1) = -ONE
            J(I,2) = TMP1*TMP2/TMP4
            J(I,3) = TMP1*TMP3/TMP4
   30    CONTINUE
C
         NFEVL = 0
C
      ELSE IF ( IFLAG.EQ.3 ) THEN
C
C        Set the parameter LDJ, the length of the array J, and the sizes
C        of the workspace for MD03BF (IFLAG = 1 or 2), MD03BA and MD03BB.
C
         LDJ = M
         IPAR(1) = M*N
         IPAR(2) = 0
         IPAR(3) = 0
         IPAR(4) = 4*N + 1
         IPAR(5) = 4*N
      ELSE IF ( IFLAG.EQ.0 ) THEN
C
C        Special call for printing intermediate results.
C
         ERR = DNRM2( M, E, 1 )
         WRITE( NOUT, '('' Norm of current error = '', D15.6)') ERR
C
      END IF
C
      RETURN
C
C *** Last line of MD03BF ***
      END
C
      SUBROUTINE MD03BA( N, IPAR, LIPAR, FNORM, J, LDJ, E, JNORMS,
     $                   GNORM, IPVT, DWORK, LDWORK, INFO )
C
C     This is the QRFACT routine for solving a standard nonlinear least
C     squares problem using SLICOT Library routine MD03BD. See the
C     argument QRFACT in the routine MD03BD for the description of
C     parameters.
C
C     For efficiency, the arguments are not checked. This is done in
C     the routine MD03BX (except for LIPAR).
C
C     ******************************************************************
C
C     .. Scalar Arguments ..
      INTEGER           INFO, LDJ, LDWORK, LIPAR, N
      DOUBLE PRECISION  FNORM, GNORM
C     .. Array Arguments ..
      INTEGER           IPAR(*), IPVT(*)
      DOUBLE PRECISION  DWORK(*), E(*), J(LDJ,*), JNORMS(*)
C     .. External Subroutines ..
      EXTERNAL          MD03BX
C     ..
C     .. Executable Statements ..
C
      CALL MD03BX( IPAR(1), N, FNORM, J, LDJ, E, JNORMS, GNORM, IPVT,
     $             DWORK, LDWORK, INFO )
      RETURN
C
C *** Last line of MD03BA ***
      END
C
      SUBROUTINE MD03BB( COND, N, IPAR, LIPAR, R, LDR, IPVT, DIAG, QTB,
     $                   DELTA, PAR, RANKS, X, RX, TOL, DWORK, LDWORK,
     $                   INFO )
C
C     This is the LMPARM routine for solving a standard nonlinear least
C     squares problem using SLICOT Library routine MD03BD. See the
C     argument LMPARM in the routine MD03BD for the description of
C     parameters.
C
C     For efficiency, the arguments are not checked. This is done in
C     the routine MD03BY (except for LIPAR).
C
C     ******************************************************************
C
C     .. Scalar Arguments ..
      CHARACTER         COND
      INTEGER           INFO, LDR, LDWORK, LIPAR, N
      DOUBLE PRECISION  DELTA, PAR, TOL
C     .. Array Arguments ..
      INTEGER           IPAR(*), IPVT(*), RANKS(*)
      DOUBLE PRECISION  DIAG(*), DWORK(*), QTB(*), R(LDR,*), RX(*), X(*)
C     .. External Subroutines ..
      EXTERNAL          MD03BY
C     ..
C     .. Executable Statements ..
C
      CALL MD03BY( COND, N, R, LDR, IPVT, DIAG, QTB, DELTA, PAR,
     $             RANKS(1), X, RX, TOL, DWORK, LDWORK, INFO )
      RETURN
C
C *** Last line of MD03BB ***
      END


      subroutine GZHqaggvsqPoles(p,sqres)
      implicit none
      include 'constants.f'
      include 'masses.f'
      include 'zprods_com.f'
      include 'sprods_com.f'
      include 'scale.f'
      include 'b0.f'
      double precision   p(4,5),sqres(-2:0)
      double precision   Hqagg,Hqagg_ab,Hqagg_ba,Hqagg_sym
      double precision   q(mxpart,4)
      integer i,j
      double precision   s12,s13,s14,s23,s24,s34
      double complex lnrat

C --  reversal of GZ notation and restore dimension of the momenta
      do i=1,4
         do j=1,4
            q(i,j) = p(j,i)*hmass
         enddo
      enddo
      call spinoru(4,q,za,zb)

      call hqqgg(1,2,3,4,Hqagg,Hqagg_ab,Hqagg_ba,Hqagg_sym)

      s12=s(1,2)
      s13=s(1,3)
      s14=s(1,4)
      s23=s(2,3)
      s24=s(2,4)
      s34=s(3,4)

c--- NB: removed factor of ason2pi which is restored
c--- in the wrapping routine
      sqres(-2) = (-3d0*xn+one/xn)*Hqagg
      sqres(-1) = (
     .  (-3d0*Cf+(11d0*xn/3d0-2d0/3d0*nf-1d0/xn*dble(lnrat(-s12,musq))))
     .  *Hqagg
     .  +(xn*dble(lnrat(-s13,musq)+lnrat(-s34,musq)+lnrat(-s24,musq)))
     .  *Hqagg_ab
     .  +(xn*dble(lnrat(-s14,musq)+lnrat(-s34,musq)+lnrat(-s23,musq)))
     .  *Hqagg_ba
     .  +(xn*dble(-lnrat(-s12,musq)+lnrat(-s13,musq)+lnrat(-s23,musq)
     .       +lnrat(-s14,musq)+lnrat(-s24,musq)))*Hqagg_sym)

      sqres(0)  = 11d0*Hqagg
c--- The finite part which will be calculated using the semi-numerical
c--- procedure has to be added to this piece, which comes from the
c--- finite renormalization of the effective Lagrangian

c--- Add on renormalization factor
      sqres(-1)=sqres(-1)-4d0*b0*Hqagg

C      write(*,*) 'Poles qagggv K: 1/eps^2', sqres(-2)
C      write(*,*) 'Poles qagggv K: 1/eps^1', sqres(-1)
      return
      end


SUBROUTINE Geider_simple
use bio_MOD
implicit none
integer :: k
real    :: rhochl, theta, CHL
real    :: rmax_T, SI, muNet
real    :: par_, Ep, Ez
real    :: NO3, PHY, ZOO, DET, DET1

Ep = params(iEp)
Ez = params(iEz)
DO k = 1, nlev
   NO3 = Vars(iNO3,   k)
   PHY = Vars(iPHY(1),k)
   ZOO = Vars(iZOO,   k)
   CHL = Vars(iCHL,   k)
   DET = Vars(iDET,   k)

   ! Check whether in the MLD or not
   if (k .lt. N_MLD) then
      par_ = PAR(k)
   else
      par_ = PARavg
   endif
   ! Loss rate of phytoplankton to detritus equals to zero

   ! Define phytoplankton Chl-to-carbon ratio (gChl/molC)
   theta = CHL/(PHY/params(iQ0N))

   ! The maximal growth rate (rmax_T) under temperature tC
   rmax_T = params(imu0)* TEMPBOL(Ep,Temp(k)) * dtdays

   !The light limitation index (fpar)
   SI = 1d0 - exp(-params(iaI0) * dtdays *par_ * theta/rmax_T)

   ! Growth rate (d-1) is the product function of temperature, light, and nutrient
   Varout(oLno3(1),k) = NO3/(NO3 + params(iKn))
   muNet = rmax_T * Varout(oLno3(1),k)*SI

   ! define rhochl (gChl/molC;the fraction of phytoplankton carbon production that is devoted to Chl synthesis)
   rhochl = thetm*muNet/(params(iaI0)*dtdays*par_*theta)

   ! The total amount of phytoplankton grazed by zooplankton (molN;gmax is the maximal specific ingestion rate!)
   tf_z   = TEMPBOL(Ez,Temp(k))
   gbar   = grazing(grazing_formulation,params(ikp),PHY)
   INGES  = ZOO*params(igmax)*tf_z * dtdays * gbar

   Zmort = ZOO*ZOO*dtdays* params(imz) *tf_z  !Mortality term for ZOO

   !Zooplankton excretion rate (-> DOM)
   RES = INGES*(1d0-GGE-unass)

   !ZOOPLANKTON EGESTION (-> POM)
   EGES = INGES*unass

  ! For production/destruction matrix:
  pp_ND = dtdays* params(irDN) *DET*tf_z
  pp_NZ = ZOO*RES
  pp_DZ = ZOO*EGES+Zmort
  pp_ZP = ZOO*INGES

  DET1 = (DET + pp_DZ)/(1d0 + dtdays * params(irDN)*tf_z)
  Varout(oDET,k)    = DET1
  Varout(oSI(1),k)  = SI
  Varout(oNO3,k)    = (NO3+pp_ND+pp_NZ)/(1d0+ PHY*muNet/NO3)
  Varout(oPHY(1),k) = PHY*(1d0 + muNet)/(1d0 + pp_ZP/PHY)

  Varout(omuNet(1), k) = muNet/dtdays
  Varout(oPPt,k)       = PHY*muNet/params(iQ0N)/dtdays
  Varout(oGraz(1), k)  = pp_ZP/PHY/dtdays
  Varout(oZOO,k) = (ZOO+pp_ZP)/(1d0+EGES+ZOO*dtdays*params(imz)*tf_z+RES)
  Varout(oZ2N,k) = pp_NZ/dtdays
  Varout(oD2N,k) = pp_ND/dtdays

  Varout(oCHLt,k) = (CHL + rhochl*muNet*PHY/params(iQ0N)) &
                 / (1d0 + pp_ZP/PHY)

  Varout(oTheta(1),k) = Varout(oCHLt,k)/(Varout(oPHY(1),k)/params(iQ0N))

  !Varout(ow_p(1),k) = w_p0   !Should not be converted by dtdays

enddo
End subroutine Geider_simple


      SUBROUTINE HALLEY(TIME1,POS)
C
C SUBROUTINE HALLEY TAKES A TIME AND RETURNS THE POSITION OF HALLEY'S
C COMET WITH RESPECT TO EARTH CENTERED COORDINATES IN MEAN EQUATOR AND
C EQUINOX OF 1950.0
C
C*****************************************************************
C
C THE METHOD FOR FINDING THE POSITION OF HALLEY'S COMET IN THIS
C SUBROUTINE IS AS FOLLOWS: THE SIX KEPLERIAN ORBITAL ELEMENTS
C OF HALLEY'S COMET ARE DEFINED IN THE DATA STATEMENT.
C
C*****************************************************************
C
C THIS SUBROUTINE WAS CODED BY BARBARA H. ROBERTS, 6/81.
C UPDATED............
C            1/83. C PETRUZZO. COMMENT CHANGES, REPLACE ELREC WITH
C                  TOCART, AND ASSOCIATED CHANGES.
C            5/85. S LAMBROS. UPDATE ORBITAL ELEMENTS AND TIMEP, AS
C                  PER D.K. YEOMANS OF JPL. ALSO CHANGED ASSOCIATED
C                  COMMENTS.
C******************************************************************
C
C VARIABLE DESCRIPTION  DIMENSION     I/O    TYPE     DESCRIPTION
C
C        TIME1              1          I      R*8     SEC SINCE 1/1/50,
C                                                     0.0 HOURS
C
C        POS                3          O      R*8     POSITION OF
C                                                     COMET IN X,Y,Z
C                                                     COORDINATES WRT
C                                                     EARTH IN KM
C
C INTERNAL VARIABLES:
C
C        ELEM               6         N/A     R*8     KEPLERIAN ELEMENTS
C                                                     (AU,DEG) OF HALLEY
C
C        U                  1         N/A     R*8     GRAVITATIONAL
C                                                     CONSTANT
C
C        ELEM(6)            1         N/A     R*8     MEAN ANOMALY
C
C**********************************************************************
C
      IMPLICIT REAL*8(A-H,O-Z)
      REAL*8 AU/149.6D6/
      DIMENSION ELEM(6),POS(3),COEF(4),RHALEY(3),VHALEY(3),SUNVEC(3)
C
C   HALLEY ORBITAL ELEMENTS. THESE ARE FROM D. K. YEOMANS OF JPL -
C   HIS LATEST CALCULATIONS AS OF 5/17/85. UNITS ARE A.U. AND DEG.,
C   AND ARE REFERRED TO THE ECLIPTIC AND EQUINOX OF 1950.0.
C   PERIHELION TIME(=TIMEP) CORRESPONDS TO 1986, FEB. 9.45069 E.T.
      DATA ELEM/17.9390877D0, 0.9672726D0,
     1  162.23931D0, 58.14398D0, 111.84677D0, 0.D0/,   ! DEGREES
     2  TIMEP/2446470.95069D0/
C
C   COEFFICIENTS FOR OBLIQUITY COMPUTATION.
      DATA COEF/23.4522944D0, -.0130125D0,-.1638889D-5,-.5027778D-6/
C
      REAL*8 JD50/2433282.5D0/
      REAL*8 DEGRAD/ 57.29577951308232D0 /
      REAL*8 TWOPI/ 6.283185307179586D0 /
      INTEGER INIT/0/
C
C
      IF(INIT.NE.0) GO TO 55
      INIT=1
C    OBLIQUITY AT 1/1/50,  0.0 HRS.
      TT=0.5D0
      TILT=(COEF(1)+COEF(2)*TT+COEF(3)*TT**2+COEF(4)*TT**3)/DEGRAD
      SINI=DSIN(TILT)
      COSI=DCOS(TILT)
C    SUN MU IN KM**3/SEC**2
      U=1.32715445D11
C    SUN MU IN AU**3/SEC**2
      U=U/AU**3
C    PERIOD IN DAYS.
      PERIOD=TWOPI*DSQRT(ELEM(1)**3/(U*86400.D0**2))
C    TPERIH=PERIHELION TIME IN DAYS SINCE 1/1/50, 0.0 HRS E.T.
      TPERIH= TIMEP-JD50
C    HALLEY ANGLE ELEMENTS CONVERTED TO RADIANS.
      DO 54 I=3,6
   54 ELEM(I)=ELEM(I)/DEGRAD
   55 CONTINUE
C
C    FIND RHALEY, THE POSITION VECTOR OF HALLEY WRT THE SUN AND IN
C    ECLIPTIC COORDINATES, MEAN OF 1950.0.
      DT=TIME1/86400.0D0-TPERIH
      ELEM(6)=DT/PERIOD * TWOPI
      CALL TOCART(U,ELEM,0,RHALEY,VHALEY,6,IERR)
C
C    NOW ROTATE RHALEY TO EARTH'S EQUATOR
      POS2=RHALEY(2)*COSI-RHALEY(3)*SINI
      POS3=RHALEY(3)*COSI+RHALEY(2)*SINI
      RHALEY(2)=POS2
      RHALEY(3)=POS3
C
C    FIND THE POSITION OF SUN IN MEAN OF 1950.0.
      CALL SOLM50(TIME1,SUNVEC,2)
C
C    NOW GET AND RETURN HALLEY POSITION IN GEOCENTRIC, MEAN EQUATOR
C    AND EQUINOX OF 1950.0.  UNITS ARE KM.
      DO 300 I=1,3
  300 POS(I)=RHALEY(I)*AU+SUNVEC(I)
C
      RETURN
      END