      SUBROUTINE DCHKHS( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
     $                   NOUNIT, A, LDA, H, T1, T2, U, LDU, Z, UZ, WR1,
     $                   WI1, WR3, WI3, EVECTL, EVECTR, EVECTY, EVECTX,
     $                   UU, TAU, WORK, NWORK, IWORK, SELECT, RESULT,
     $                   INFO )
*
*  -- LAPACK test routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDU, NOUNIT, NSIZES, NTYPES, NWORK
      DOUBLE PRECISION   THRESH
*     ..
*     .. Array Arguments ..
      LOGICAL            DOTYPE( * ), SELECT( * )
      INTEGER            ISEED( 4 ), IWORK( * ), NN( * )
      DOUBLE PRECISION   A( LDA, * ), EVECTL( LDU, * ),
     $                   EVECTR( LDU, * ), EVECTX( LDU, * ),
     $                   EVECTY( LDU, * ), H( LDA, * ), RESULT( 14 ),
     $                   T1( LDA, * ), T2( LDA, * ), TAU( * ),
     $                   U( LDU, * ), UU( LDU, * ), UZ( LDU, * ),
     $                   WI1( * ), WI3( * ), WORK( * ), WR1( * ),
     $                   WR3( * ), Z( LDU, * )
*     ..
*
*  Purpose
*  =======
*
*     DCHKHS  checks the nonsymmetric eigenvalue problem routines.
*
*             DGEHRD factors A as  U H U' , where ' means transpose,
*             H is hessenberg, and U is an orthogonal matrix.
*
*             DORGHR generates the orthogonal matrix U.
*
*             DORMHR multiplies a matrix by the orthogonal matrix U.
*
*             DHSEQR factors H as  Z T Z' , where Z is orthogonal and
*             T is "quasi-triangular", and the eigenvalue vector W.
*
*             DTREVC computes the left and right eigenvector matrices
*             L and R for T.
*
*             DHSEIN computes the left and right eigenvector matrices
*             Y and X for H, using inverse iteration.
*
*     When DCHKHS 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, 14
*     tests will be performed:
*
*     (1)     | A - U H U**T | / ( |A| n ulp )
*
*     (2)     | I - UU**T | / ( n ulp )
*
*     (3)     | H - Z T Z**T | / ( |H| n ulp )
*
*     (4)     | I - ZZ**T | / ( n ulp )
*
*     (5)     | A - UZ H (UZ)**T | / ( |A| n ulp )
*
*     (6)     | I - UZ (UZ)**T | / ( n ulp )
*
*     (7)     | T(Z computed) - T(Z not computed) | / ( |T| ulp )
*
*     (8)     | W(Z computed) - W(Z not computed) | / ( |W| ulp )
*
*     (9)     | TR - RW | / ( |T| |R| ulp )
*
*     (10)    | L**H T - W**H L | / ( |T| |L| ulp )
*
*     (11)    | HX - XW | / ( |H| |X| ulp )
*
*     (12)    | Y**H H - W**H Y | / ( |H| |Y| ulp )
*
*     (13)    | AX - XW | / ( |A| |X| ulp )
*
*     (14)    | Y**H A - W**H Y | / ( |A| |Y| ulp )
*
*     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 signs.
*          (ULP = (first number larger than 1) - 1 )
*     (5)  A diagonal matrix with geometrically spaced entries
*          1, ..., ULP  and random signs.
*     (6)  A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
*          and random signs.
*
*     (7)  Same as (4), but multiplied by SQRT( overflow threshold )
*     (8)  Same as (4), but multiplied by SQRT( underflow threshold )
*
*     (9)  A matrix of the form  U' T U, where U is orthogonal and
*          T has evenly spaced entries 1, ..., ULP with random signs
*          on the diagonal and random O(1) entries in the upper
*          triangle.
*
*     (10) A matrix of the form  U' T U, where U is orthogonal and
*          T has geometrically spaced entries 1, ..., ULP with random
*          signs 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
*          signs on the diagonal and random O(1) entries in the upper
*          triangle.
*
*     (12) A matrix of the form  U' T U, where U is orthogonal and
*          T has real or complex conjugate paired eigenvalues randomly
*          chosen from ( ULP, 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 signs 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 signs 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 signs 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 real or complex conjugate paired
*          eigenvalues randomly chosen from ( ULP, 1 ) and random
*          O(1) entries in the upper triangle.
*
*     (17) Same as (16), but multiplied by SQRT( overflow threshold )
*     (18) Same as (16), but multiplied by SQRT( underflow threshold )
*
*     (19) Nonsymmetric matrix with random entries chosen from (-1,1).
*     (20) Same as (19), but multiplied by SQRT( overflow threshold )
*     (21) Same as (19), but multiplied by SQRT( underflow threshold )
*
*  Arguments
*  ==========
*
*  NSIZES - INTEGER
*           The number of sizes of matrices to use.  If it is zero,
*           DCHKHS does nothing.  It must be at least zero.
*           Not modified.
*
*  NN     - 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.
*           Not modified.
*
*  NTYPES - INTEGER
*           The number of elements in DOTYPE.   If it is zero, DCHKHS
*           does nothing.  It must be at least zero.  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. .
*           Not modified.
*
*  DOTYPE - 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.
*           Not modified.
*
*  ISEED  - 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 DCHKHS to continue the same random number
*           sequence.
*           Modified.
*
*  THRESH - 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.
*           Not modified.
*
*  NOUNIT - INTEGER
*           The FORTRAN unit number for printing out error messages
*           (e.g., if a routine returns IINFO not equal to 0.)
*           Not modified.
*
*  A      - DOUBLE PRECISION 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.
*           Modified.
*
*  LDA    - INTEGER
*           The leading dimension of A, H, T1 and T2.  It must be at
*           least 1 and at least max( NN ).
*           Not modified.
*
*  H      - DOUBLE PRECISION array, dimension (LDA,max(NN))
*           The upper hessenberg matrix computed by DGEHRD.  On exit,
*           H contains the Hessenberg form of the matrix in A.
*           Modified.
*
*  T1     - DOUBLE PRECISION array, dimension (LDA,max(NN))
*           The Schur (="quasi-triangular") matrix computed by DHSEQR
*           if Z is computed.  On exit, T1 contains the Schur form of
*           the matrix in A.
*           Modified.
*
*  T2     - DOUBLE PRECISION array, dimension (LDA,max(NN))
*           The Schur matrix computed by DHSEQR when Z is not computed.
*           This should be identical to T1.
*           Modified.
*
*  LDU    - INTEGER
*           The leading dimension of U, Z, UZ and UU.  It must be at
*           least 1 and at least max( NN ).
*           Not modified.
*
*  U      - DOUBLE PRECISION array, dimension (LDU,max(NN))
*           The orthogonal matrix computed by DGEHRD.
*           Modified.
*
*  Z      - DOUBLE PRECISION array, dimension (LDU,max(NN))
*           The orthogonal matrix computed by DHSEQR.
*           Modified.
*
*  UZ     - DOUBLE PRECISION array, dimension (LDU,max(NN))
*           The product of U times Z.
*           Modified.
*
*  WR1    - DOUBLE PRECISION array, dimension (max(NN))
*  WI1    - DOUBLE PRECISION array, dimension (max(NN))
*           The real and imaginary parts of the eigenvalues of A,
*           as computed when Z is computed.
*           On exit, WR1 + WI1*i are the eigenvalues of the matrix in A.
*           Modified.
*
*  WR3    - DOUBLE PRECISION array, dimension (max(NN))
*  WI3    - DOUBLE PRECISION array, dimension (max(NN))
*           Like WR1, WI1, these arrays contain the eigenvalues of A,
*           but those computed when DHSEQR only computes the
*           eigenvalues, i.e., not the Schur vectors and no more of the
*           Schur form than is necessary for computing the
*           eigenvalues.
*           Modified.
*
*  EVECTL - DOUBLE PRECISION array, dimension (LDU,max(NN))
*           The (upper triangular) left eigenvector matrix for the
*           matrix in T1.  For complex conjugate pairs, the real part
*           is stored in one row and the imaginary part in the next.
*           Modified.
*
*  EVEZTR - DOUBLE PRECISION array, dimension (LDU,max(NN))
*           The (upper triangular) right eigenvector matrix for the
*           matrix in T1.  For complex conjugate pairs, the real part
*           is stored in one column and the imaginary part in the next.
*           Modified.
*
*  EVECTY - DOUBLE PRECISION array, dimension (LDU,max(NN))
*           The left eigenvector matrix for the
*           matrix in H.  For complex conjugate pairs, the real part
*           is stored in one row and the imaginary part in the next.
*           Modified.
*
*  EVECTX - DOUBLE PRECISION array, dimension (LDU,max(NN))
*           The right eigenvector matrix for the
*           matrix in H.  For complex conjugate pairs, the real part
*           is stored in one column and the imaginary part in the next.
*           Modified.
*
*  UU     - DOUBLE PRECISION array, dimension (LDU,max(NN))
*           Details of the orthogonal matrix computed by DGEHRD.
*           Modified.
*
*  TAU    - DOUBLE PRECISION array, dimension(max(NN))
*           Further details of the orthogonal matrix computed by DGEHRD.
*           Modified.
*
*  WORK   - DOUBLE PRECISION array, dimension (NWORK)
*           Workspace.
*           Modified.
*
*  NWORK  - INTEGER
*           The number of entries in WORK.  NWORK >= 4*NN(j)*NN(j) + 2.
*
*  IWORK  - INTEGER array, dimension (max(NN))
*           Workspace.
*           Modified.
*
*  SELECT - LOGICAL array, dimension (max(NN))
*           Workspace.
*           Modified.
*
*  RESULT - DOUBLE PRECISION array, dimension (14)
*           The values computed by the fourteen tests described above.
*           The values are currently limited to 1/ulp, to avoid
*           overflow.
*           Modified.
*
*  INFO   - INTEGER
*           If 0, then everything ran OK.
*            -1: NSIZES < 0
*            -2: Some NN(j) < 0
*            -3: NTYPES < 0
*            -6: THRESH < 0
*            -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
*           -14: LDU < 1 or LDU < NMAX.
*           -28: NWORK too small.
*           If  DLATMR, SLATMS, or SLATME returns an error code, the
*               absolute value of it is returned.
*           If 1, then DHSEQR could not find all the shifts.
*           If 2, then the EISPACK code (for small blocks) failed.
*           If >2, then 30*N iterations were not enough to find an
*               eigenvalue or to decompose the problem.
*           Modified.
*
*-----------------------------------------------------------------------
*
*     Some Local Variables and Parameters:
*     ---- ----- --------- --- ----------
*
*     ZERO, ONE       Real 0 and 1.
*     MAXTYP          The number of types defined.
*     MTEST           The number of tests defined: care must be taken
*                     that (1) the size of RESULT, (2) the number of
*                     tests actually performed, and (3) MTEST agree.
*     NTEST           The number of tests performed on this matrix
*                     so far.  This should be less than MTEST, and
*                     equal to it by the last test.  It will be less
*                     if any of the routines being tested indicates
*                     that it could not compute the matrices that
*                     would be tested.
*     NMAX            Largest value in NN.
*     NMATS           The number of matrices generated so far.
*     NERRS           The number of tests which have exceeded THRESH
*                     so far (computed by DLAFTS).
*     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.
*     RTOVFL, RTUNFL,
*     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)       Selects whether CONDS is to be 1 or
*                     1/sqrt(ulp).  (0 means irrelevant.)
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
      INTEGER            MAXTYP
      PARAMETER          ( MAXTYP = 21 )
*     ..
*     .. Local Scalars ..
      LOGICAL            BADNN, MATCH
      INTEGER            I, IHI, IINFO, ILO, IMODE, IN, ITYPE, J, JCOL,
     $                   JJ, JSIZE, JTYPE, K, MTYPES, N, N1, NERRS,
     $                   NMATS, NMAX, NSELC, NSELR, NTEST, NTESTT
      DOUBLE PRECISION   ANINV, ANORM, COND, CONDS, OVFL, RTOVFL, RTULP,
     $                   RTULPI, RTUNFL, TEMP1, TEMP2, ULP, ULPINV, UNFL
*     ..
*     .. Local Arrays ..
      CHARACTER          ADUMMA( 1 )
      INTEGER            IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( MAXTYP ),
     $                   KMAGN( MAXTYP ), KMODE( MAXTYP ),
     $                   KTYPE( MAXTYP )
      DOUBLE PRECISION   DUMMA( 6 )
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEHRD, DGEMM, DGET10, DGET22, DHSEIN,
     $                   DHSEQR, DHST01, DLABAD, DLACPY, DLAFTS, DLASET,
     $                   DLASUM, DLATME, DLATMR, DLATMS, DORGHR, DORMHR,
     $                   DTREVC, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, 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 ..
*
*     Check for errors
*
      NTESTT = 0
      INFO = 0
*
      BADNN = .FALSE.
      NMAX = 0
      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( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN
         INFO = -9
      ELSE IF( LDU.LE.1 .OR. LDU.LT.NMAX ) THEN
         INFO = -14
      ELSE IF( 4*NMAX*NMAX+2.GT.NWORK ) THEN
         INFO = -28
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DCHKHS', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
     $   RETURN
*
*     More important constants
*
      UNFL = DLAMCH( 'Safe minimum' )
      OVFL = DLAMCH( 'Overflow' )
      CALL DLABAD( UNFL, OVFL )
      ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
      ULPINV = ONE / ULP
      RTUNFL = SQRT( UNFL )
      RTOVFL = SQRT( OVFL )
      RTULP = SQRT( ULP )
      RTULPI = ONE / RTULP
*
*     Loop over sizes, types
*
      NERRS = 0
      NMATS = 0
*
      DO 270 JSIZE = 1, NSIZES
         N = NN( JSIZE )
         IF( N.EQ.0 )
     $      GO TO 270
         N1 = MAX( 1, N )
         ANINV = ONE / DBLE( N1 )
*
         IF( NSIZES.NE.1 ) THEN
            MTYPES = MIN( MAXTYP, NTYPES )
         ELSE
            MTYPES = MIN( MAXTYP+1, NTYPES )
         END IF
*
         DO 260 JTYPE = 1, MTYPES
            IF( .NOT.DOTYPE( JTYPE ) )
     $         GO TO 260
            NMATS = NMATS + 1
            NTEST = 0
*
*           Save ISEED in case of an error.
*
            DO 20 J = 1, 4
               IOLDSD( J ) = ISEED( J )
   20       CONTINUE
*
*           Initialize RESULT
*
            DO 30 J = 1, 14
               RESULT( J ) = ZERO
   30       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 100
*
            ITYPE = KTYPE( JTYPE )
            IMODE = KMODE( JTYPE )
*
*           Compute norm
*
            GO TO ( 40, 50, 60 )KMAGN( JTYPE )
*
   40       CONTINUE
            ANORM = ONE
            GO TO 70
*
   50       CONTINUE
            ANORM = ( RTOVFL*ULP )*ANINV
            GO TO 70
*
   60       CONTINUE
            ANORM = RTUNFL*N*ULPINV
            GO TO 70
*
   70       CONTINUE
*
            CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
            IINFO = 0
            COND = ULPINV
*
*           Special Matrices
*
            IF( ITYPE.EQ.1 ) THEN
*
*              Zero
*
               IINFO = 0
*
            ELSE IF( ITYPE.EQ.2 ) THEN
*
*              Identity
*
               DO 80 JCOL = 1, N
                  A( JCOL, JCOL ) = ANORM
   80          CONTINUE
*
            ELSE IF( ITYPE.EQ.3 ) THEN
*
*              Jordan Block
*
               DO 90 JCOL = 1, N
                  A( JCOL, JCOL ) = ANORM
                  IF( JCOL.GT.1 )
     $               A( JCOL, JCOL-1 ) = ONE
   90          CONTINUE
*
            ELSE IF( ITYPE.EQ.4 ) THEN
*
*              Diagonal Matrix, [Eigen]values Specified
*
               CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
     $                      ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ),
     $                      IINFO )
*
            ELSE IF( ITYPE.EQ.5 ) THEN
*
*              Symmetric, eigenvalues specified
*
               CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, 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
*
               ADUMMA( 1 ) = ' '
               CALL DLATME( N, 'S', ISEED, WORK, IMODE, COND, ONE,
     $                      ADUMMA, 'T', 'T', 'T', WORK( N+1 ), 4,
     $                      CONDS, N, N, ANORM, A, LDA, WORK( 2*N+1 ),
     $                      IINFO )
*
            ELSE IF( ITYPE.EQ.7 ) THEN
*
*              Diagonal, random eigenvalues
*
               CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
     $                      'T', 'N', WORK( N+1 ), 1, ONE,
     $                      WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0,
     $                      ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
            ELSE IF( ITYPE.EQ.8 ) THEN
*
*              Symmetric, random eigenvalues
*
               CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
     $                      'T', 'N', WORK( N+1 ), 1, ONE,
     $                      WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
     $                      ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
            ELSE IF( ITYPE.EQ.9 ) THEN
*
*              General, random eigenvalues
*
               CALL DLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
     $                      'T', 'N', WORK( N+1 ), 1, ONE,
     $                      WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
     $                      ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
            ELSE IF( ITYPE.EQ.10 ) THEN
*
*              Triangular, random eigenvalues
*
               CALL DLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
     $                      'T', 'N', WORK( N+1 ), 1, ONE,
     $                      WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, 0,
     $                      ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
*
            ELSE
*
               IINFO = 1
            END IF
*
            IF( IINFO.NE.0 ) THEN
               WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE,
     $            IOLDSD
               INFO = ABS( IINFO )
               RETURN
            END IF
*
  100       CONTINUE
*
*           Call DGEHRD to compute H and U, do tests.
*
            CALL DLACPY( ' ', N, N, A, LDA, H, LDA )
*
            NTEST = 1
*
            ILO = 1
            IHI = N
*
            CALL DGEHRD( N, ILO, IHI, H, LDA, WORK, WORK( N+1 ),
     $                   NWORK-N, IINFO )
*
            IF( IINFO.NE.0 ) THEN
               RESULT( 1 ) = ULPINV
               WRITE( NOUNIT, FMT = 9999 )'DGEHRD', IINFO, N, JTYPE,
     $            IOLDSD
               INFO = ABS( IINFO )
               GO TO 250
            END IF
*
            DO 120 J = 1, N - 1
               UU( J+1, J ) = ZERO
               DO 110 I = J + 2, N
                  U( I, J ) = H( I, J )
                  UU( I, J ) = H( I, J )
                  H( I, J ) = ZERO
  110          CONTINUE
  120       CONTINUE
            CALL DCOPY( N, WORK, 1, TAU, 1 )
            CALL DORGHR( N, ILO, IHI, U, LDU, WORK, WORK( N+1 ),
     $                   NWORK-N, IINFO )
            NTEST = 2
*
            CALL DHST01( N, ILO, IHI, A, LDA, H, LDA, U, LDU, WORK,
     $                   NWORK, RESULT( 1 ) )
*
*           Call DHSEQR to compute T1, T2 and Z, do tests.
*
*           Eigenvalues only (WR3,WI3)
*
            CALL DLACPY( ' ', N, N, H, LDA, T2, LDA )
            NTEST = 3
            RESULT( 3 ) = ULPINV
*
            CALL DHSEQR( 'E', 'N', N, ILO, IHI, T2, LDA, WR3, WI3, UZ,
     $                   LDU, WORK, NWORK, IINFO )
            IF( IINFO.NE.0 ) THEN
               WRITE( NOUNIT, FMT = 9999 )'DHSEQR(E)', IINFO, N, JTYPE,
     $            IOLDSD
               IF( IINFO.LE.N+2 ) THEN
                  INFO = ABS( IINFO )
                  GO TO 250
               END IF
            END IF
*
*           Eigenvalues (WR1,WI1) and Full Schur Form (T2)
*
            CALL DLACPY( ' ', N, N, H, LDA, T2, LDA )
*
            CALL DHSEQR( 'S', 'N', N, ILO, IHI, T2, LDA, WR1, WI1, UZ,
     $                   LDU, WORK, NWORK, IINFO )
            IF( IINFO.NE.0 .AND. IINFO.LE.N+2 ) THEN
               WRITE( NOUNIT, FMT = 9999 )'DHSEQR(S)', IINFO, N, JTYPE,
     $            IOLDSD
               INFO = ABS( IINFO )
               GO TO 250
            END IF
*
*           Eigenvalues (WR1,WI1), Schur Form (T1), and Schur vectors
*           (UZ)
*
            CALL DLACPY( ' ', N, N, H, LDA, T1, LDA )
            CALL DLACPY( ' ', N, N, U, LDU, UZ, LDA )
*
            CALL DHSEQR( 'S', 'V', N, ILO, IHI, T1, LDA, WR1, WI1, UZ,
     $                   LDU, WORK, NWORK, IINFO )
            IF( IINFO.NE.0 .AND. IINFO.LE.N+2 ) THEN
               WRITE( NOUNIT, FMT = 9999 )'DHSEQR(V)', IINFO, N, JTYPE,
     $            IOLDSD
               INFO = ABS( IINFO )
               GO TO 250
            END IF
*
*           Compute Z = U' UZ
*
            CALL DGEMM( 'T', 'N', N, N, N, ONE, U, LDU, UZ, LDU, ZERO,
     $                  Z, LDU )
            NTEST = 8
*
*           Do Tests 3: | H - Z T Z' | / ( |H| n ulp )
*                and 4: | I - Z Z' | / ( n ulp )
*
            CALL DHST01( N, ILO, IHI, H, LDA, T1, LDA, Z, LDU, WORK,
     $                   NWORK, RESULT( 3 ) )
*
*           Do Tests 5: | A - UZ T (UZ)' | / ( |A| n ulp )
*                and 6: | I - UZ (UZ)' | / ( n ulp )
*
            CALL DHST01( N, ILO, IHI, A, LDA, T1, LDA, UZ, LDU, WORK,
     $                   NWORK, RESULT( 5 ) )
*
*           Do Test 7: | T2 - T1 | / ( |T| n ulp )
*
            CALL DGET10( N, N, T2, LDA, T1, LDA, WORK, RESULT( 7 ) )
*
*           Do Test 8: | W3 - W1 | / ( max(|W1|,|W3|) ulp )
*
            TEMP1 = ZERO
            TEMP2 = ZERO
            DO 130 J = 1, N
               TEMP1 = MAX( TEMP1, ABS( WR1( J ) )+ABS( WI1( J ) ),
     $                 ABS( WR3( J ) )+ABS( WI3( J ) ) )
               TEMP2 = MAX( TEMP2, ABS( WR1( J )-WR3( J ) )+
     $                 ABS( WR1( J )-WR3( J ) ) )
  130       CONTINUE
*
            RESULT( 8 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) )
*
*           Compute the Left and Right Eigenvectors of T
*
*           Compute the Right eigenvector Matrix:
*
            NTEST = 9
            RESULT( 9 ) = ULPINV
*
*           Select last max(N/4,1) real, max(N/4,1) complex eigenvectors
*
            NSELC = 0
            NSELR = 0
            J = N
  140       CONTINUE
            IF( WI1( J ).EQ.ZERO ) THEN
               IF( NSELR.LT.MAX( N / 4, 1 ) ) THEN
                  NSELR = NSELR + 1
                  SELECT( J ) = .TRUE.
               ELSE
                  SELECT( J ) = .FALSE.
               END IF
               J = J - 1
            ELSE
               IF( NSELC.LT.MAX( N / 4, 1 ) ) THEN
                  NSELC = NSELC + 1
                  SELECT( J ) = .TRUE.
                  SELECT( J-1 ) = .FALSE.
               ELSE
                  SELECT( J ) = .FALSE.
                  SELECT( J-1 ) = .FALSE.
               END IF
               J = J - 2
            END IF
            IF( J.GT.0 )
     $         GO TO 140
*
            CALL DTREVC( 'Right', 'All', SELECT, N, T1, LDA, DUMMA, LDU,
     $                   EVECTR, LDU, N, IN, WORK, IINFO )
            IF( IINFO.NE.0 ) THEN
               WRITE( NOUNIT, FMT = 9999 )'DTREVC(R,A)', IINFO, N,
     $            JTYPE, IOLDSD
               INFO = ABS( IINFO )
               GO TO 250
            END IF
*
*           Test 9:  | TR - RW | / ( |T| |R| ulp )
*
            CALL DGET22( 'N', 'N', 'N', N, T1, LDA, EVECTR, LDU, WR1,
     $                   WI1, WORK, DUMMA( 1 ) )
            RESULT( 9 ) = DUMMA( 1 )
            IF( DUMMA( 2 ).GT.THRESH ) THEN
               WRITE( NOUNIT, FMT = 9998 )'Right', 'DTREVC',
     $            DUMMA( 2 ), N, JTYPE, IOLDSD
            END IF
*
*           Compute selected right eigenvectors and confirm that
*           they agree with previous right eigenvectors
*
            CALL DTREVC( 'Right', 'Some', SELECT, N, T1, LDA, DUMMA,
     $                   LDU, EVECTL, LDU, N, IN, WORK, IINFO )
            IF( IINFO.NE.0 ) THEN
               WRITE( NOUNIT, FMT = 9999 )'DTREVC(R,S)', IINFO, N,
     $            JTYPE, IOLDSD
               INFO = ABS( IINFO )
               GO TO 250
            END IF
*
            K = 1
            MATCH = .TRUE.
            DO 170 J = 1, N
               IF( SELECT( J ) .AND. WI1( J ).EQ.ZERO ) THEN
                  DO 150 JJ = 1, N
                     IF( EVECTR( JJ, J ).NE.EVECTL( JJ, K ) ) THEN
                        MATCH = .FALSE.
                        GO TO 180
                     END IF
  150             CONTINUE
                  K = K + 1
               ELSE IF( SELECT( J ) .AND. WI1( J ).NE.ZERO ) THEN
                  DO 160 JJ = 1, N
                     IF( EVECTR( JJ, J ).NE.EVECTL( JJ, K ) .OR.
     $                   EVECTR( JJ, J+1 ).NE.EVECTL( JJ, K+1 ) ) THEN
                        MATCH = .FALSE.
                        GO TO 180
                     END IF
  160             CONTINUE
                  K = K + 2
               END IF
  170       CONTINUE
  180       CONTINUE
            IF( .NOT.MATCH )
     $         WRITE( NOUNIT, FMT = 9997 )'Right', 'DTREVC', N, JTYPE,
     $         IOLDSD
*
*           Compute the Left eigenvector Matrix:
*
            NTEST = 10
            RESULT( 10 ) = ULPINV
            CALL DTREVC( 'Left', 'All', SELECT, N, T1, LDA, EVECTL, LDU,
     $                   DUMMA, LDU, N, IN, WORK, IINFO )
            IF( IINFO.NE.0 ) THEN
               WRITE( NOUNIT, FMT = 9999 )'DTREVC(L,A)', IINFO, N,
     $            JTYPE, IOLDSD
               INFO = ABS( IINFO )
               GO TO 250
            END IF
*
*           Test 10:  | LT - WL | / ( |T| |L| ulp )
*
            CALL DGET22( 'Trans', 'N', 'Conj', N, T1, LDA, EVECTL, LDU,
     $                   WR1, WI1, WORK, DUMMA( 3 ) )
            RESULT( 10 ) = DUMMA( 3 )
            IF( DUMMA( 4 ).GT.THRESH ) THEN
               WRITE( NOUNIT, FMT = 9998 )'Left', 'DTREVC', DUMMA( 4 ),
     $            N, JTYPE, IOLDSD
            END IF
*
*           Compute selected left eigenvectors and confirm that
*           they agree with previous left eigenvectors
*
            CALL DTREVC( 'Left', 'Some', SELECT, N, T1, LDA, EVECTR,
     $                   LDU, DUMMA, LDU, N, IN, WORK, IINFO )
            IF( IINFO.NE.0 ) THEN
               WRITE( NOUNIT, FMT = 9999 )'DTREVC(L,S)', IINFO, N,
     $            JTYPE, IOLDSD
               INFO = ABS( IINFO )
               GO TO 250
            END IF
*
            K = 1
            MATCH = .TRUE.
            DO 210 J = 1, N
               IF( SELECT( J ) .AND. WI1( J ).EQ.ZERO ) THEN
                  DO 190 JJ = 1, N
                     IF( EVECTL( JJ, J ).NE.EVECTR( JJ, K ) ) THEN
                        MATCH = .FALSE.
                        GO TO 220
                     END IF
  190             CONTINUE
                  K = K + 1
               ELSE IF( SELECT( J ) .AND. WI1( J ).NE.ZERO ) THEN
                  DO 200 JJ = 1, N
                     IF( EVECTL( JJ, J ).NE.EVECTR( JJ, K ) .OR.
     $                   EVECTL( JJ, J+1 ).NE.EVECTR( JJ, K+1 ) ) THEN
                        MATCH = .FALSE.
                        GO TO 220
                     END IF
  200             CONTINUE
                  K = K + 2
               END IF
  210       CONTINUE
  220       CONTINUE
            IF( .NOT.MATCH )
     $         WRITE( NOUNIT, FMT = 9997 )'Left', 'DTREVC', N, JTYPE,
     $         IOLDSD
*
*           Call DHSEIN for Right eigenvectors of H, do test 11
*
            NTEST = 11
            RESULT( 11 ) = ULPINV
            DO 230 J = 1, N
               SELECT( J ) = .TRUE.
  230       CONTINUE
*
            CALL DHSEIN( 'Right', 'Qr', 'Ninitv', SELECT, N, H, LDA,
     $                   WR3, WI3, DUMMA, LDU, EVECTX, LDU, N1, IN,
     $                   WORK, IWORK, IWORK, IINFO )
            IF( IINFO.NE.0 ) THEN
               WRITE( NOUNIT, FMT = 9999 )'DHSEIN(R)', IINFO, N, JTYPE,
     $            IOLDSD
               INFO = ABS( IINFO )
               IF( IINFO.LT.0 )
     $            GO TO 250
            ELSE
*
*              Test 11:  | HX - XW | / ( |H| |X| ulp )
*
*                        (from inverse iteration)
*
               CALL DGET22( 'N', 'N', 'N', N, H, LDA, EVECTX, LDU, WR3,
     $                      WI3, WORK, DUMMA( 1 ) )
               IF( DUMMA( 1 ).LT.ULPINV )
     $            RESULT( 11 ) = DUMMA( 1 )*ANINV
               IF( DUMMA( 2 ).GT.THRESH ) THEN
                  WRITE( NOUNIT, FMT = 9998 )'Right', 'DHSEIN',
     $               DUMMA( 2 ), N, JTYPE, IOLDSD
               END IF
            END IF
*
*           Call DHSEIN for Left eigenvectors of H, do test 12
*
            NTEST = 12
            RESULT( 12 ) = ULPINV
            DO 240 J = 1, N
               SELECT( J ) = .TRUE.
  240       CONTINUE
*
            CALL DHSEIN( 'Left', 'Qr', 'Ninitv', SELECT, N, H, LDA, WR3,
     $                   WI3, EVECTY, LDU, DUMMA, LDU, N1, IN, WORK,
     $                   IWORK, IWORK, IINFO )
            IF( IINFO.NE.0 ) THEN
               WRITE( NOUNIT, FMT = 9999 )'DHSEIN(L)', IINFO, N, JTYPE,
     $            IOLDSD
               INFO = ABS( IINFO )
               IF( IINFO.LT.0 )
     $            GO TO 250
            ELSE
*
*              Test 12:  | YH - WY | / ( |H| |Y| ulp )
*
*                        (from inverse iteration)
*
               CALL DGET22( 'C', 'N', 'C', N, H, LDA, EVECTY, LDU, WR3,
     $                      WI3, WORK, DUMMA( 3 ) )
               IF( DUMMA( 3 ).LT.ULPINV )
     $            RESULT( 12 ) = DUMMA( 3 )*ANINV
               IF( DUMMA( 4 ).GT.THRESH ) THEN
                  WRITE( NOUNIT, FMT = 9998 )'Left', 'DHSEIN',
     $               DUMMA( 4 ), N, JTYPE, IOLDSD
               END IF
            END IF
*
*           Call DORMHR for Right eigenvectors of A, do test 13
*
            NTEST = 13
            RESULT( 13 ) = ULPINV
*
            CALL DORMHR( 'Left', 'No transpose', N, N, ILO, IHI, UU,
     $                   LDU, TAU, EVECTX, LDU, WORK, NWORK, IINFO )
            IF( IINFO.NE.0 ) THEN
               WRITE( NOUNIT, FMT = 9999 )'DORMHR(R)', IINFO, N, JTYPE,
     $            IOLDSD
               INFO = ABS( IINFO )
               IF( IINFO.LT.0 )
     $            GO TO 250
            ELSE
*
*              Test 13:  | AX - XW | / ( |A| |X| ulp )
*
*                        (from inverse iteration)
*
               CALL DGET22( 'N', 'N', 'N', N, A, LDA, EVECTX, LDU, WR3,
     $                      WI3, WORK, DUMMA( 1 ) )
               IF( DUMMA( 1 ).LT.ULPINV )
     $            RESULT( 13 ) = DUMMA( 1 )*ANINV
            END IF
*
*           Call DORMHR for Left eigenvectors of A, do test 14
*
            NTEST = 14
            RESULT( 14 ) = ULPINV
*
            CALL DORMHR( 'Left', 'No transpose', N, N, ILO, IHI, UU,
     $                   LDU, TAU, EVECTY, LDU, WORK, NWORK, IINFO )
            IF( IINFO.NE.0 ) THEN
               WRITE( NOUNIT, FMT = 9999 )'DORMHR(L)', IINFO, N, JTYPE,
     $            IOLDSD
               INFO = ABS( IINFO )
               IF( IINFO.LT.0 )
     $            GO TO 250
            ELSE
*
*              Test 14:  | YA - WY | / ( |A| |Y| ulp )
*
*                        (from inverse iteration)
*
               CALL DGET22( 'C', 'N', 'C', N, A, LDA, EVECTY, LDU, WR3,
     $                      WI3, WORK, DUMMA( 3 ) )
               IF( DUMMA( 3 ).LT.ULPINV )
     $            RESULT( 14 ) = DUMMA( 3 )*ANINV
            END IF
*
*           End of Loop -- Check for RESULT(j) > THRESH
*
  250       CONTINUE
*
            NTESTT = NTESTT + NTEST
            CALL DLAFTS( 'DHS', N, N, JTYPE, NTEST, RESULT, IOLDSD,
     $                   THRESH, NOUNIT, NERRS )
*
  260    CONTINUE
  270 CONTINUE
*
*     Summary
*
      CALL DLASUM( 'DHS', NOUNIT, NERRS, NTESTT )
*
      RETURN
*
 9999 FORMAT( ' DCHKHS: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
     $      I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
 9998 FORMAT( ' DCHKHS: ', A, ' Eigenvectors from ', A, ' incorrectly ',
     $      'normalized.', / ' Bits of error=', 0P, G10.3, ',', 9X,
     $      'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5,
     $      ')' )
 9997 FORMAT( ' DCHKHS: Selected ', A, ' Eigenvectors from ', A,
     $      ' do not match other eigenvectors ', 9X, 'N=', I6,
     $      ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
*
*     End of DCHKHS
*
      END


C
C  (C) 2001 by Argonne National Laboratory.
C      See COPYRIGHT in top-level directory.
C
c
c  This file contains a routine for producing a decomposition of a 1-d array
c  when given a number of processors.  It may be used in "direct" product
c  decomposition.  The values returned assume a "global" domain in [1:n]
c
      subroutine MRE_DECOMP1D( n, numprocs, myid, s, e )
      integer n, numprocs, myid, s, e
      integer nlocal
      integer deficit
c
      nlocal  = n / numprocs
      s       = myid * nlocal + 1
      deficit = mod(n,numprocs)
      s       = s + min(myid,deficit)
      if (myid .lt. deficit) then
          nlocal = nlocal + 1
      endif
      e = s + nlocal - 1
      if (e .gt. n .or. myid .eq. numprocs-1) e = n
      return
      end


C     File: SADOURNY_x.f

C
C     DDX
C
      SUBROUTINE DDX(DF,F,DX,NX,NY)

      implicit none

      INTEGER :: NX, NY, nthreads
      INTEGER :: OMP_GET_NUM_THREADS
      REAL*8, DIMENSION(NX,  NY) :: F
      REAL*8, DIMENSION(NX-1,NY) :: DF
      REAL*8 :: DX

Cf2py intent(in) F
Cf2py intent(out) DF
Cf2py intent(in) DX
Cf2py intent(in) NX
Cf2py intent(in) NY

C     LOOP INDEX
      INTEGER :: I,J

      nthreads = OMP_GET_NUM_THREADS()
      call OMP_SET_NUM_THREADS(nthreads)
      !$OMP PARALLEL DO &
      !$OMP DEFAULT(SHARED) PROVATE(I,J)

      DO I = 1,NX-1
        DO J = 1,NY
            DF(I,J) = (F(I+1,J) - F(I,J))/DX
        END DO
      END DO
      !$OPM END PARALLEL DO

      END

C
C     AVX
C
      SUBROUTINE AVX(AF,F,NX,NY)

      implicit none

      INTEGER :: NX, NY, nthreads
      INTEGER :: OMP_GET_NUM_THREADS
      REAL*8, DIMENSION(NX,  NY) :: F
      REAL*8, DIMENSION(NX-1,NY) :: AF

Cf2py intent(in) F
Cf2py intent(out) AF
Cf2py intent(in) NX
Cf2py intent(in) NY

C     LOOP INDEX
      INTEGER :: I,J

      nthreads = OMP_GET_NUM_THREADS()
      call OMP_SET_NUM_THREADS(nthreads)
      !$OMP PARALLEL DO &
      !$OMP DEFAULT(SHARED) PROVATE(I,J)

      DO I = 1,NX-1
        DO J = 1,NY
            AF(I,J) = 0.5*(F(I+1,J) + F(I,J))
        END DO
      END DO
      !$OPM END PARALLEL DO

      END

C
C     DDX_PERIODIC
C
      SUBROUTINE DDX_PERIODIC(DF,F,DX,NX,NY)

      implicit none

      INTEGER :: NX, NY, nthreads
      INTEGER :: OMP_GET_NUM_THREADS
      REAL*8, DIMENSION(NX,  NY) :: F
      REAL*8, DIMENSION(NX+1,NY) :: DF
      REAL*8 :: DX

Cf2py intent(in) F
Cf2py intent(out) DF
Cf2py intent(in) DX
Cf2py intent(in) NX
Cf2py intent(in) NY

C     LOOP INDEX
      INTEGER :: I,J

      nthreads = OMP_GET_NUM_THREADS()
      call OMP_SET_NUM_THREADS(nthreads)
      !$OMP PARALLEL DO &
      !$OMP DEFAULT(SHARED) PROVATE(I,J)

      DO J = 1,NY
        DF(1,J) = (F(1,J) - F(NX,J))/DX
        DO I = 2,NX
          DF(I,J) = (F(I,J) - F(I-1,J))/DX
        END DO
        DF(NX+1,J) = (F(1,J) - F(NX,J))/DX
      END DO
      !$OPM END PARALLEL DO

      END

C
C     AVX_PERIODIC
C
      SUBROUTINE AVX_PERIODIC(AF,F,NX,NY)

      implicit none

      INTEGER :: NX, NY, nthreads
      INTEGER :: OMP_GET_NUM_THREADS
      REAL*8, DIMENSION(NX,  NY) :: F
      REAL*8, DIMENSION(NX+1,NY) :: AF

Cf2py intent(in) F
Cf2py intent(out) AF
Cf2py intent(in) NX
Cf2py intent(in) NY

C     LOOP INDEX
      INTEGER :: I,J

      nthreads = OMP_GET_NUM_THREADS()
      call OMP_SET_NUM_THREADS(nthreads)
      !$OMP PARALLEL DO &
      !$OMP DEFAULT(SHARED) PROVATE(I,J)

      DO J = 1,NY
        AF(1,J) = 0.5*(F(1,J) + F(NX,J))
        DO I = 2,NX
          AF(I,J) = 0.5*(F(I,J) + F(I-1,J))
        END DO
        AF(NX+1,J) = 0.5*(F(1,J) + F(NX,J))
      END DO
      !$OPM END PARALLEL DO

      END

C
C     DDX_WALLS
C
      SUBROUTINE DDX_WALLS(DF,F,DX,NX,NY)

      implicit none

      INTEGER :: NX, NY, nthreads
      INTEGER :: OMP_GET_NUM_THREADS
      REAL*8, DIMENSION(NX,   NY) :: F
      REAL*8, DIMENSION(NX+1, NY) :: DF
      REAL*8 :: DX

Cf2py intent(in) F
Cf2py intent(out) DF
Cf2py intent(in) DX
Cf2py intent(in) NX
Cf2py intent(in) NY

C     LOOP INDEX
      INTEGER :: I,J

      nthreads = OMP_GET_NUM_THREADS()
      call OMP_SET_NUM_THREADS(nthreads)
      !$OMP PARALLEL DO &
      !$OMP DEFAULT(SHARED) PROVATE(I,J)

      DO J = 1,NY
        DF(1,J) = (F(1,J) + F(1,J))/DX
        DO I = 2,NX
          DF(I,J) = (F(I,J) - F(I-1,J))/DX
        END DO
        DF(I,NY+1) = -(F(NX,J) + F(NX,J))/DX
      END DO
      !$OPM END PARALLEL DO

      END

C
C     AVX_WALLS
C
      SUBROUTINE AVX_WALLS(AF,F,NX,NY)

      implicit none

      INTEGER :: NX, NY, nthreads
      INTEGER :: OMP_GET_NUM_THREADS
      REAL*8, DIMENSION(NX,   NY) :: F
      REAL*8, DIMENSION(NX+1, NY) :: AF

Cf2py intent(in) F
Cf2py intent(out) AF
Cf2py intent(in) NX
Cf2py intent(in) NY

C     LOOP INDEX
      INTEGER :: I,J

      nthreads = OMP_GET_NUM_THREADS()
      call OMP_SET_NUM_THREADS(nthreads)
      !$OMP PARALLEL DO &
      !$OMP DEFAULT(SHARED) PROVATE(I,J)

      DO J = 1,NY
        AF(1,J) = 0.0
        DO I = 2,NX
          AF(I,J) = 0.5*(F(I,J) + F(I-1,J))
        END DO
        AF(NX+1,J) = 0.0
      END DO
      !$OPM END PARALLEL DO

      END


! compute the analytic solution -- this is a function of time and the
! problem parameters only

subroutine ca_deranalytic(a,a_l1,a_l2,a_h1,a_h2,ncomp_a, &
                          u,u_l1,u_l2,u_h1,u_h2,ncomp_u,lo,hi,domlo, &
                          domhi,dx,xlo,time,dt,bc,level,grid_no) bind(C, name="ca_deranalytic")

  use prob_params_module, only: center, problo
  use amrex_fort_module, only : rt => amrex_real
  use bl_constants_module, only : HALF
  use prob_util_module, only: analytic

  implicit none

  integer, intent(in) :: a_l1, a_l2, a_h1, a_h2, ncomp_a
  integer, intent(in) :: u_l1, u_l2, u_h1, u_h2, ncomp_u
  integer, intent(in) :: lo(2), hi(2), domlo(2), domhi(2)
  real(rt), intent(inout) :: a(a_l1:a_h1,a_l2:a_h2,ncomp_a)
  real(rt), intent(in) :: u(u_l1:u_h1,u_l2:u_h2,ncomp_u)
  real(rt), intent(in) :: dx(2), xlo(2), time, dt
  integer, intent(in) :: bc(2,2,ncomp_u), level, grid_no

  real(rt) :: xc, yc, temp
  integer :: i, j

  do j = lo(2), hi(2)
     yc = problo(2) + dx(2)*(dble(j) + HALF)

     do i = lo(1), hi(1)
        xc = problo(1) + dx(1)*(dble(i) + HALF)

        call analytic(xc, yc, time, temp)
        a(i,j,1) = temp

     enddo
  enddo

end subroutine ca_deranalytic


      FUNCTION dpmpar (i)
      USE stel_kinds
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER :: i
      REAL(rprec) :: dpmpar
C-----------------------------------------------
c
c     FUNCTION dpmpar
c
c     this FUNCTION provides single (double) precision machine parameters
c     when the appropriate set of data statements is activated (by
c     removing the c from column 1) and ALL other data statements are
c     rendered inactive. most of the PARAMETER values were obtained
c     from the corresponding bell laboratories port library FUNCTION.
c
c     the FUNCTION statement is
c
c       FUNCTION dpmpar(i)
c
c     WHERE
c
c       i is an integer input variable set to 1, 2, or 3 which
c         selects the desired machine parameter. if the machine has
c         t base b digits and its smallest and largest exponents are
c         emin and emax, respectively, then these parameters are
c
c         dpmpar(1) = b**(1 - t), the machine precision,
c
c         dpmpar(2) = b**(emin - 1), the smallest magnitude,
c
c         dpmpar(3) = b**emax*(1 - b**(-t)), the largest magnitude.
c
c     argonne national laboratory. minpack project. march 1980.
c     burton s. garbow, kenneth e. hillstrom, jorge j. more
c
c     SINGLE PRECISION
c     data rmach(1)/1.490116100E-8/
c     data rmach(2)/1.4693679000E-30/
c     data rmach(3)/1.701411800E+30/
c     DOUBLE PRECISION - IEEE
c     data dmach(1) /2.22044604926d-16/
c     data dmach(2) /2.22507385852d-308/
c     data dmach(3) /1.79769313485d+308/
c     modified for f90 (sph, august 1997)
c
      SELECT CASE(i)
      CASE(:1)
        dpmpar = EPSILON(dpmpar)      !2.22044604926e-16_dp
      CASE(2)
        dpmpar = TINY(dpmpar)         !2.22507385852e-308_dp
      CASE(3:)
        dpmpar = HUGE(dpmpar)         !1.79769313485e+308_dp
      END SELECT

      END FUNCTION dpmpar


    program demo_sum
    ! John Mahaffy  2/16/96
    implicit none
    integer nd, ndh, nduh, j
    parameter (nd=10,ndh=nd/2, nduh=nd-ndh)
    real csum, cpsum, cbpsum
    real, dimension(nd):: c=[(j, j=-1,nd-2)], b
    data b/ndh*-1.0, nduh*2.0/
       csum= sum(c(1:nd))
       cpsum= sum (c(1:nd), mask=c.gt.0)
       cbpsum= sum(c(1:nd), mask=b.gt.0.0)
       print *, 'Sum of all elements in c = ' , csum
       print *, 'Sum of Positive elements in c = ', cpsum
       print *, 'Sum of elements in c when corresponding elements in b>0', &
       & ' =', cbpsum
    end program demo_sum


FUNCTION CSEDTAUB(DENBULK,IOPT)

  ! **  CALCULATES CRITIAL STRESS FOR BULK OR MASS EROSION OF COHESIVE
  ! **  SEDIMENT AS A FUNCTION OF BED BULK DENSITY
  ! **  IOPT=1  BASED ON
  ! **
  ! **  HWANG, K. N., AND A. J. MEHTA, 1989: FINE SEDIMENT DRODIBILITY
  ! **  IN LAKE OKEECHOBEE FLORIDA. COASTAL AND OCEANOGRAPHIC ENGINEERING
  ! **  DEPARTMENT, UNIVERSITY OF FLORIDA, GAINESVILLE, FL32661
  ! **  IOPT=2  BASED ON
  ! **
  ! **  HWANG, K. N., AND A. J. MEHTA, 1989: FINE SEDIMENT DRODIBILITY
  ! **  IN LAKE OKEECHOBEE FLORIDA. COASTAL AND OCEANOGRAPHIC ENGINEERING
  ! **  DEPARTMENT, UNIVERSITY OF FLORIDA, GAINESVILLE, FL32661

  ! CHANGE RECORD

  IMPLICIT NONE

  INTEGER :: IOPT
  REAL :: CSEDTAUB,DENBULK,BULKDEN

  IF( IOPT == 1 )THEN
    BULKDEN=0.001*DENBULK  ! *** PMC Changed to prevent
    IF( BULKDEN <= 1.013 )THEN
      CSEDTAUB=0.0
    ELSE
      CSEDTAUB=0.001*(9.808*BULKDEN-9.934)
    ENDIF
  ELSEIF( IOPT == 2 )THEN
    BULKDEN=0.001*DENBULK  ! *** PMC Changed to prevent
    IF( BULKDEN <= 1.013 )THEN
      CSEDTAUB=0.0
    ELSE
      CSEDTAUB=0.001*(9.808*BULKDEN-9.934)
    ENDIF
  ELSE
    STOP 'CSEDTAUB: BAD SEDIMENT CRITICAL STRESS OPTION! STOPPING!'
  ENDIF
  !
END FUNCTION


subroutine HotSpot(lai,q,tss,ks,ko,dso, &
        tsstoo,sumint)

    use mod_types
    implicit none
    real(kind=r2), intent(in) :: lai,q,tss,ks,ko,dso
    real(kind=r2), intent(out) :: tsstoo, sumint

    integer :: i
    real(kind=r2) :: fhot,alf,ca,x1,y1,f1,fint,x2,y2,f2

    !Treatment of the hotspot-effect
    alf = 1d6
    !Apply correction 2/(K+k) suggested by F.-M. Bréon
    IF (q.gt.0.) alf = (dso/q)*2./(ks+ko)
    IF (alf.GT.200.) alf = 200 !inserted H. Bach 1/3/04
    IF (alf.eq.0.) THEN
        !The pure hotspot - no shadow
        tsstoo = tss
        sumint = (1-tss)/(ks*lai)
    ELSE
        !Outside the hotspot
        fhot   = lai*SQRT(ko*ks)

        !Integrate by exponential Simpson method in 20 steps
        !the steps are arranged according to equal partitioning
        !of the slope of the joint probability function

        x1     = 0.
        y1     = 0.
        f1     = 1.
        ca=exp(alf*(-1.))
        fint   = (1.-ca)*.05
        sumint = 0.

        DO i=1,20
        IF (i.lt.20) THEN
            x2=-LOG(1.-i*fint)/alf
        ELSE
            x2=1.
        ENDIF
        y2     = -(ko+ks)*lai*x2+fhot*(1.-EXP(-alf*x2))/alf
        f2     = EXP(y2)
        sumint = sumint+(f2-f1)*(x2-x1)/(y2-y1)
        x1     = x2
        y1     = y2
        f1     = f2
        ENDDO
        tsstoo = f1
    ENDIF

    return
end subroutine HotSpot


! mpiexec -np 4 bin/Debug/WGFM_test2.exe
program potencial_test
    use meshread_mod
    use EFIE_functions
    use EFIEDuffy_functions
    use MFIEDuffy_functions
    use linalg_mod
    use WGFM_matrices
    use CFIE_mod
    use mpi
    implicit none

    real(8), parameter :: pi = 4d0 * atan(1d0)
    complex(8), parameter :: IU = (0d0, 1d0)

    ! Variables
    type(Mesh) :: msh, msh_evl
    integer, parameter :: nNS = 6           ! number of quadrature points for EFIE
    complex(8), allocatable :: Z(:, :), V(:), I(:), Es(:, :)
    complex(8), allocatable :: Einc(:, :), Hinc(:, :)
    complex(8), allocatable :: Eexact(:, :), Hexact(:, :)
    complex(8), allocatable :: Epot(:, :, :)
    complex(8), allocatable :: wEpot1(:, :, :)
    complex(8), allocatable :: wEpot2(:, :, :)
    complex(8), allocatable :: wHpot1(:, :, :)
    complex(8), allocatable :: wHpot2(:, :, :)

    integer :: nEvl
    real(8), allocatable :: xEvl(:,:)  ! Evaluation mesh
    real(8) :: ExNorm, Error1, Error2

    ! MPI variables
    integer :: ierr, N_procs, id

    ! Parameters
    real(8), parameter :: ep0 = 1d0 / (35950207149.4727056d0 * PI)  ! vacuum permittivity [F/m]
    real(8), parameter :: mu0 = PI * 4d-7                           ! vacuum permeability [H/m]

    real(8), parameter :: k = 1d0 * PI          ! free-space wavenumber [1/m]
    real(8), parameter :: ep1 = ep0             ! upper half-space permittivity [F/m]
    real(8), parameter :: mu1 = mu0             ! upper half-space permeability [H/m]
    real(8), parameter :: ep2 = ep0 * 7.4d0     ! lower half-space permittivity [F/m]
    real(8), parameter :: mu2 = mu0 * 2.5d0     ! lower half-space permeability [H/m]

    real(8), parameter :: w = k / sqrt(ep0 * mu0)   ! angular frequency [rad/s]
    real(8), parameter :: k1 = w * sqrt(ep1 * mu1)  ! upper half-space wavenumber [1/m]
    real(8), parameter :: k2 = w * sqrt(ep2 * mu2)  ! lower half-space wavenumber [1/m]
    real(8), parameter :: ktest = k2

    character(len=100) :: file_msh = 'meshes/convergence_sphere/sph0150.msh'
    character(len=100) :: file_evl_msh = 'meshes/convergence_sphere/sphNF0300.msh'

    real(8) :: pol(3) = [1.0d0, 1.0d0, 1.0d0]      ! polarization vector
    real(8) :: src(3) = [-0.1d0, -0.1d0, -0.25d0]  ! location of dipole source

    ! MPI init
    call mpi_init(ierr)
    call mpi_comm_size(MPI_COMM_WORLD, N_procs, ierr)
    call mpi_comm_rank(MPI_COMM_WORLD, id, ierr)
    print *, "Total processes:", N_procs, "Process id:", id

    ! Load mesh
    call load_gmsh(file_msh, msh)

    ! Compute EFIE matrices
    if (id == 0) print *, "EFIE"
    call genEFIESauterSchwabMat(Z, msh, ktest, nNS, nNS)

    ! Solve system
    if (id == 0) then
        allocate(V(msh%nbEdg))
        allocate(I(msh%nbEdg))

        ! Incident fields
        call DipoleFieldsOnMesh(pol, src, ktest, msh, Einc, Hinc)  ! Magnetic dipole

        ! EFIE RHS
        V = genRHS(Einc, msh)

        ! Solve
        call linsolve(I, Z, V, msh%nbEdg)
    end if

    ! Load eval mesh
    call load_gmsh(file_evl_msh, msh_evl)
    nEvl = msh_evl%nbELm
    allocate(xEvl(nEvl, 3))
    xEvl = msh_evl%CNTR + (msh%h/2.0d0**(0))*msh_evl%NRM

    ! Compute exact solution
    if (id==0) then
        call DipoleFieldsOnEvlMsh(pol, src, ktest, xEvl, Eexact, Hexact)  ! magnetic dipole
        ExNorm = maxval(sqrt(abs(Eexact(:,1))**2+abs(Eexact(:,2))**2+abs(Eexact(:,3))**2))
    endif

    ! Compute EFIE potencial
    if (id == 0) print *, "EFIE"
    call genEFIEPot(Epot, nEvl, xEvl, msh, ktest)

    ! Compute WGFM potencial
    if (id == 0) print *, "WGFM"
    call genWGFMPot(msh, xEvl, k1, k2, wEpot1, wHpot1, wEpot2, wHpot2)

    ! Compute BEM solution and error
    if (id==0) then
        ! Potencial test
        allocate(Es(nEvl,3))
        Es(:,1) = matmul(Epot(:,:,1), I)
        Es(:,2) = matmul(Epot(:,:,2), I)
        Es(:,3) = matmul(Epot(:,:,3), I)
        Es = Es - Eexact
        Error1 = maxval(sqrt(abs(Es(:,1))**2+abs(Es(:,2))**2+abs(Es(:,3))**2))

        ! EFIE k1
!        Es(:,1) = matmul(wEpot1(:,:,1), I)
!        Es(:,2) = matmul(wEpot1(:,:,2), I)
!        Es(:,3) = matmul(wEpot1(:,:,3), I)
!        Es = Es - Eexact
!        Error2 = maxval(sqrt(abs(Es(:,1))**2+abs(Es(:,2))**2+abs(Es(:,3))**2))

        ! EFIE k2
        Es(:,1) = matmul(wEpot2(:,:,1), I)
        Es(:,2) = matmul(wEpot2(:,:,2), I)
        Es(:,3) = matmul(wEpot2(:,:,3), I)
        Es = Es - Eexact
        Error2 = maxval(sqrt(abs(Es(:,1))**2+abs(Es(:,2))**2+abs(Es(:,3))**2))

        print *, 'h ',' Error test: '
        print *, msh%h, Error1 / ExNorm

        print *, 'h ',' Error EFIE: '
        print *, msh%h, Error2 / ExNorm
    end if

    call MPI_Finalize(ierr)
end program


! wireframe.f90
!
! Renders a wireframe model of the Tie-Figher with EGGX/ProCALL (you'll need
! some imagination ...).
!
! Author:  Philipp Engel
! Licence: ISC
module render
    implicit none
    private

    type, public :: vertex_type
        real :: x
        real :: y
        real :: z
    end type vertex_type

    type, public :: edge_type
        integer :: v1
        integer :: v2
    end type edge_type

    type, public :: point_type
        real :: x
        real :: y
    end type point_type

    public :: project
    public :: rad
    public :: rotate_x
    public :: rotate_y
    public :: rotate_z
contains
    function project(v, width, height, fov, distance) result(point)
        !! Transforms a 3D vector to a 2D vector by using perspective projection.
        type(vertex_type), intent(inout) :: v
        integer,           intent(in)    :: width
        integer,           intent(in)    :: height
        real,              intent(in)    :: fov
        real,              intent(in)    :: distance
        type(point_type)                 :: point
        real                             :: f

        f = fov / (distance + v%z)

        point%x = v%x * f + width / 2.0
        point%y = -1.0 * v%y * f + height / 2.0
    end function project

    function rad(deg)
        !! Converts an angle from deg to rad.
        real, intent(in) :: deg
        real             :: rad

        rad = deg * acos(-1.0) / 180.
    end function rad

    function rotate_x(v, angle) result(r)
        !! Rotates vector in x.
        type(vertex_type), intent(inout) :: v
        real,              intent(in)    :: angle
        type(vertex_type)                :: r

        r%x = v%x
        r%y = v%y * cos(angle) - v%z * sin(angle)
        r%z = v%z * sin(angle) + v%z * cos(angle)
    end function rotate_x

    function rotate_y(v, angle) result(r)
        !! Rotates vector in y.
        type(vertex_type), intent(inout) :: v
        real,              intent(in)    :: angle
        type(vertex_type)                :: r

        r%x = v%z * sin(angle) + v%x * cos(angle)
        r%y = v%y
        r%z = v%z * cos(angle) - v%x * sin(angle)
    end function rotate_y

    function rotate_z(v, angle) result(r)
        !! Rotates vector in z.
        type(vertex_type), intent(inout) :: v
        real,              intent(in)    :: angle
        type(vertex_type)                :: r

        r%x = v%x * cos(angle) - v%y * sin(angle)
        r%y = v%x * sin(angle) - v%y * cos(angle)
        r%z = v%z
    end function rotate_z
end module render

program main
    use, intrinsic :: iso_c_binding, only: c_null_char
    use :: procall
    use :: render
    implicit none

    character(len=*), parameter :: OBJ_FILE = 'tie.obj'
    integer,          parameter :: WIN_WIDTH  = 640
    integer,          parameter :: WIN_HEIGHT = 480

    integer :: key
    integer :: rc
    integer :: win
    real    :: d, x, y, z

    type(edge_type),   allocatable :: edges(:)
    type(vertex_type), allocatable :: vertices(:)
    type(point_type),  allocatable :: points(:)

    ! Load vertices and edges from Wavefront OBJ file, initialise `points`
    ! array.
    call init(vertices, edges, points, OBJ_FILE, rc)

    if (rc /= 0) then
        print '(3a)', 'Error: loading file "', OBJ_FILE, '" failed'
        stop
    end if

    ! Initialise ProCALL.
    call gopen(WIN_WIDTH, WIN_HEIGHT, win)                  ! Open X11 window.
    call winname(win, 'Fortran Wireframe' // c_null_char)   ! Set window title.
    call gsetbgcolor(win, 'black' // c_null_char)           ! Set background colour.
    call gsetnonblock(1)                                    ! Enable non-blocking input.
    call layer(win, 0, 1)                                   ! Enable double buffering.

    ! Rotation angles in x, y, z, and camera distance to object.
    x = 0.0; y = 0.0; z = 0.0
    d = 4.0

    do
        call ggetch(key)
        if (key == PROCALL_KEY_ESCAPE) exit

        y = modulo(y + rad(1.0), rad(360.0)) ! Rotate in y.
        call update(vertices, points, WIN_WIDTH, WIN_HEIGHT, x, y, z, d)
        call render(win, points, edges)
        call msleep(20)
    end do

    call gcloseall()
contains
    subroutine init(vertices, edges, points, file_path, stat)
        type(vertex_type), allocatable, intent(out)           :: vertices(:)
        type(edge_type),   allocatable, intent(out)           :: edges(:)
        type(point_type),  allocatable, intent(out)           :: points(:)
        character(len=*),               intent(in)            :: file_path
        integer,                        intent(out), optional :: stat
        integer                                               :: rc
        logical                                               :: file_exists

        if (present(stat)) stat = 0

        inquire (file=trim(file_path), exist=file_exists)

        if (.not. file_exists) then
            if (present(stat)) stat = -1
            return
        end if

        call load(trim(file_path), vertices, edges, rc)

        if (rc /= 0) then
            if (present(stat)) stat = rc
            return
        end if

        allocate (points(size(vertices)))
    end subroutine init

    subroutine load(file_path, vertices, edges, stat)
        !! Loads and parses a Wavefront OBJ file.
        character(len=*),               intent(in)            :: file_path
        type(vertex_type), allocatable, intent(inout)         :: vertices(:)
        type(edge_type),   allocatable, intent(inout)         :: edges(:)
        integer,                        intent(out), optional :: stat
        character(len=80)                                     :: buffer
        integer                                               :: fu, i, j, rc
        integer                                               :: nedges, nvertices

        ! Open file for reading.
        open (action='read', file=trim(file_path), newunit=fu, iostat=rc)

        if (rc /= 0) then
            if (present(stat)) stat = rc
            return
        end if

        ! Count number of edges/vertices in file.
        nedges    = 0
        nvertices = 0

        do
            read (fu, '(a)', iostat=rc) buffer
            if (rc /= 0) exit

            if (buffer(1:1) == 'f') nedges = nedges + 1
            if (buffer(1:1) == 'v') nvertices = nvertices + 1
        end do

        if (nedges == 0 .or. nvertices == 0) then
            close (fu)
            if (present(stat)) stat = -1
            return
        end if

        ! Allocate edge and vertex arrays.
        if (allocated(edges)) deallocate (edges)
        allocate (edges (nedges))

        if (allocated(vertices)) deallocate (vertices)
        allocate (vertices(nvertices))

        ! Read edges and vertices into arrays.
        rewind (fu)

        i = 1
        j = 1

        do
            read (fu, '(a)', iostat=rc) buffer
            if (rc /= 0) exit

            select case (buffer(1:1))
                case ('f')
                    read (buffer(2:), *, iostat=rc) edges(i)
                    if (rc /= 0) cycle
                    i = i + 1

                case ('v')
                    read (buffer(2:), *, iostat=rc) vertices(j)
                    if (rc /= 0) cycle
                    j = j + 1

                case default
                    cycle
            end select
        end do

        close (fu)
        if (present(stat)) stat = 0
    end subroutine load

    subroutine update(vertices, points, width, height, x, y, z, distance)
        !! Rotates the 3D object.
        type(vertex_type), intent(inout) :: vertices(:)
        type(point_type),  intent(inout) :: points(:)
        integer,           intent(in)    :: width
        integer,           intent(in)    :: height
        real,              intent(in)    :: x
        real,              intent(in)    :: y
        real,              intent(in)    :: z
        real,              intent(in)    :: distance
        integer                          :: i
        type(vertex_type)                :: v

        do i = 1, size(vertices, 1)
            v = vertices(i)
            v = rotate_x(v, x)
            v = rotate_y(v, y)
            v = rotate_z(v, z)
            points(i) = project(v, width, height, 256.0, distance)
        end do
    end subroutine update

    subroutine render(win, points, edges)
        !! Renders the scene on the layer and copies layer to screen.
        integer,          intent(inout) :: win
        type(point_type), intent(inout) :: points(:)
        type(edge_type),  intent(inout) :: edges(:)
        real                            :: x1, y1, x2, y2
        integer                         :: i

        call gclr(win)
        call newpencolor(win, PROCALL_CYAN)

        do i = 1, size(edges)
            x1 = points(edges(i)%v1)%x
            y1 = points(edges(i)%v1)%y
            x2 = points(edges(i)%v2)%x
            y2 = points(edges(i)%v2)%y

            call moveto(win, x1, y1)
            call lineto(win, x2, y2)
        end do

        call copylayer(win, 1, 0)
    end subroutine render
end program main


C++**********************************************************************
C CONVERT_FLUX
C Convert magnitudes to F_lambda (erg/s/cm2/A)
C
C JLP
C Version 29-06-90
C++**********************************************************************
	PROGRAM CONVERT_FLUX
	DOUBLE PRECISION XLAMBDA,XMAGNI,FLAMBDA,CLIGHT
	CLIGHT= 2.9979E+18

	OPEN(1,FILE='convert_flux.log',STATUS='unknown')

	PRINT 80
80	FORMAT(' CONVERT_FLUX Version of 15-03-89',/,
     1	' 1. Conversion Magnitude to Flambda',
     1	' (Stone et Baldwin 1983, MNRAS 204, 347)',/)
	WRITE(1,80)
	 WRITE(1,69)
69	 FORMAT('  LAMBDA (A)       MAGNITUDE          FLUX   (erg/s/cm2/A)')

C Starting the loop:

66	PRINT *,' Lambda (A) and magnitude : (0,0 to exit)'
	READ(5,*) XLAMBDA,XMAGNI
	IF((XLAMBDA.NE.0).AND.(XMAGNI.NE.0)) THEN
	 FLAMBDA= CLIGHT * (10**(-0.4*(XMAGNI+48.595))) /(XLAMBDA**2)
	 WRITE(6,70) XLAMBDA,XMAGNI,FLAMBDA
	 WRITE(1,70) XLAMBDA,XMAGNI,FLAMBDA
70	 FORMAT(2X,F12.4,2X,F12.4,2X,G14.6)
	 GOTO 66
	ENDIF

	CLOSE(1)
        PRINT *,' Output in "convert_flux.log"'
	END


!***********************************************************
!*               Copyright (c) Wenbin Yu                   *
!*              All rights reserved                        *
!*          Mechanical and Aerospace Engineering           *
!*                                                         *
!*                Utah State University                    *
!***********************************************************
!=================================================================
!
!> A module for defining time functions needed for both prescribed  concentrated and distributed conditions
!
!=================================================================
MODULE TimeFunctionModule

USE GlobalDataFun

IMPLICIT NONE

PRIVATE       ! So everything is private, except declared by PUBLIC
PUBLIC TimeFunction,GetTimeFunction,InitTF,InputEchoTimeFunctions,CurrentValues

TYPE TimeFunction
!~      PRIVATE
	 INTEGER   ::fun_type             !<function type: 0, user defined; 1, harmonic
	 REAL(DBL) ::ts           !< starting time
	 REAL(DBL) ::te               !< ending time
	 INTEGER   ::entries              !< number of entries
	 REAL(DBL),POINTER::time_val(:)   !< the ith time, in increasing order; the amplitude of the harmonic
	 REAL(DBL),POINTER::fun_val(:)    !< the ith functional value; the period of the harmonic
	 REAL(DBL),POINTER::phase_val(:)  !< the phase value of the harmonic
END TYPE TimeFunction

CONTAINS

!*********************************************************
!*                                                       *
!> get the time function value for any arbitrary time
!! from a piecewise linear function or harmonic function
!! decide where t is located, then interpret the value
!*                                                       *
!*********************************************************
FUNCTION GetTimeFunction(tf,t) RESULT(res)

TYPE (TimeFunction),INTENT(IN)::tf
REAL(DBL),INTENT(IN)::t
REAL(DBL):: res
REAL(DBL)::t1, t2 !< t1<=t<=t2
REAL(DBL)::f1,f2   !< function values corresponding to t1, t2, respectively.

INTEGER:: n
INTEGER:: i
REAL(DBL):: tt ! a temp variable for the current time t, if t<ts, t=ts, if t>te, t=te

IF(tf%fun_type==0)THEN ! user defined piecewise linear time function
	n=COUNT(t>tf%time_val)

	IF(n==0) THEN
		res=tf%fun_val(1)   ! t is smaller than or equal to the time of first entry, and the fun equal to the first entry
	ELSE IF(n==tf%entries) THEN
		res=tf%fun_val(tf%entries) ! t is larger than the time of last entry, and the fun equal to the last entry
	ELSE
		t1=tf%time_val(n);   f1=tf%fun_val(n)
		t2=tf%time_val(n+1); f2=tf%fun_val(n+1)
		res=(f2-f1)/(t2-t1)*(t-t1)+f1 ! linear interplation
	ENDIF
ELSE IF(tf%fun_type==1) THEN ! harmonic functions
      res=0.0d0
   IF(t<tf%ts) THEN
		tt=tf%ts
   ELSE IF(t>tf%te) THEN
		tt=tf%te
   ELSE
        tt=t
   ENDIF
   DO i=1, tf%entries
      f1=tf%time_val(i)
	  IF(tf%fun_val(i)/=0.D0) THEN
		  IF(tf%fun_val(i)==-1.0D0) THEN
			f1=f1*SIN(2.0D0*PI*tf%phase_val(i))
		  ELSE
			f1=f1*SIN(2.0D0*PI*(tt/tf%fun_val(i)+tf%phase_val(i)))
		  ENDIF
	  ENDIF
      res=res+f1
   ENDDO
ELSE ! Other types of time functions to be implemented

ENDIF

END FUNCTION GetTimeFunction
!*********************************************************

!*********************************************************
!*                                                       *
!> Initialize the time function
!*                                                       *
!*********************************************************

ELEMENTAL FUNCTION InitTF() RESULT(res)

TYPE (TimeFunction)::res

res%fun_type=0
res%ts=0.d0
res%te=0.d0
res%entries=0
NULLIFY(res%time_val,res%fun_val, res%phase_val)

END FUNCTION InitTF
!*********************************************************

!************************************************************
!*                                                          *
!> Input and echo Time Functions
!*															*
!************************************************************
FUNCTION InputEchoTimeFunctions(IN,EIN,error) RESULT(res)

INTEGER,INTENT(IN)::IN,EIN !< file units for input anf echo files, respectively
CHARACTER(*),INTENT(OUT)::error
TYPE (TimeFunction)::res
INTEGER:: i,n

READ(IN,*,IOSTAT=in_stat) res%fun_type
IF(IOError('read function type for a time function',error)) RETURN

READ(IN,*,IOSTAT=in_stat) res%ts, res%te
IF(IOError('read starting and ending time for a time function',error)) RETURN

READ(IN,*,IOSTAT=in_stat) n
IF(IOError('read number of entries for a time function',error)) RETURN

res%entries=n

ALLOCATE(res%time_val(n),STAT=allo_stat)
IF(MemoryError('res%time_val',error)) GOTO 9999

ALLOCATE(res%fun_val(n),STAT=allo_stat)
IF(MemoryError('res%fun_val',error)) GOTO 9999

IF(res%fun_type==1) THEN
	ALLOCATE(res%phase_val(n),STAT=allo_stat)
	IF(MemoryError('res%phase_val',error)) GOTO 9999
ENDIF

DO i=1,   n
	IF(res%fun_type==0) THEN
		READ(IN,*,IOSTAT=in_stat)res%time_val(i),res%fun_val(i)
	ELSEIF(res%fun_type==1)THEN
		READ(IN,*,IOSTAT=in_stat)res%time_val(i),res%fun_val(i),res%phase_val(i)
	ELSE
	    error='Time function type is not defined'
        WRITE(0,*) 'TimeFunction.f90 : ',error
        ERROR STOP 127
    ENDIF

	IF(IOError('read values needed to define time functions',error)) RETURN
ENDDO

WRITE(EIN,*)
WRITE(EIN,*) 'Function Type=',     res%fun_type
WRITE(EIN,*) 'Starting/Ending Time=', res%ts, res%te
WRITE(EIN,*) 'Number of Entries=', res%entries
WRITE(EIN,*) '----------------------------------'

DO i=1,res%entries
	IF( res%fun_type==0)THEN
		CALL WriteVec(EIN,(/res%time_val(i),res%fun_val(i)/))
	ELSEIF(res%fun_type==1)THEN
		CALL WriteVec(EIN,(/res%time_val(i),res%fun_val(i),res%phase_val(i)/))
	ELSE
	ENDIF
ENDDO

9999 IF(error/='')THEN
    WRITE(0,*) 'TimeFunction.f90 : ',error
    ERROR STOP 128
ENDIF

END FUNCTION InputEchoTimeFunctions
!************************************************************

!************************************************************
!*                                                          *
!>  Evaluate current function based on magnitude and time
!* function and current time                                *
!* vec: magnitude                                           *
!* vec_tf: time function #   								*
!* time_fun: array holding all time functions               *
!* time_current:  current time for evaluation               *
!************************************************************
FUNCTION CurrentValues(vec,vec_tf,time_fun,time_current)

REAL(DBL),INTENT(IN)::vec(:)
INTEGER,  INTENT(IN)::vec_tf(:)
TYPE (TimeFunction),INTENT(IN)::time_fun(:)
REAL(DBL),INTENT(IN)::time_current
REAL(DBL)           ::CurrentValues(SIZE(vec))
INTEGER:: j

CurrentValues=vec  ! initialize to be the magnitude

DO j=1, SIZE(vec)
   IF(vec_tf(j)/=0.AND.vec(j)/=0.0D0) &
     CurrentValues(j)  =vec(j) *GetTimeFunction(time_fun(vec_tf(j)),time_current)
ENDDO

END FUNCTION CurrentValues
!************************************************************

!================================================
! Subroutines/functions used internally
!================================================

END MODULE TimeFunctionModule
!===========================================================


      SUBROUTINE PZBSSOLVER1( N, M, IM, JM, DESCM, LAMBDA, X, IX, JX,
     $                        DESCX, WORK, LWORK, IWORK, LIWORK, INFO )
*
      IMPLICIT NONE
*
*     .. Scalar Arguments ..
      INTEGER            N, IM, JM, IX, JX, LWORK, LIWORK, INFO
*     ..
*     .. Array Arguments ..
      INTEGER            DESCM( * ), DESCX( * ), IWORK( * )
      DOUBLE PRECISION   M( * ), LAMBDA( * ), WORK( * )
      COMPLEX*16         X( * )
*     ..
*
*  Purpose
*  =======
*
*  PZBSSOLVER1() computes all eigenvalues and (both right and
*  left) eigenvectors of 2n-by-2n complex matrix
*
*     H = [       A,        B;
*          -conj(B), -conj(A) ],
*
*  where A is n-by-n Hermitian, and B is n-by-n symmetric.
*
*  On entry, the information of H is provided in the lower triangular
*  part of
*
*     M = [ real(A)+real(B), imag(A)-imag(B);
*          -imag(A)-imag(B), real(A)-real(B) ].
*
*  The matrix M is required to be positive definite.
*
*  The structure of H leads to the following properties.
*
*     1) H is diagonalizable with n pairs of real eigenvalues
*        (lambda_i, -lambda_i).
*
*     2) The eigenvectors of H has the block structure
*
*           X = [ X_1, conj(X_2);     Y = [ X_1, -conj(X_2);
*                 X_2, conj(X_1) ],        -X_2,  conj(X_1) ],
*
*        and satisfy that
*
*           X_1**T * X_2 = X_2**T * X_1,
*           X_1**H * X_1 - X_2**H * X_2 = I,
*           Y**H * X = I,
*           H * X = X * diag(lambda, -lambda),
*           Y**H * H = diag(lambda, -lambda) * Y**H.
*
*  On exit, only the positive eigenvalues and the corresponding right
*  eigenvectors are returned.  The eigenvalues are sorted in ascending
*  order.  The eigenvectors are normalized (i.e., X = [ X_1; X_2 ] with
*  X_1**H * X_1 - X_2**H * X_2 = I).
*
*  M is destroyed on exit.
*
*  Notes
*  =====
*
*  Each global data object is described by an associated description
*  vector.  This vector stores the information required to establish
*  the mapping between an object element and its corresponding process
*  and memory location.
*
*  Let A be a generic term for any 2D block cyclicly distributed array.
*  Such a global array has an associated description vector DESCA.
*  In the following comments, the character _ should be read as
*  "of the global array".
*
*  NOTATION        STORED IN      EXPLANATION
*  --------------- -------------- --------------------------------------
*  DTYPE_A(global) DESCA( DTYPE_ )The descriptor type.  In this case,
*                                 DTYPE_A = 1.
*  CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
*                                 the BLACS process grid A is distribu-
*                                 ted over. The context itself is glo-
*                                 bal, but the handle (the integer
*                                 value) may vary.
*  M_A    (global) DESCA( M_ )    The number of rows in the global
*                                 array A.
*  N_A    (global) DESCA( N_ )    The number of columns in the global
*                                 array A.
*  MB_A   (global) DESCA( MB_ )   The blocking factor used to distribute
*                                 the rows of the array.
*  NB_A   (global) DESCA( NB_ )   The blocking factor used to distribute
*                                 the columns of the array.
*  RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
*                                 row of the array A is distributed.
*  CSRC_A (global) DESCA( CSRC_ ) The process column over which the
*                                 first column of the array A is
*                                 distributed.
*  LLD_A  (local)  DESCA( LLD_ )  The leading dimension of the local
*                                 array.  LLD_A >= MAX(1,LOCr(M_A)).
*
*  Let K be the number of rows or columns of a distributed matrix,
*  and assume that its process grid has dimension p x q.
*  LOCr( K ) denotes the number of elements of K that a process
*  would receive if K were distributed over the p processes of its
*  process column.
*  Similarly, LOCc( K ) denotes the number of elements of K that a
*  process would receive if K were distributed over the q processes of
*  its process row.
*  The values of LOCr() and LOCc() may be determined via a call to the
*  ScaLAPACK tool function, NUMROC:
*          LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
*          LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
*  An upper bound for these quantities may be computed by:
*          LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
*          LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
*
*  Arguments
*  =========
*
*  N       (global input) INTEGER
*          The number of rows and columns of A and B.
*          The size of M and X are N*N and (2N)*N, respectively.
*          N >= 0.
*
*  M       (local input and output) DOUBLE PRECISION pointer into the
*          local memory to an array of dimension
*          (LLD_M, LOCc(JM+2*N-1)).
*          On entry, the symmetric positive definite matrix M. Only the
*          lower triangular part of M is used to define the elements of
*          the symmetric matrix.
*          On exit, all entries of M are destroyed.
*
*  IM      (global input) INTEGER
*          The row index in the global array M indicating the first
*          row of sub( M ).
*
*  JM      (global input) INTEGER
*          The column index in the global array M indicating the
*          first column of sub( M ).
*
*  DESCM   (global and local input) INTEGER array of dimension DLEN_.
*          The array descriptor for the distributed matrix M.
*
*  LAMBDA  (global output) DOUBLE PRECISION array, dimension (N)
*          On normal exit LAMBDA contains the positive eigenvalues of H
*          in ascending order.
*
*  X       (local output) COMPLEX*16 array,
*          global dimension (2N, N),
*          local dimension ( LLD_X, LOCc(JX+N-1) )
*          On normal exit X contains the normalized right eigenvectors
*          of H corresponding to the positive eigenvalues.
*
*  IX      (global input) INTEGER
*          X's global row index, which points to the beginning of the
*          submatrix which is to be operated on.
*          In this version, only IX = JX = 1 is supported.
*
*  JX      (global input) INTEGER
*          X's global column index, which points to the beginning of
*          the submatrix which is to be operated on.
*          In this version, only IX = JX = 1 is supported.
*
*  DESCX   (global and local input) INTEGER array of dimension DLEN_.
*          The array descriptor for the distributed matrix X.
*          DESCX( CTXT_ ) must equal DESCA( CTXT_ )
*
*  WORK    (local workspace/output) DOUBLE PRECISION array,
*          dimension (LWORK)
*          On output, WORK( 1 ) returns the minimal amount of workspace
*          needed to guarantee completion.
*          If the input parameters are incorrect, WORK( 1 ) may also be
*          incorrect.
*
*  LWORK   (local input) INTEGER
*          The length of the workspace array WORK.
*          If LWORK = -1, the LWORK is global input and a workspace
*          query is assumed; the routine only calculates the minimum
*          size for the WORK/IWORK array. The required workspace is
*          returned as the first element of WORK/IWORK and no error
*          message is issued by PXERBLA.
*
*  IWORK   (local workspace/output) INTEGER array,
*          dimension (LIWORK)
*          On output, IWORK( 1 ) returns the minimal amount of workspace
*          needed to guarantee completion.
*          If the input parameters are incorrect, IWORK( 1 ) may also be
*          incorrect.
*
*  LIWORK   (local input) INTEGER
*          The length of the workspace array IWORK.
*          If LIWORK = -1, the LIWORK is global input and a workspace
*          query is assumed; the routine only calculates the minimum
*          size for the WORK/IWORK array. The required workspace is
*          returned as the first element of WORK/IWORK and no error
*          message is issued by PXERBLA.
*
*  INFO    (global output) INTEGER
*          = 0:  successful exit
*          < 0:  If the i-th argument is an array and the j-entry had
*                an illegal value, then INFO = -(i*100+j), if the i-th
*                argument is a scalar and had an illegal value, then
*                INFO = -i.
*          > 0:  The eigensolver did not converge.
*
*  Alignment requirements
*  ======================
*
*  This subroutine requires M and X to be distributed consistently in
*  the sense that DESCM( : ) = DESCX( : ) except for the fourth entry,
*  despite that X is complex and M is real.
*  In addition, square blocks ( i.e., MB = NB ) are required.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
     $                   LLD_, MB_, M_, NB_, N_, RSRC_
      PARAMETER          ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
     $                     CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
     $                     RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
      DOUBLE PRECISION   ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            ICTXT, NPROCS, NPROW, NPCOL, MYROW, MYCOL, NB,
     $                   TWON, I, LWKOPT, LIWKOPT, LLWORK, LLIWORK,
     $                   LOCALMAT, MROWS, MCOLS, LLDM, DIMV, NSPLIT,
     $                   INDD, INDE, INDTAU, INDU, INDV, INDW,
     $                   INDGAP, INDWORK, INDIBLOCK, INDISPLIT,
     $                   INDIFAIL, INDICLUSTR, INDIWORK, ITMP
      DOUBLE PRECISION   ABSTOL, ORFAC
      DOUBLE PRECISION   T_CHOL, T_FORMW, T_TRIDIAG1, T_TRIDIAG2,
     $                   T_DIAG1, T_DIAG2, T_DIAG3, T_VEC1, T_VEC2,
     $                   T_PREP
*     ..
*     .. Local Arrays ..
      INTEGER            DESCU( DLEN_ ), DESCV( DLEN_ ), DESCW( DLEN_ ),
     $                   ITMP2( 14 ), ITMP3( N )
      DOUBLE PRECISION   DTMP( 1 )
      DOUBLE PRECISION   DTMP2( 7 )
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE, DSQRT
*     ..
*     .. External Functions ..
      EXTERNAL           NUMROC, PDLAMCH, MPI_WTIME
      INTEGER            NUMROC
      DOUBLE PRECISION   PDLAMCH, MPI_WTIME
*     ..
*     .. External Subroutines ..
      EXTERNAL           PDSYRK, PDTRMM, PDTRSM, PDLACPY, PDLASET,
     $                   PDPOTRF, PDSTEBZ, PDSTEIN, PXERBLA,
     $                   BLACS_GRIDINFO, CHK1MAT,
     $                   PDSORTEIG, PZBSAUX1, PDSSTRD, PDORMTR,
     $                   PDGEADD, PZLASCL
*     ..
*     .. Executable Statements ..
*
      T_PREP = MPI_WTIME()
      INFO = 0
      TWON = 2*N
      ICTXT = DESCM( CTXT_ )
      CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
      NPROCS = NPROW*NPCOL
      IF ( NPROW .EQ. -1 ) THEN
         INFO = -( 500+CTXT_ )
      END IF
*
*     Test the input arguments.
*
      IF ( INFO .EQ. 0 .AND. N .LT. 0 ) THEN
         INFO = -1
      END IF
      IF ( INFO .EQ. 0 )
     $   CALL CHK1MAT( TWON, 1, TWON, 1, IM, JM, DESCM, 5, INFO )
      IF ( INFO .EQ. 0 .AND. DESCM( MB_ ) .NE. DESCM( NB_ ) )
     $   INFO = -( 500+MB_ )
      IF ( INFO .EQ. 0 )
     $   CALL CHK1MAT( TWON, 1, N, 1, IX, JX, DESCX, 10, INFO )
      IF ( INFO .EQ. 0 .AND. DESCX( MB_ ) .NE. DESCX( NB_ ) )
     $   INFO = -( 1000+MB_ )
*
*     Compute required workspace.
*
      IF ( INFO .EQ. 0 ) THEN
*
*        Set up local indices for the workspace.
*
         LQUERY = LWORK .EQ. -1 .OR. LIWORK .EQ. -1
         ABSTOL = TWO*PDLAMCH( ICTXT, 'S' )
         ORFAC = PDLAMCH( ICTXT, 'P' )
         NB = DESCM( NB_ )
         LLDM = DESCM( LLD_ )
         MROWS = NUMROC( TWON, NB, MYROW, 0, NPROW )
         MCOLS = NUMROC( TWON, NB, MYCOL, 0, NPCOL )
         LOCALMAT = MAX( NB, LLDM )*MCOLS
         DESCW( 1:DLEN_ ) = DESCM( 1:DLEN_ )
         DESCU( 1:DLEN_ ) = DESCM( 1:DLEN_ )
         DESCV( 1:DLEN_ ) = DESCM( 1:DLEN_ )
         INDE = 1
         INDW = INDE + TWON
         INDU = INDW + MAX( TWON+NPROCS, LOCALMAT )
         INDV = INDU + LOCALMAT
         INDWORK = INDV + MAX( TWON, LOCALMAT )
         INDD = INDW
         INDTAU = INDV
         INDGAP = INDW + TWON
         LLWORK = LWORK - INDWORK + 1
         INDIBLOCK = 1
         INDISPLIT = INDIBLOCK + TWON
         INDIFAIL = INDISPLIT + TWON
         INDICLUSTR = INDIFAIL + N
         INDIWORK = INDICLUSTR + 2*NPROCS
         LLIWORK = LIWORK - INDIWORK + 1
*
*        Estimate the workspace required by external subroutines.
*
         CALL PDSSTRD( 'L', TWON, DTMP, 1, 1, DESCW, DTMP, DTMP, WORK,
     $        -1, ITMP )
         LWKOPT = INT( WORK( 1 ) )
         CALL PDORMTR( 'R', 'L', 'N', TWON, TWON, DTMP, 1, 1, DESCW,
     $        DTMP, DTMP, 1, 1, DESCU, WORK, -1, ITMP )
         LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) )
         CALL PDSTEBZ( ICTXT, 'I', 'B', TWON, ZERO, ZERO, N+1, TWON,
     $        ABSTOL, DTMP, DTMP, DIMV, NSPLIT, LAMBDA, ITMP, ITMP,
     $        DTMP2, -1, ITMP2, -1, ITMP )
         LWKOPT = MAX( LWKOPT, INT( DTMP2( 1 ) ) )
         LIWKOPT = ITMP2( 1 )
         DO I = 1, N
            ITMP3(I) = I
         END DO
         CALL PDSTEIN( TWON, DTMP, DTMP, N, LAMBDA, ITMP3, ITMP,
     $        ORFAC, DTMP, 1, 1, DESCU, WORK, -1, IWORK, -1, ITMP,
     $        ITMP, DTMP, ITMP )
         LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) )
         LIWKOPT = MAX( LIWKOPT, IWORK( 1 ) )
*
         LWKOPT = INDWORK - 1 + MAX( LWKOPT, LOCALMAT )
         LIWKOPT = INDIWORK - 1 + LIWKOPT
         IF ( .NOT. LQUERY ) THEN
            IF ( LWORK .LT. LWKOPT ) THEN
               INFO = -12
            ELSE IF ( LIWORK .LT. LIWKOPT ) THEN
               INFO = -14
            END IF
         END IF
      END IF
*
      IF ( INFO .NE. 0 ) THEN
         CALL PXERBLA( ICTXT, 'PZBSSOLVER1', -INFO )
         RETURN
      END IF
      WORK( 1 ) = DBLE( LWKOPT )
      IWORK( 1 ) = LIWKOPT
      IF ( LQUERY )
     $   RETURN
*
*     Quick return if possible.
*
      IF ( N .EQ. 0 )
     $   RETURN
      T_PREP = MPI_WTIME() - T_PREP
!      IF ( MYROW+MYCOL .EQ. 0 )
!     $   WRITE( *, * ) 't_prep = ', T_PREP, ';'
*
*     Compute the Cholesky factorization M = L * L**T.
*     In case of failure, a general solver is needed.
*
      T_CHOL = MPI_WTIME()
      CALL PDPOTRF( 'L', TWON, M, 1, 1, DESCM, ITMP )
      T_CHOL = MPI_WTIME() - T_CHOL
!      IF ( MYROW+MYCOL .EQ. 0 )
!     $   WRITE( *, * ) 't_chol = ', T_CHOL, ';'
!      CALL PDLAPRNT( TWON, TWON, M, 1, 1, DESCM, 0, 0, 'L', 6,
!     $     WORK( INDWORK ) )
!      IF ( MYROW+MYCOL .EQ. 0 )
!     $   WRITE( *, * ) "L=tril(L);"
      IF ( ITMP .NE. 0 ) THEN
         INFO = -2
         RETURN
      END IF
*
*     Explicitly formulate W = L**T * J * L,
*     where
*
*        J = [   0, I_n;
*             -I_n,   0 ]
*
*     is the standard symplectic matrix.
*     Only the lower triangular part of W is filled by the correct
*     values.
*
      T_FORMW = MPI_WTIME()
      CALL PDLASET( 'A', TWON, TWON, ZERO, ZERO, WORK( INDW ), 1, 1,
     $     DESCW )
      CALL PDGEADD( 'T', N, N, -ONE, M, N+1, 1, DESCM, ONE,
     $     WORK( INDW ), 1, 1, DESCW )
      CALL PDTRADD( 'U', 'T', N, N, -ONE, M, N+1, N+1, DESCM, ONE,
     $     WORK( INDW ), N+1, 1, DESCW )
      CALL PDTRMM( 'R', 'L', 'N', 'N', TWON, N, ONE, M, 1, 1, DESCM,
     $     WORK( INDW ), 1, 1, DESCW )
      CALL PDLACPY( 'A', N, N, WORK( INDW ), 1, 1, DESCW,
     $     WORK( INDV ), 1, 1, DESCV )
      CALL PDGEADD( 'T', N, N, -ONE, WORK( INDV ), 1, 1, DESCV,
     $     ONE, WORK( INDW ), 1, 1, DESCW )
      T_FORMW = MPI_WTIME() - T_FORMW
!      IF ( MYROW+MYCOL .EQ. 0 )
!     $   WRITE( *, * ) 't_formw = ', T_FORMW, ';'
!      CALL PDLAPRNT( TWON, TWON, WORK( INDW ), 1, 1, DESCW, 0, 0, 'W',
!     $     6, WORK( INDWORK ) )
*
*     Tridiagonalization: U**T * W * U = T.
*
      T_TRIDIAG1 = MPI_WTIME()
      CALL PDSSTRD( 'L', TWON, WORK( INDW ), 1, 1, DESCW, WORK( INDE ),
     $     WORK( INDTAU ), WORK( INDWORK ), LLWORK, ITMP )
!      CALL PDLAPRNT( TWON, TWON, WORK( INDW ), 1, 1, DESCW, 0, 0, 'T',
!     $     6, WORK( INDWORK ) )
      DO I = 1, TWON-1
         CALL PDELGET( 'A', ' ', WORK( INDE + I-1 ), WORK( INDW ), I+1,
     $        I, DESCW )
         WORK( INDE + I-1 ) = -WORK( INDE + I-1 )
!         IF ( MYROW+MYCOL .EQ. 0 )
!     $      WRITE( *, * ) 'E(', I, ', 1) =', WORK( INDE + I-1 ), ';'
      END DO
      T_TRIDIAG1 = MPI_WTIME() - T_TRIDIAG1
!      IF ( MYROW+MYCOL .EQ. 0 )
!     $   WRITE( *, * ) 't_tridiag1 = ', T_TRIDIAG1, ';'
*
*     Formulate sqrt(1/2) * L * U.
*
      T_TRIDIAG2 = MPI_WTIME()
      CALL PDLASET( 'A', TWON, TWON, ZERO, ZERO, WORK( INDU ), 1, 1,
     $     DESCU )
      CALL PDTRADD( 'L', 'N', TWON, TWON, DSQRT( ONE/TWO ), M, 1, 1,
     $     DESCM, ZERO, WORK( INDU ), 1, 1, DESCU )
      CALL PDORMTR( 'R', 'L', 'N', TWON, TWON, WORK( INDW ), 1, 1,
     $     DESCW, WORK( INDTAU ), WORK( INDU ), 1, 1, DESCU,
     $     WORK( INDWORK ), LLWORK, ITMP )
      T_TRIDIAG2 = MPI_WTIME() - T_TRIDIAG2
!      IF ( MYROW+MYCOL .EQ. 0 )
!     $   WRITE( *, * ) 't_tridiag2 = ', T_TRIDIAG2, ';'
!      CALL PDLAPRNT( TWON, TWON, WORK( INDU ), 1, 1, DESCU, 0, 0, 'U',
!     $     6, WORK( INDWORK ) )
*
*     Diagonalize the tridiagonal matrix
*
*        D**H * (-i*T) * D = V * diag(lambda) * V**T,
*
*     where D = diag{1,i,i^2,i^3,...}.
*     Only the positive half of the eigenpairs are computed.
*
      DO I = 0, TWON-1
         WORK( INDD + I ) = ZERO
      END DO
*
      T_DIAG1 = MPI_WTIME()
      CALL PDSTEBZ( ICTXT, 'I', 'B', TWON, ZERO, ZERO, N+1, TWON,
     $     ABSTOL, WORK( INDD ), WORK( INDE ), DIMV, NSPLIT, LAMBDA,
     $     IWORK( INDIBLOCK ), IWORK( INDISPLIT ), WORK( INDWORK ),
     $     LLWORK, IWORK( INDIWORK ), LLIWORK, ITMP )
      T_DIAG1 = MPI_WTIME() - T_DIAG1
!      IF ( MYROW+MYCOL .EQ. 0 )
!     $   WRITE( *, * ) 't_diag1 = ', T_DIAG1, ';'
      IF ( ITMP .NE. 0 ) THEN
         INFO = ITMP
         WRITE( *, * ) '% PDSTEBZ fails with INFO =', INFO
         RETURN
      END IF
!      IF ( MYROW+MYCOL .EQ. 0 ) THEN
!         DO I = 1, TWON
!            WRITE( *, * ) 'lambda0(', I, ', 1) =', LAMBDA( I ), ';'
!         END DO
!      END IF
*
      T_DIAG2 = MPI_WTIME()
      CALL PDSTEIN( TWON, WORK( INDD ), WORK( INDE ), DIMV, LAMBDA,
     $     IWORK( INDIBLOCK ), IWORK( INDISPLIT ), ORFAC,
     $     WORK( INDV ), 1, 1, DESCV, WORK( INDWORK ), LLWORK,
     $     IWORK( INDIWORK ), LLIWORK, IWORK( INDIFAIL ),
     $     IWORK( INDICLUSTR ), WORK( INDGAP ), ITMP )
      IF ( ITMP .NE. 0 ) THEN
         INFO = ITMP
         WRITE( *, * ) '% PDSTEIN fails with INFO =', INFO
         RETURN
      END IF
      T_DIAG2 = MPI_WTIME() - T_DIAG2
!      IF ( MYROW+MYCOL .EQ. 0 )
!     $   WRITE( *, * ) 't_diag2 = ', T_DIAG2, ';'
      T_DIAG3 = MPI_WTIME()
      CALL PDSORTEIG( TWON, N, LAMBDA, WORK( INDV ), 1, 1, DESCV, 0 )
*
*     Orthogonalize the eigenvectors.
*
      CALL PDSYRK( 'L', 'T', N, TWON, ONE, WORK( INDV ), 1, 1, DESCV,
     $     ZERO, WORK( INDW ), 1, 1, DESCW )
      CALL PDPOTRF( 'L', N, WORK( INDW ), 1, 1, DESCW, ITMP )
      CALL PDTRSM( 'R', 'L', 'T', 'N', TWON, N, ONE, WORK( INDW ),
     $     1, 1, DESCW, WORK( INDV ), 1, 1, DESCV )
      T_DIAG3 = MPI_WTIME() - T_DIAG3
!      IF ( MYROW+MYCOL .EQ. 0 )
!     $   WRITE( *, * ) 't_diag3 = ', T_DIAG3, ';'
!      CALL PDLAPRNT( TWON, N, WORK( INDV ), 1, 1, DESCV, 0, 0, 'V0',
!     $     6, WORK( INDWORK ) )
*
*     Restore the eigenvectors of H:
*
*        X = Q * L**{-T} * U * D * V * Lambda**{1/2},
*        Y = Q * L * U * D * V * Lambda**{-1/2},
*
*     where
*
*        Q = sqrt(1/2) * [ I_n, -i*I_n;
*                          I_n,  i*I_n ].
*
      T_VEC1 = MPI_WTIME()
*
*     Scale V by Lambda**{-1/2}.
*
      DO I = 1, N
         CALL PDSCAL( TWON, ONE/DSQRT( LAMBDA( I ) ),
     $        WORK( INDV ), 1, I, DESCV, 1 )
      END DO
      T_VEC1 = MPI_WTIME() - T_VEC1
!      IF ( MYROW+MYCOL .EQ. 0 )
!     $   WRITE( *, * ) 't_vec1 = ', T_VEC1, ';'
!      CALL PDLAPRNT( TWON, TWON, WORK( INDU ), 1, 1, DESCU, 0, 0, 'Z',
!     $     6, WORK( INDWORK ) )
*
*     Formulate
*
*        Y = Q * L * U * D * V * Lambda**{-1/2},
*        X = Q * L**{-T} * U * D * V * Lambda**{1/2},
*
*     Once Y is calculated, X is constructed from Y through
*
*        Y = [ Y1; Y2 ], X = [ Y1; -Y2 ].
*
*     Use WORK and M as workspace for real and imaginary parts,
*     respectively.
*
      T_VEC2 = MPI_WTIME()
      CALL PZBSAUX1( N, WORK( INDV ), 1, 1, DESCV, X, IX, JX, DESCX,
     $     WORK( INDU ), 1, 1, DESCU, WORK( INDWORK ), 1, 1, DESCW,
     $     M, IM, JM, DESCM )
      CALL PZLASCL( 'G', -ONE, ONE, N, N, X, IX+N, JX, DESCX, ITMP )
      T_VEC2 = MPI_WTIME() - T_VEC2
!      IF ( MYROW+MYCOL .EQ. 0 )
!     $   WRITE( *, * ) 't_vec2 = ', T_VEC2, ';'
!      CALL PZLAPRNT( TWON, N, X, IX, JX, DESCX, 0, 0, 'X', 6,
!     $     WORK( INDWORK ) )
*
      WORK( 1 ) = DBLE( LWKOPT )
      IWORK( 1 ) = LIWKOPT
*
      RETURN
*
*     End of PZBSSOLVER1().
*
      END


! { dg-additional-options "-fprofile-generate" }
  SUBROUTINE matmul_test ( ntim,len)
    INTEGER, PARAMETER :: dp=8
    REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: ma, mb, mc
    INTEGER :: siz,len, ntim
    DO i = 5, siz, 2
       len = 2**i + 1
       ALLOCATE ( ma ( len, len ), STAT = ierr )
       IF ( ierr /= 0 ) EXIT
       ALLOCATE ( mb ( len, len ), STAT = ierr )
       IF ( ierr /= 0 ) EXIT
       ALLOCATE ( mc ( len, len ), STAT = ierr )
       IF ( ierr /= 0 ) EXIT
       DO j = 1, ntim
          mc = MATMUL ( ma, mb )
       END DO
    END DO
  END SUBROUTINE matmul_test


! =============================================================================
!                       Test ellipsoid merge
!
!         This unit test checks the merging of two ellipsoids. It is the
!         reverse test of test_ellipsoid_split.f90.
! =============================================================================
program test_ellipsoid_merge_2
    use unit_test
    use constants, only : pi, one, f12, f14, f13, f23, f34, two, four, five, ten
    use parcel_container
    use parcel_merge, only : merge_parcels, merge_timer
    use options, only : parcel
    use parameters, only : update_parameters, nx, ny, nz, lower, extent
    use parcel_ellipsoid
    use parcel_nearest
    use timer
    implicit none

    double precision :: a2, b2, c2, abc, ab, error, lam
    double precision :: theta, phi, st, ct, sp, cp
    integer          :: i, j

    nx = 1
    ny = 1
    nz = 1
    lower  = (/-pi / two, -pi /two, -pi /two/)
    extent = (/pi, pi, pi/)

    call register_timer('parcel merge', merge_timer)
    call register_timer('merge nearest', merge_nearest_timer)
    call register_timer('merge tree resolve', merge_tree_resolve_timer)

    parcel%lambda_max = five
    parcel%min_vratio = ten

    call update_parameters

    call parcel_alloc(2)

    abc = one
    ab = f34

    lam = three
    a2 = ab * lam
    b2 = ab / lam
    c2 = (abc / ab) ** 2

    error = zero

    do i = 0, 7
        theta = dble(i) * f14 * pi
        st = dsin(theta)
        ct = dcos(theta)
        do j = 0, 7
            phi = dble(j) * f14 * pi
            sp = dsin(phi)
            cp = dcos(phi)

            call setup_parcels

            call merge_parcels(parcels)

            call check_result
        enddo
    enddo

    call print_result_dp('Test ellipsoid merge 2', error, atol=dble(2.0e-15))

    call parcel_dealloc

    contains

        subroutine setup_parcels
            double precision :: h, B11, B12, B13, B22, B23, B33, evec(3)
            n_parcels = 2

            B11 = a2 * ct ** 2 * sp ** 2 + b2 * st ** 2 + c2 * ct ** 2 * cp ** 2
            B12 = a2 * st * ct * sp ** 2 - b2 * st * ct + c2 * st * ct * cp ** 2
            B13 = (a2 - c2) * ct * sp * cp
            B22 = a2 * st ** 2 * sp ** 2 + b2 * ct ** 2 + c2 * st ** 2 * cp ** 2
            B23 = (a2 - c2) * st * sp * cp
            B33 = a2 * cp ** 2 + c2 * sp ** 2

            h = f12 * dsqrt(three / five * a2)
            B11 = B11 - f34 * a2 * ct ** 2 * sp ** 2
            B12 = B12 - f34 * a2 * st * ct * sp ** 2
            B13 = B13 - f34 * a2 * ct * sp * cp
            B22 = B22 - f34 * a2 * st ** 2 * sp ** 2
            B23 = B23 - f34 * a2 * st * sp * cp
            B33 = B33 - f34 * a2 * cp ** 2

            if ((a2 > b2) .and. (a2 > c2)) then
                evec = (/ct * sp, st * sp, cp/)
            else if ((b2 > a2) .and. (b2 > c2)) then
                evec = (/-st, ct, zero/)
            else if ((c2 > a2) .and. (c2 > b2)) then
                evec = (/ct * cp, st * cp, -sp/)
            endif

            ! first parcel
            parcels%position(:, 1) = h * evec
            parcels%volume(1) = f12 * dsqrt(a2 * b2 * c2) * four * pi / three
            parcels%B(1, 1) = B11
            parcels%B(2, 1) = B12
            parcels%B(3, 1) = B13
            parcels%B(4, 1) = B22
            parcels%B(5, 1) = B23
            parcels%buoyancy(1) = 1.8d0
#ifndef ENABLE_DRY_MODE
            parcels%humidity(1) = 1.2d0
#endif
            ! second parcel
            parcels%position(:, 2) = - h * evec
            parcels%volume(2) = parcels%volume(1)
            parcels%B(:, 2) = parcels%B(:, 1)
            parcels%buoyancy(2) = 1.4d0
#ifndef ENABLE_DRY_MODE
            parcels%humidity(2) = 1.1d0
#endif
        end subroutine setup_parcels

        subroutine check_result
            double precision :: B11, B12, B13, B22, B23, B33, vol
            double precision :: hum, buoy

            ! reference solution
            B11 = a2 * ct ** 2 * sp ** 2 + b2 * st ** 2 + c2 * ct ** 2 * cp ** 2
            B12 = a2 * st * ct * sp ** 2 - b2 * st * ct + c2 * st * ct * cp ** 2
            B13 = (a2 - c2) * ct * sp * cp
            B22 = a2 * st ** 2 * sp ** 2 + b2 * ct ** 2 + c2 * st ** 2 * cp ** 2
            B23 = (a2 - c2) * st * sp * cp
            B33 = a2 * cp ** 2 + c2 * sp ** 2

            abc = dsqrt(a2 * b2 * c2)
            vol = abc * four * pi / three

            buoy = f12 * (1.8d0 + 1.4d0)
            hum  = f12 * (1.2d0 + 1.1d0)

            error = max(error, abs(dble(n_parcels - 1)))
            error = max(error, abs(parcels%B(1, 1) - B11))
            error = max(error, abs(parcels%B(2, 1) - B12))
            error = max(error, abs(parcels%B(3, 1) - B13))
            error = max(error, abs(parcels%B(4, 1) - B22))
            error = max(error, abs(parcels%B(5, 1) - B23))
            error = max(error, abs(get_B33(parcels%B(:, 1), &
                                           parcels%volume(1)) - B33))
            error = max(error, sum(abs(parcels%position(:, 1))))
            error = max(error, abs(parcels%volume(1) - vol))
            error = max(error, abs(parcels%buoyancy(1) - buoy))
#ifndef ENABLE_DRY_MODE
            error = max(error, abs(parcels%humidity(1) - hum))
#endif
        end subroutine check_result
end program test_ellipsoid_merge_2