      SUBROUTINE PCSEPRTST(DESCA, UPLO, N, MATTYPE, SUBTESTS, THRESH,
     $                     ORDER, ABSTOL, ISEED, A, COPYA, Z, LDA, WIN,
     $                     WNEW, IFAIL, ICLUSTR, GAP, IPREPAD, IPOSTPAD,
     $                     WORK, LWORK, RWORK, LRWORK,
     $                     IWORK, LIWORK, HETERO, NOUT, INFO )
*
*  -- ScaLAPACK routine (@(MODE)version *TBA*) --
*     University of California, Berkeley and
*     University of Tennessee, Knoxville.
*     October 21, 2006
*
      IMPLICIT NONE
*
*     .. Scalar Arguments ..
      CHARACTER          HETERO, SUBTESTS, UPLO
      INTEGER            INFO, IPOSTPAD, IPREPAD, LDA, LIWORK, LWORK,
     $                   MATTYPE, N, NOUT, ORDER
      INTEGER            LRWORK
      REAL               ABSTOL, THRESH
*     ..
*     .. Array Arguments ..
      INTEGER            DESCA( * ), ICLUSTR( * ), IFAIL( * ),
     $                   ISEED( 4 ), IWORK( * )
      REAL               GAP( * ),  WIN( * ), WNEW( * ), RWORK( * )
      COMPLEX            A( LDA, * ), COPYA( LDA, * ),
     $                   WORK( * ), Z( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  PCSEPRTST builds a random matrix and runs PCHEEVR to
*  compute the eigenvalues and eigenvectors. Then it performs two tests
*  to determine if the result is good enough.  The two tests are:
*       |AQ -QL| / (abstol + ulp * norm(A) )
*  and
*       |QT * Q - I| / ulp * norm(A)
*
*  The random matrix built depends upon the following parameters:
*     N, NB, ISEED, ORDER
*
*  Arguments
*  =========
*
*     NP = the number of rows local to a given process.
*     NQ = the number of columns local to a given process.
*
*  DESCA   (global and local input) INTEGER array of dimension DLEN_
*          The array descriptor for the distributed matrices
*
*  UPLO     (global input) CHARACTER*1
*           Specifies whether the upper or lower triangular part of the
*           matrix A is stored:
*           = 'U':  Upper triangular
*           = 'L':  Lower triangular
*
*  N        (global input) INTEGER
*           Size of the matrix to be tested.  (global size)
*
*  MATTYPE  (global input) INTEGER
*           Matrix type
*  Currently, the list of possible types is:
*
*  (1)  The zero matrix.
*  (2)  The identity matrix.
*
*  (3)  A diagonal matrix with evenly spaced entries
*       1, ..., ULP  and random signs.
*       (ULP = (first number larger than 1) - 1 )
*  (4)  A diagonal matrix with geometrically spaced entries
*       1, ..., ULP  and random signs.
*  (5)  A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
*       and random signs.
*
*  (6)  Same as (4), but multiplied by SQRT( overflow threshold )
*  (7)  Same as (4), but multiplied by SQRT( underflow threshold )
*
*  (8)  A matrix of the form  U' D U, where U is orthogonal and
*       D has evenly spaced entries 1, ..., ULP with random signs
*       on the diagonal.
*
*  (9)  A matrix of the form  U' D U, where U is orthogonal and
*       D has geometrically spaced entries 1, ..., ULP with random
*       signs on the diagonal.
*
*  (10) A matrix of the form  U' D U, where U is orthogonal and
*       D has "clustered" entries 1, ULP,..., ULP with random
*       signs on the diagonal.
*
*  (11) Same as (8), but multiplied by SQRT( overflow threshold )
*  (12) Same as (8), but multiplied by SQRT( underflow threshold )
*
*  (13) A matrix with random entries chosen from (-1,1).
*  (14) Same as (13), but multiplied by SQRT( overflow threshold )
*  (15) Same as (13), but multiplied by SQRT( underflow threshold )
*  (16) Same as (8), but diagonal elements are all positive.
*  (17) Same as (9), but diagonal elements are all positive.
*  (18) Same as (10), but diagonal elements are all positive.
*  (19) Same as (16), but multiplied by SQRT( overflow threshold )
*  (20) Same as (16), but multiplied by SQRT( underflow threshold )
*  (21) A tridiagonal matrix that is a direct sum of smaller diagonally
*       dominant submatrices. Each unreduced submatrix has geometrically
*       spaced diagonal entries 1, ..., ULP.
*  (22) A matrix of the form  U' D U, where U is orthogonal and
*       D has ceil(lgN) "clusters" at 0,1,2,...,ceil(lgN)-1. The
*       size of the cluster at the value I is 2^I.
*
*  SUBTESTS (global input) CHARACTER*1
*           'Y' - Perform subset tests
*           'N' - Do not perform subset tests
*
*  THRESH   (global input) REAL
*          A test will count as "failed" if the "error", computed as
*          described below, 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.
*
*  ORDER    (global input) INTEGER
*           Number of reflectors used in test matrix creation.
*           If ORDER is large, it will
*           take more time to create the test matrices but they will
*           be closer to random.
*           ORDER .lt. N not implemented
*
*  ABSTOL   (global input) REAL
*           For the purposes of this test, ABSTOL=0.0 is fine.
*           THis test does not test for high relative accuracy.
*
*  ISEED   (global input/output) INTEGER array, dimension (4)
*          On entry, the seed of the random number generator; the array
*          elements must be between 0 and 4095, and ISEED(4) must be
*          odd.
*          On exit, the seed is updated.
*
*  A       (local workspace) COMPLEX          array, dim (N*N)
*          global dimension (N, N), local dimension (LDA, NQ)
*          The test matrix, which is then overwritten.
*          A is distributed in a block cyclic manner over both rows
*          and columns.  The actual location of a particular element
*          in A is controlled by the values of NPROW, NPCOL, and NB.
*
*  COPYA   (local workspace) COMPLEX          array, dim (N, N)
*          COPYA is used to hold an identical copy of the array A
*          identical in both form and content to A
*
*  Z       (local workspace) COMPLEX          array, dim (N*N)
*          Z is distributed in the same manner as A
*          Z is used as workspace by the test routines
*          PCSEPCHK and PCSEPQTQ
*
*  W       (local workspace) REAL             array, dimension (N)
*          On normal exit, the first M entries
*          contain the selected eigenvalues in ascending order.
*
*  IFAIL   (global workspace) INTEGER array, dimension (N)
*          Not used, only for backward compatibility
*
*  WORK    (local workspace) COMPLEX          array, dimension (LWORK)
*
*  LWORK   (local input) INTEGER
*          The length of the array WORK.  LWORK >= SIZETST as
*          returned by PCLASIZESEPR
*
*  RWORK   (local workspace) REAL             array, dimension (LRWORK)
*
*  LRWORK  (local input) INTEGER
*          The length of the array WORK.  LRWORK >= RSIZETST as
*          returned by P@(CRPF)LASIZESEPR
*
*  IWORK   (local workspace) INTEGER array, dimension (LIWORK)
*
*  LIWORK  (local input) INTEGER
*          The length of the array IWORK.  LIWORK >= ISIZETST as
*          returned by PCLASIZESEPR
*
*  HETERO (input) INTEGER
*
*  NOUT   (local input) INTEGER
*         The unit number for output file.  Only used on node 0.
*         NOUT = 6, output to screen,
*         NOUT = 0, output to stderr.
*         NOUT = 13, output to file, divide thresh by 10.0
*         NOUT = 14, output to file, divide thresh by 20.0
*         (This hack allows us to test more stringently internally
*         so that when errors on found on other computers they will
*         be serious enough to warrant our attention.)
*
*  INFO (global output) INTEGER
*         -3       This process is not involved
*         0        Test succeeded (passed |AQ -QL| and |QT*Q - I| tests)
*         1        At least one test failed
*         2        Residual test were not performed, thresh <= 0.0
*         3        Test was skipped because of inadequate memory space
*
*     .. Parameters ..
      INTEGER            CTXT_, MB_, NB_, RSRC_, CSRC_, LLD_
      PARAMETER          ( CTXT_ = 2, MB_ = 5, NB_ = 6,
     $                   RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
      REAL               HALF, ONE, TEN, ZERO
      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0,
     $                     TEN = 10.0E0, HALF = 0.5E0 )
      COMPLEX            PADVAL
      PARAMETER          ( PADVAL = ( 19.25E0, 1.1E1 ) )
      COMPLEX                  ZZERO
      PARAMETER          ( ZZERO = ( 0.0E0, 0.0E0 ) )
      COMPLEX                  ZONE
      PARAMETER          ( ZONE = ( 1.0E0, 0.0E0 ) )
      INTEGER            MAXTYP
      PARAMETER          ( MAXTYP = 22 )
*     ..
*
*     .. Local Scalars ..
      LOGICAL            WKNOWN
      CHARACTER          JOBZ, RANGE
      CHARACTER*14       PASSED
      INTEGER            CONTEXT, I, IAM, IHETERO, IINFO, IL, IMODE, IN,
     $                   INDD, INDWORK, ISIZESUBTST, ISIZEEVR,
     $                   ISIZETST, ITYPE, IU, J, LLWORK, LEVRSIZE,
     $                   MAXSIZE, MYCOL, MYROW, NB, NGEN, NLOC,
     $                   NNODES, NP, NPCOL, NPROW, NQ, RES, SIZECHK,
     $                   SIZEMQRLEFT, SIZEMQRRIGHT, SIZEQRF, SIZEQTQ,
     $                   SIZESUBTST, SIZEEVR, SIZETMS,
     $                   SIZETST, VALSIZE, VECSIZE
      INTEGER            INDRWORK, LLRWORK, RSIZEEVR, RSIZESUBTST,
     $                   RSIZETST
      REAL               ANINV, ANORM, COND, MAXQTQNRM, MAXTSTNRM, OVFL,
     $                   QTQNRM, RTOVFL, RTUNFL, TEMP1, TSTNRM, ULP,
     $                   ULPINV, UNFL, VL, VU
*     ..
*     .. Local Arrays ..
      INTEGER            ISEEDIN( 4 ), KMAGN( MAXTYP ), KMODE( MAXTYP ),
     $                   KTYPE( MAXTYP )
      DOUBLE PRECISION   CTIME( 10 ), WTIME( 10 )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            NUMROC
      REAL               SLARAN, PSLAMCH
      EXTERNAL           SLARAN, LSAME, NUMROC, PSLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GRIDINFO, BLACS_PINFO, CLATMS, IGAMX2D,
     $                   IGEBR2D, IGEBS2D, PCCHEKPAD, PCELSET,
     $                   PCFILLPAD, PCLASET, PCLASIZEHEEVR,
     $                   PCLASIZESEPR, PCLATMS, PCMATGEN, PCSEPRSUBTST,
     $                   SLABAD, SLASRT, SLCOMBINE
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, REAL, INT, MAX, MIN, SQRT
*     ..
*     .. Data statements ..
      DATA               KTYPE / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8,
     $                   8, 8, 9, 9, 9, 9, 9, 10, 11 /
      DATA               KMAGN / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
     $                   2, 3, 1, 1, 1, 2, 3, 1, 1 /
      DATA               KMODE / 0, 0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
     $                   0, 0, 4, 3, 1, 4, 4, 3, 0 /
*     ..
*     .. Executable Statements ..
*
      INFO = 0
      PASSED = 'PASSED   EVR'
      CONTEXT = DESCA( CTXT_ )
      NB = DESCA( NB_ )
*
      CALL BLACS_PINFO( IAM, NNODES )
      CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
*
*     Distribute HETERO across processes
*
      IF( IAM.EQ.0 ) THEN
         IF( LSAME( HETERO, 'Y' ) ) THEN
            IHETERO = 2
         ELSE
            IHETERO = 1
         END IF
         CALL IGEBS2D( CONTEXT, 'All', ' ', 1, 1, IHETERO, 1 )
      ELSE
         CALL IGEBR2D( CONTEXT, 'All', ' ', 1, 1, IHETERO, 1, 0, 0 )
      END IF
      IF( IHETERO.EQ.2 ) THEN
         HETERO = 'Y'
      ELSE
         HETERO = 'N'
      END IF
*
*     Make sure that there is enough memory
*
      CALL PCLASIZESEPR( DESCA, IPREPAD, IPOSTPAD, SIZEMQRLEFT,
     $                   SIZEMQRRIGHT, SIZEQRF, SIZETMS, SIZEQTQ,
     $                   SIZECHK, SIZEEVR, RSIZEEVR, ISIZEEVR,
     $                   SIZESUBTST, RSIZESUBTST,
     $                   ISIZESUBTST, SIZETST, RSIZETST, ISIZETST )
      IF( LRWORK.LT.RSIZETST ) THEN
         INFO = 3
      END IF
*
      CALL IGAMX2D( CONTEXT, 'a', ' ', 1, 1, INFO, 1, 1, 1, -1, -1, 0 )
*
      IF( INFO.EQ.0 ) THEN
*
         INDD = 1
         INDRWORK = INDD + N
         INDWORK = 1
         LLWORK = LWORK - INDWORK + 1
         LLRWORK = LRWORK - INDRWORK + 1
*
         ULP = PSLAMCH( CONTEXT, 'P' )
         ULPINV = ONE / ULP
         UNFL = PSLAMCH( CONTEXT, 'Safe min' )
         OVFL = ONE / UNFL
         CALL SLABAD( UNFL, OVFL )
         RTUNFL = SQRT( UNFL )
         RTOVFL = SQRT( OVFL )
         ANINV = ONE / REAL( MAX( 1, N ) )
*
*     This ensures that everyone starts out with the same seed.
*
         IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
            CALL IGEBS2D( CONTEXT, 'a', ' ', 4, 1, ISEED, 4 )
         ELSE
            CALL IGEBR2D( CONTEXT, 'a', ' ', 4, 1, ISEED, 4, 0, 0 )
         END IF
         ISEEDIN( 1 ) = ISEED( 1 )
         ISEEDIN( 2 ) = ISEED( 2 )
         ISEEDIN( 3 ) = ISEED( 3 )
         ISEEDIN( 4 ) = ISEED( 4 )
*
*     Compute the matrix A
*
*     Control parameters:
*
*     KMAGN  KMODE        KTYPE
*     =1  O(1)   clustered 1  zero
*     =2  large  clustered 2  identity
*     =3  small  exponential  (none)
*     =4         arithmetic   diagonal, (w/ eigenvalues)
*     =5         random log   Hermitian, w/ eigenvalues
*     =6         random       (none)
*     =7                      random diagonal
*     =8                      random Hermitian
*     =9                      positive definite
*     =10                     block diagonal with tridiagonal blocks
*     =11                     Geometrically sized clusters.
*
         ITYPE = KTYPE( MATTYPE )
         IMODE = KMODE( MATTYPE )
*
*     Compute norm
*
         GO TO ( 10, 20, 30 )KMAGN( MATTYPE )
*
   10    CONTINUE
         ANORM = ONE
         GO TO 40
*
   20    CONTINUE
         ANORM = ( RTOVFL*ULP )*ANINV
         GO TO 40
*
   30    CONTINUE
         ANORM = RTUNFL*N*ULPINV
         GO TO 40
*
   40    CONTINUE
         IF( MATTYPE.LE.15 ) THEN
            COND = ULPINV
         ELSE
            COND = ULPINV*ANINV / TEN
         END IF
*
*        Special Matrices
*
         IF( ITYPE.EQ.1 ) THEN
*
*          Zero Matrix
*
            DO 50 I = 1, N
               RWORK( INDD+I-1 ) = ZERO
   50       CONTINUE
            CALL PCLASET( 'All', N, N,ZZERO,ZZERO, COPYA, 1, 1, DESCA )
            WKNOWN = .TRUE.
*
         ELSE IF( ITYPE.EQ.2 ) THEN
*
*           Identity Matrix
*
            DO 60 I = 1, N
               RWORK( INDD+I-1 ) = ONE
   60       CONTINUE
            CALL PCLASET( 'All', N, N,ZZERO,ZONE, COPYA, 1, 1, DESCA )
            WKNOWN = .TRUE.
*
         ELSE IF( ITYPE.EQ.4 ) THEN
*
*           Diagonal Matrix, [Eigen]values Specified
*
            CALL PCFILLPAD( DESCA( CTXT_ ), SIZETMS, 1, WORK( INDWORK ),
     $                      SIZETMS, IPREPAD, IPOSTPAD, PADVAL+1.0E0 )
*
           CALL PCLATMS( N, N, 'S', ISEED, 'S',RWORK( INDD ), IMODE,
     $                    COND, ANORM, 0, 0, 'N', COPYA, 1, 1, DESCA,
     $                    ORDER, WORK( INDWORK+IPREPAD ), SIZETMS,
     $                    IINFO )
            WKNOWN = .TRUE.
*
            CALL PCCHEKPAD( DESCA( CTXT_ ), 'PCLATMS1-WORK', SIZETMS, 1,
     $                      WORK( INDWORK ), SIZETMS, IPREPAD, IPOSTPAD,
     $                      PADVAL+1.0E0 )
*
         ELSE IF( ITYPE.EQ.5 ) THEN
*
*           Hermitian, eigenvalues specified
*
            CALL PCFILLPAD( DESCA( CTXT_ ), SIZETMS, 1, WORK( INDWORK ),
     $                      SIZETMS, IPREPAD, IPOSTPAD, PADVAL+2.0E0 )
*
            CALL PCLATMS( N, N, 'S', ISEED, 'S',RWORK( INDD ), IMODE,
     $                    COND, ANORM, N, N, 'N', COPYA, 1, 1, DESCA,
     $                    ORDER, WORK( INDWORK+IPREPAD ), SIZETMS,
     $                    IINFO )
*
            CALL PCCHEKPAD( DESCA( CTXT_ ), 'PCLATMS2-WORK', SIZETMS, 1,
     $                      WORK( INDWORK ), SIZETMS, IPREPAD, IPOSTPAD,
     $                      PADVAL+2.0E0 )
*
            WKNOWN = .TRUE.
*
         ELSE IF( ITYPE.EQ.8 ) THEN
*
*           Hermitian, random eigenvalues
*
            NP = NUMROC( N, DESCA( MB_ ), MYROW, 0, NPROW )
            NQ = NUMROC( N, DESCA( NB_ ), MYCOL, 0, NPCOL )
            CALL PCMATGEN( DESCA( CTXT_ ), 'H', 'N', N, N, DESCA( MB_ ),
     $                     DESCA( NB_ ), COPYA, DESCA( LLD_ ),
     $                     DESCA( RSRC_ ), DESCA( CSRC_ ), ISEED( 1 ),
     $                     0, NP, 0, NQ, MYROW, MYCOL, NPROW, NPCOL )
            INFO = 0
            WKNOWN = .FALSE.
*
         ELSE IF( ITYPE.EQ.9 ) THEN
*
*           Positive definite, eigenvalues specified.
*
            CALL PCFILLPAD( DESCA( CTXT_ ), SIZETMS, 1, WORK( INDWORK ),
     $                      SIZETMS, IPREPAD, IPOSTPAD, PADVAL+3.0E0 )
*
            CALL PCLATMS( N, N, 'S', ISEED, 'S',RWORK( INDD ), IMODE,
     $                    COND, ANORM, N, N, 'N', COPYA, 1, 1, DESCA,
     $                    ORDER, WORK( INDWORK+IPREPAD ), SIZETMS,
     $                    IINFO )
*
            WKNOWN = .TRUE.
*
            CALL PCCHEKPAD( DESCA( CTXT_ ), 'PCLATMS3-WORK', SIZETMS, 1,
     $                      WORK( INDWORK ), SIZETMS, IPREPAD, IPOSTPAD,
     $                      PADVAL+3.0E0 )
*
         ELSE IF( ITYPE.EQ.10 ) THEN
*
*           Block diagonal matrix with each block being a positive
*           definite tridiagonal submatrix.
*
            CALL PCLASET( 'All', N, N,ZZERO,ZZERO, COPYA, 1, 1, DESCA )
            NP = NUMROC( N, DESCA( MB_ ), 0, 0, NPROW )
            NQ = NUMROC( N, DESCA( NB_ ), 0, 0, NPCOL )
            NLOC = MIN( NP, NQ )
            NGEN = 0
   70       CONTINUE
*
            IF( NGEN.LT.N ) THEN
               IN = MIN( 1+INT( SLARAN( ISEED )*REAL( NLOC ) ), N-NGEN )
*
              CALL CLATMS( IN, IN, 'S', ISEED, 'P',RWORK( INDD ),
     $                      IMODE, COND, ANORM, 1, 1, 'N', A, LDA,
     $                      WORK( INDWORK ), IINFO )
*
               DO 80 I = 2, IN
                  TEMP1 = ABS( A( I-1, I ) ) /
     $                    SQRT( ABS( A( I-1, I-1 )*A( I, I ) ) )
                  IF( TEMP1.GT.HALF ) THEN
                     A( I-1, I ) = HALF*SQRT( ABS( A( I-1, I-1 )*A( I,
     $                             I ) ) )
                     A( I, I-1 ) = A( I-1, I )
                  END IF
   80          CONTINUE
               CALL PCELSET( COPYA, NGEN+1, NGEN+1, DESCA, A( 1, 1 ) )
               DO 90 I = 2, IN
                  CALL PCELSET( COPYA, NGEN+I, NGEN+I, DESCA,
     $                          A( I, I ) )
                  CALL PCELSET( COPYA, NGEN+I-1, NGEN+I, DESCA,
     $                          A( I-1, I ) )
                  CALL PCELSET( COPYA, NGEN+I, NGEN+I-1, DESCA,
     $                          A( I, I-1 ) )
   90          CONTINUE
               NGEN = NGEN + IN
               GO TO 70
            END IF
            WKNOWN = .FALSE.
*
         ELSE IF( ITYPE.EQ.11 ) THEN
*
*           Geometrically sized clusters.  Eigenvalues:  0,1,1,2,2,2,2,...
*
            NGEN = 0
            J = 1
            TEMP1 = ZERO
  100       CONTINUE
            IF( NGEN.LT.N ) THEN
               IN = MIN( J, N-NGEN )
               DO 110 I = 0, IN - 1
                  RWORK( INDD+NGEN+I ) = TEMP1
  110          CONTINUE
               TEMP1 = TEMP1 + ONE
               J = 2*J
               NGEN = NGEN + IN
               GO TO 100
            END IF
*
            CALL PCFILLPAD( DESCA( CTXT_ ), SIZETMS, 1, WORK( INDWORK ),
     $                      SIZETMS, IPREPAD, IPOSTPAD, PADVAL+4.0E0 )
*
            CALL PCLATMS( N, N, 'S', ISEED, 'S',RWORK( INDD ), IMODE,
     $                    COND, ANORM, 0, 0, 'N', COPYA, 1, 1, DESCA,
     $                    ORDER, WORK( INDWORK+IPREPAD ), SIZETMS,
     $                    IINFO )
*
            CALL PCCHEKPAD( DESCA( CTXT_ ), 'PCLATMS4-WORK', SIZETMS, 1,
     $                      WORK( INDWORK ), SIZETMS, IPREPAD, IPOSTPAD,
     $                      PADVAL+4.0E0 )
*
         ELSE
            IINFO = 1
         END IF
*
         IF( WKNOWN )
     $      CALL SLASRT( 'I', N,RWORK( INDD ), IINFO )
*
         CALL PCLASIZEHEEVR( WKNOWN, 'A', N, DESCA, VL, VU, IL, IU,
     $                       ISEED,RWORK( INDD ), MAXSIZE, VECSIZE,
     $                       VALSIZE )
         LEVRSIZE = MIN( MAXSIZE, LLRWORK )
*
         CALL PCSEPRSUBTST( WKNOWN, 'v', 'a', UPLO, N, VL, VU, IL, IU,
     $                      THRESH, ABSTOL, A, COPYA, Z, 1, 1, DESCA,
     $                      RWORK( INDD ), WIN, IFAIL, ICLUSTR, GAP,
     $                      IPREPAD, IPOSTPAD, WORK( INDWORK ), LLWORK,
     $                      RWORK( INDRWORK ), LLRWORK,
     $                      LEVRSIZE, IWORK, ISIZEEVR, RES, TSTNRM,
     $                      QTQNRM, NOUT )
*
         MAXTSTNRM = TSTNRM
         MAXQTQNRM = QTQNRM
*
         IF( THRESH.LE.ZERO ) THEN
            PASSED = 'SKIPPED       '
            INFO = 2
         ELSE IF( RES.NE.0 ) THEN
            PASSED = 'FAILED        '
            INFO = 1
         END IF
      END IF
*
      IF( THRESH.GT.ZERO .AND. LSAME( SUBTESTS, 'Y' ) ) THEN
*
*        Subtest 1:  JOBZ = 'N', RANGE = 'A', minimum memory
*
         IF( INFO.EQ.0 ) THEN
*
            JOBZ = 'N'
            RANGE = 'A'
            CALL PCLASIZEHEEVR( .TRUE., RANGE, N, DESCA, VL, VU, IL, IU,
     $                          ISEED, WIN( 1+IPREPAD ), MAXSIZE,
     $                          VECSIZE, VALSIZE )
*
            LEVRSIZE = VALSIZE
*
            CALL PCSEPRSUBTST( .TRUE., JOBZ, RANGE, UPLO, N, VL, VU, IL,
     $                         IU, THRESH, ABSTOL, A, COPYA, Z, 1, 1,
     $                         DESCA, WIN( 1+IPREPAD ), WNEW, IFAIL,
     $                         ICLUSTR, GAP, IPREPAD, IPOSTPAD,
     $                         WORK( INDWORK ), LLWORK,
     $                         RWORK, LRWORK, LEVRSIZE,
     $                         IWORK, ISIZEEVR, RES, TSTNRM, QTQNRM,
     $                         NOUT )
*
            IF( RES.NE.0 ) THEN
               MAXTSTNRM = MAX( TSTNRM, MAXTSTNRM )
               MAXQTQNRM = MAX( QTQNRM, MAXQTQNRM )
               PASSED = 'FAILED stest 1'
               INFO = 1
            END IF
         END IF
*
*        Subtest 2:  JOBZ = 'N', RANGE = 'I', minimum memory
*
         IF( INFO.EQ.0 ) THEN
*
            IL = -1
            IU = -1
            JOBZ = 'N'
            RANGE = 'I'
*
*           Use PCLASIZEHEEVR to choose IL and IU.
*
            CALL PCLASIZEHEEVR( .TRUE., RANGE, N, DESCA, VL, VU, IL, IU,
     $                          ISEED, WIN( 1+IPREPAD ), MAXSIZE,
     $                          VECSIZE, VALSIZE )
*
            LEVRSIZE = VALSIZE
*
            CALL PCSEPRSUBTST( .TRUE., JOBZ, RANGE, UPLO, N, VL, VU, IL,
     $                         IU, THRESH, ABSTOL, A, COPYA, Z, 1, 1,
     $                         DESCA, WIN( 1+IPREPAD ), WNEW, IFAIL,
     $                         ICLUSTR, GAP, IPREPAD, IPOSTPAD,
     $                         WORK( INDWORK ), LLWORK,
     $                         RWORK, LRWORK, LEVRSIZE,
     $                         IWORK, ISIZEEVR, RES, TSTNRM, QTQNRM,
     $                         NOUT )
*
            IF( RES.NE.0 ) THEN
               MAXTSTNRM = MAX( TSTNRM, MAXTSTNRM )
               MAXQTQNRM = MAX( QTQNRM, MAXQTQNRM )
               PASSED = 'FAILED stest 2'
               INFO = 1
            END IF
         END IF
*
*        Subtest 3:  JOBZ = 'V', RANGE = 'I', minimum memory
*
         IF( INFO.EQ.0 ) THEN
            IL = -1
            IU = -1
            JOBZ = 'V'
            RANGE = 'I'
*
*           We use PCLASIZEHEEVR to choose IL and IU for us.
*
            CALL PCLASIZEHEEVR( .TRUE., RANGE, N, DESCA, VL, VU, IL, IU,
     $                          ISEED, WIN( 1+IPREPAD ), MAXSIZE,
     $                          VECSIZE, VALSIZE )
*
            LEVRSIZE = VECSIZE
*
            CALL PCSEPRSUBTST( .TRUE., JOBZ, RANGE, UPLO, N, VL, VU, IL,
     $                         IU, THRESH, ABSTOL, A, COPYA, Z, 1, 1,
     $                         DESCA, WIN( 1+IPREPAD ), WNEW, IFAIL,
     $                         ICLUSTR, GAP, IPREPAD, IPOSTPAD,
     $                         WORK( INDWORK ), LLWORK,
     $                         RWORK, LRWORK, LEVRSIZE,
     $                         IWORK, ISIZEEVR, RES, TSTNRM, QTQNRM,
     $                         NOUT )
*
            IF( RES.NE.0 ) THEN
               MAXTSTNRM = MAX( TSTNRM, MAXTSTNRM )
               MAXQTQNRM = MAX( QTQNRM, MAXQTQNRM )
               PASSED = 'FAILED stest 3'
               INFO = 1
            END IF
         END IF
*
*        Subtest 4:  JOBZ = 'N', RANGE = 'V', minimum memory
*
         IF( INFO.EQ.0 ) THEN
            VL = ONE
            VU = -ONE
            JOBZ = 'N'
            RANGE = 'V'
*
*           We use PCLASIZEHEEVR to choose IL and IU for us.
*
            CALL PCLASIZEHEEVR( .TRUE., RANGE, N, DESCA, VL, VU, IL, IU,
     $                          ISEED, WIN( 1+IPREPAD ), MAXSIZE,
     $                          VECSIZE, VALSIZE )
*
            LEVRSIZE = VALSIZE
*
            CALL PCSEPRSUBTST( .TRUE., JOBZ, RANGE, UPLO, N, VL, VU, IL,
     $                         IU, THRESH, ABSTOL, A, COPYA, Z, 1, 1,
     $                         DESCA, WIN( 1+IPREPAD ), WNEW, IFAIL,
     $                         ICLUSTR, GAP, IPREPAD, IPOSTPAD,
     $                         WORK( INDWORK ), LLWORK,
     $                         RWORK, LRWORK, LEVRSIZE,
     $                         IWORK, ISIZEEVR, RES, TSTNRM, QTQNRM,
     $                         NOUT )
*
            IF( RES.NE.0 ) THEN
               MAXTSTNRM = MAX( TSTNRM, MAXTSTNRM )
               MAXQTQNRM = MAX( QTQNRM, MAXQTQNRM )
               PASSED = 'FAILED stest 4'
               INFO = 1
            END IF
         END IF
*
*        Subtest 5:  JOBZ = 'V', RANGE = 'V', minimum memory
*
         IF( INFO.EQ.0 ) THEN
            VL = ONE
            VU = -ONE
            JOBZ = 'V'
            RANGE = 'V'
*
*           We use PCLASIZEHEEVR to choose VL and VU for us.
*
            CALL PCLASIZEHEEVR( .TRUE., RANGE, N, DESCA, VL, VU, IL, IU,
     $                          ISEED, WIN( 1+IPREPAD ), MAXSIZE,
     $                          VECSIZE, VALSIZE )
*
            LEVRSIZE = VECSIZE
*
            CALL PCSEPRSUBTST( .TRUE., JOBZ, RANGE, UPLO, N, VL, VU, IL,
     $                         IU, THRESH, ABSTOL, A, COPYA, Z, 1, 1,
     $                         DESCA, WIN( 1+IPREPAD ), WNEW, IFAIL,
     $                         ICLUSTR, GAP, IPREPAD, IPOSTPAD,
     $                         WORK( INDWORK ), LLWORK,
     $                         RWORK, LRWORK, LEVRSIZE,
     $                         IWORK, ISIZEEVR, RES, TSTNRM, QTQNRM,
     $                         NOUT )
*
            IF( RES.NE.0 ) THEN
               MAXTSTNRM = MAX( TSTNRM, MAXTSTNRM )
               MAXQTQNRM = MAX( QTQNRM, MAXQTQNRM )
               PASSED = 'FAILED stest 5'
               INFO = 1
            END IF
         END IF
      END IF
*
      CALL IGAMX2D( CONTEXT, 'All', ' ', 1, 1, INFO, 1, -1, -1, -1, -1,
     $              -1 )
      IF( INFO.EQ.1 ) THEN
         IF( IAM.EQ.0 .AND. .FALSE. ) THEN
            WRITE( NOUT, FMT = 9994 )'C  '
            WRITE( NOUT, FMT = 9993 )ISEEDIN( 1 )
            WRITE( NOUT, FMT = 9992 )ISEEDIN( 2 )
            WRITE( NOUT, FMT = 9991 )ISEEDIN( 3 )
            WRITE( NOUT, FMT = 9990 )ISEEDIN( 4 )
            IF( LSAME( UPLO, 'L' ) ) THEN
               WRITE( NOUT, FMT = 9994 )'      UPLO= ''L'' '
            ELSE
               WRITE( NOUT, FMT = 9994 )'      UPLO= ''U'' '
            END IF
            IF( LSAME( SUBTESTS, 'Y' ) ) THEN
               WRITE( NOUT, FMT = 9994 )'      SUBTESTS= ''Y'' '
            ELSE
               WRITE( NOUT, FMT = 9994 )'      SUBTESTS= ''N'' '
            END IF
            WRITE( NOUT, FMT = 9989 )N
            WRITE( NOUT, FMT = 9988 )NPROW
            WRITE( NOUT, FMT = 9987 )NPCOL
            WRITE( NOUT, FMT = 9986 )NB
            WRITE( NOUT, FMT = 9985 )MATTYPE
            WRITE( NOUT, FMT = 9982 )ABSTOL
            WRITE( NOUT, FMT = 9981 )THRESH
            WRITE( NOUT, FMT = 9994 )'C  '
         END IF
      END IF
*
      CALL SLCOMBINE( CONTEXT, 'All', '>', 'W', 6, 1, WTIME )
      CALL SLCOMBINE( CONTEXT, 'All', '>', 'C', 6, 1, CTIME )
      IF( IAM.EQ.0 ) THEN
         IF( INFO.EQ.0 .OR. INFO.EQ.1 ) THEN
            IF( WTIME( 1 ).GE.0.0 ) THEN
               WRITE( NOUT, FMT = 9999 )N, NB, NPROW, NPCOL, MATTYPE,
     $            SUBTESTS, WTIME( 1 ), CTIME( 1 ), MAXTSTNRM,
     $            MAXQTQNRM, PASSED
            ELSE
               WRITE( NOUT, FMT = 9998 )N, NB, NPROW, NPCOL, MATTYPE,
     $            SUBTESTS, CTIME( 1 ), MAXTSTNRM, MAXQTQNRM, PASSED
            END IF
         ELSE IF( INFO.EQ.2 ) THEN
            IF( WTIME( 1 ).GE.0.0 ) THEN
               WRITE( NOUT, FMT = 9997 )N, NB, NPROW, NPCOL, MATTYPE,
     $            SUBTESTS, WTIME( 1 ), CTIME( 1 )
            ELSE
               WRITE( NOUT, FMT = 9996 )N, NB, NPROW, NPCOL, MATTYPE,
     $            SUBTESTS, CTIME( 1 )
            END IF
         ELSE IF( INFO.EQ.3 ) THEN
            WRITE( NOUT, FMT = 9995 )N, NB, NPROW, NPCOL, MATTYPE,
     $         SUBTESTS
         END IF
C         WRITE(*,*)'************************************************'
      END IF
*

      RETURN
 9999 FORMAT( 1X, I5, 1X, I3, 1X, I3, 1X, I3, 1X, I3, 3X, A1, 1X,
     $      F8.2, 1X, F8.2, 1X, G9.2, 1X, G9.2, 1X, A14 )
 9998 FORMAT( 1X, I5, 1X, I3, 1X, I3, 1X, I3, 1X, I3, 3X, A1, 1X, 8X,
     $      1X, F8.2, 1X, G9.2, 1X, G9.2, A14 )
 9997 FORMAT( 1X, I5, 1X, I3, 1X, I3, 1X, I3, 1X, I3, 3X, A1, 1X, F8.2,
     $      1X, F8.2, 21X, 'Bypassed' )
 9996 FORMAT( 1X, I5, 1X, I3, 1X, I3, 1X, I3, 1X, I3, 3X, A1, 1X, 8X,
     $      1X, F8.2, 21X, 'Bypassed' )
 9995 FORMAT( 1X, I5, 1X, I3, 1X, I3, 1X, I3, 1X, I3, 3X, A1, 32X,
     $      'Bad MEMORY parameters' )
 9994 FORMAT( A )
 9993 FORMAT( '      ISEED( 1 ) =', I8 )
 9992 FORMAT( '      ISEED( 2 ) =', I8 )
 9991 FORMAT( '      ISEED( 3 ) =', I8 )
 9990 FORMAT( '      ISEED( 4 ) =', I8 )
 9989 FORMAT( '      N=', I8 )
 9988 FORMAT( '      NPROW=', I8 )
 9987 FORMAT( '      NPCOL=', I8 )
 9986 FORMAT( '      NB=', I8 )
 9985 FORMAT( '      MATTYPE=', I8 )
C 9984 FORMAT( '      IBTYPE=', I8 )
C 9983 FORMAT( '      SUBTESTS=', A1 )
 9982 FORMAT( '      ABSTOL=', D16.6 )
 9981 FORMAT( '      THRESH=', D16.6 )
C 9980 FORMAT( ' Increase TOTMEM in PCSEPRDRIVER' )
*
*     End of PCSEPRTST
*
      END


module Mod_NSCompressibleSubroutines
contains

   subroutine nsc_ComputeEnergy(ndime,accvh,tempe,veloc,energ)
      use typre
      use def_parame
      implicit none

      integer(ip), intent(in)    :: ndime
      real(rp),    intent(in)    :: accvh,tempe
      real(rp),    intent(in)    :: veloc(ndime)
      real(rp),    intent(out)   :: energ

      real(rp)                   :: tmpvel(ndime),tmp

      tmpvel = veloc
      tmp = dot_product(tmpvel,veloc) / 2.0_rp
      energ = accvh*tempe + tmp

   end subroutine

   subroutine nsc_ComputeAdvectionVelocity(e,pcden,pcmom,pcvno)
      use typre
      use Mod_Element
      implicit none
      class(FiniteElement)        :: e
      real(rp),    intent(in)    :: pcden,pcmom(e%ndime)
      real(rp),    intent(out)   :: pcvno

      real(rp)                   :: tmp(e%ndime)

      tmp = pcmom/pcden
      call vecnor(tmp,e%ndime,pcvno,2)

   end subroutine

   subroutine nsc_ComputeTemperature(a,e,pcden,pcmom,pcene,pctem)
      use typre
      use Mod_NSCompressible
      use Mod_Element
      implicit none
      class(NSCompressibleProblem) :: a
      class(FiniteElement)        :: e
      real(rp),    intent(in)    :: pcden,pcmom(e%ndime),pcene
      real(rp),    intent(out)   :: pctem

      real(rp)                   :: acvis,actco,accph,accvh
      real(rp)                   :: invcvh,invpcd,aux_k

      !Physical Parameters
      call a%GetPhysicalParameters(acvis,actco,accph,accvh)

      invcvh = 1.0_rp / accvh
      invpcd = 1.0_rp / pcden
      aux_k = dot_product(pcmom,pcmom) / 2.0_rp

      pctem = invpcd * invcvh * (pcene - (aux_k*invpcd))

   end subroutine

   subroutine nsc_ComputeSoundSpeed(accph,accvh,pctem,pcspd)
      use typre
      implicit none
      real(rp),    intent(in)    :: accph,accvh,pctem
      real(rp),    intent(out)   :: pcspd

      real(rp)                   :: cgamma

      cgamma = accph/accvh
      pcspd = sqrt(accph * (cgamma-1.0_rp) * pctem)

   end subroutine

end module


       PROGRAM RK DYNAMICS

       IMPLICIT NONE
       COMPLEX*8,ALLOCATABLE,DIMENSION(:)::C_INIT,C_NOW
       INTEGER I,J,N,IDT,JOUT
       COMPLEX*8 EYE
       DOUBLE PRECISION TMAX,TIME_STEP,TOUT,T,NORM
       DOUBLE PRECISION RPAR(6),R,RI
       DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:)::PSI0,PSI
C=======================================E====================================
C----CONSTANTS
       EYE=(0.0D0,1.0D0)  !IMAGINARY NUMBER i
C------PARAMETRS FOR THE DYNAMICS
       TIME_STEP=0.01D0   !TIME STEP FOR THE DYNAMICS IN fs
       TOUT=0.10D0         !TIME INTERVAL IN fs FOR PRINTING OUTPUT
       TMAX=1000.0D0         !TOTAL TIME OF THE DYNAMICS
C===========================================================================
C-----PARAMETER OF THE SYSTEM
       N=2              !NUMBER OF COEFFICIENTS
C------PULSE PARAMETERS

       RPAR(1)=1.0D0   !FREQUENCY OF THE PULSE IN eV
       RPAR(2)=300.0D0 !TIME TO TURN THE PULSE IN fs
       RPAR(3)=100.0D0   !SOFTNESS   OF THE PULSE IN fs
       RPAR(4)=0.1D0    !FIELD AMPLITUDE IN V/A

C============================================================================
C---HAMILTONIAN
        RPAR(5)=1.0D0    !DIAGONAL TERMS FOR THE HAMILTONIAN IN eV
        RPAR(6)=1.0D0      !DIPOLE MOMENT IN ANGSTROMS
C=============================================================================
C----SETTING DIMENSIONS
      ALLOCATE(C_INIT(N),C_NOW(N))
C=============================================================================
C----INITIAL CONDITION

        OPEN(UNIT=10,FILE='INITIAL_STATE.dat',STATUS='UNKNOWN')

        DO I=1,N
          READ(10,*)R,RI
         C_INIT(I)=CMPLX(R,RI)
        END DO
C===============================================================================
C----PROPAGATION
      IDT=INT(TMAX/TIME_STEP)
      JOUT=INT(TOUT/TIME_STEP)
      T=0.0D0

       OPEN(UNIT=12,FILE='DYNAMICS.dat',STATUS='UNKNOWN')

       WRITE(12,*)T,(REAL(C_INIT(I)*CONJG(C_INIT(I))),I=1,N)

       DO I=1,IDT
          CALL RK(TIME_STEP,C_INIT,C_NOW,N,T,RPAR)
          C_INIT=C_NOW

          NORM=0.0D0
          DO J=1,N
             NORM=NORM+C_INIT(J)*CONJG(C_INIT(J))
          END DO
          DO J=1,N
             C_INIT(J)=C_INIT(J)/SQRT(NORM)
          END DO

          IF(MOD(I,JOUT).EQ.0) THEN
            WRITE(12,*)T,(REAL(C_INIT(J)*CONJG(C_INIT(J))),J=1,N)
          END IF

       T=T+TIME_STEP
       END DO

      END PROGRAM

C================================================================================
C---HAMILTONIAN
       SUBROUTINE HH(N,T,H,RPAR)
       IMPLICIT NONE
       INTEGER I,N
       DOUBLE PRECISION RPAR(10),T,HBAR,FIELD
       COMPLEX*8 H(N,N)
       HBAR=0.6582D0   !PLANCK'S CONSTANT IN eV*fs

       IF(T.LE.RPAR(2)) THEN
         FIELD=RPAR(4)*EXP(-((T-RPAR(2))/RPAR(3))**2.0)*
     .      COS(RPAR(1)*(T-RPAR(2))/HBAR)
       ELSE IF((T.GT.RPAR(2)).and.(t.le.600d0)) THEN
         FIELD=RPAR(4)*COS(RPAR(1)*(T-RPAR(2))/HBAR)
       END IF

       DO I=1,N/2
          H(I,I)=-RPAR(5)/2.0
       END DO
       DO I=1+N/2,N
          H(I,I)=RPAR(5)/2.0
       END DO
       DO I=1,N-1
         H(I,I+1)=RPAR(6)*FIELD
         H(I+1,I)=RPAR(6)*FIELD
       END DO

       RETURN
       END SUBROUTINE


!----------------------------------------------------------------------*
!  SUBROUTINE SUBGRN                                                   *
!  Adapted: Bouman, July 1999                                          *
!  Purpose: This subroutine calculates spikelet formation rate and     *
!           spikelet fertility as affected by low and high temperature *
!           and the grain growth rate.  Spikelet sterility component   *
!           is according to Horie et al., 1992.                        *
!                                                                      *
! FORMAL PARAMETERS:  (I=input,O=output,C=control,IN=init,T=time)      *
! name   type meaning (unit)                                     class *
! ----   ---- ---------------                                    ----- *
! GCR     R4  Gross growth rate of the crop (kg DM/ha/d)            I  *
! CROPSTA R4  Crop stage (-)                                        I  *
! LRSTRS  R4  Leaf rolling stress factor (-)                        I  *
! DVS     R4  Development stage of the crop (-)                     I  *
! SF1     R4  Spikelet fertility factor due to low temperatures (-) I  *
! SF2     R4  Spikelet fertility factor due to high temperatures (-)I  *
! SPGF    R4  Spikelet growth factor (no kg-1)                      I  *
! TAV     R4  Average daily temperature (oC)                        I  *
! TMAX    R4  Daily maximum temperature (oC)                        I  *
! NSP     R4  Number of spikelets (no)                              I  *
! CTSTER  R4  The critical temperature for 50% sterility (oC)       I  *
! COLDREP R4  The critical temperature for cold causing sterility (oC) *
! GNSP    R4  Rate of increase in spikelet number (no ha-1 d-1)     O  *
! GNGR    R4  Rate of increase in grain number (no ha-1 d-1)        O  *
! SPFERT  R4  Spikelet fertility (-)                                O  *
! GRAINS  L*  Fortran logical function whether grains are formed    O  *
!                                                                      *
!  FILE usage : none                                                   *
!----------------------------------------------------------------------*
     SUBROUTINE SUBGRN(GCR,CROPSTA,LRSTRS, &
                        DVS,SF2,SF1,SPGF,TAV,TMAX,NSP,CTSTER,COLDREP,GNSP,GNGR, &
                        SPFERT,GRAINS)

      IMPLICIT NONE
!-----Formal parameters
      REAL    GCR, DVS, SF2, SF1, SPGF, TAV, TMAX, NSP, GNSP, GNGR
      REAL    SPFERT, LRSTRS, CTSTER, COLDREP
      INTEGER CROPSTA
      LOGICAL GRAINS
!-----Local parameters
      REAL    DVSPI, DVSF, CTT, COLDTT, TFERT, NTFERT, TINCR
      SAVE

!     Initialization
      IF (CROPSTA .LE. 1) THEN
         GRAINS = .FALSE.
         COLDTT = 0.
         TFERT  = 0.
         NTFERT = 0.
         SF1    = 1.
         SF2    = 1.
         SPFERT = 1.
      END IF

!-----Temperature increase due to leaf rolling (BAS): 1.6 degree
!     per unit leaf rolling (Turner et al., 1986; p 269)
      LRSTRS = max(0.0, LRSTRS)   !TAOLI, 22Feb 2012
      TINCR = 5.*(1.-LRSTRS)*1.6

!-----Spikelet formation between PI and Flowering
      DVSPI = 0.65
      DVSF  = 1.
      IF ((DVS.GE.DVSPI).AND.(DVS.LE.DVSF)) THEN
         GNSP = max(0.0, GCR)*SPGF      !TAOLI, 22Feb 2012
      ELSE
         GNSP = 0.
      END IF

!-----Grain formation from spikelets (GNGR)
!-----Calculate GNGR reduction factors
      IF ((DVS.GE.0.75).AND.(DVS.LE.1.2)) THEN
         CTT    = MAX(0.,COLDREP -(TAV-TINCR))
         COLDTT = COLDTT+CTT
      END IF
      IF ((DVS.GE.0.96).AND.(DVS.LE.1.2)) THEN
         TFERT  = TFERT +(TMAX+TINCR)
         NTFERT = NTFERT+1.
      END IF

!-----Apply GNGR reduction factors when DVS is 1.2
      IF ((DVS.GE.1.2).AND.(.NOT.GRAINS)) THEN
         GRAINS = .TRUE.
         SF1    = 1.-(4.6+0.054*COLDTT**1.56)/100.
         SF1    = MIN(1.,MAX(0.,SF1))
         TFERT  = TFERT/(NTFERT)
         SF2    = 1./(1.+EXP(0.853*(TFERT-CTSTER)))
         SF2    = MIN(1.,MAX(0.,SF2))
         SPFERT = MIN(SF1,SF2)
         GNGR   = NSP*SPFERT
      ELSE
         GNGR   = 0.
      END IF
      RETURN
      END


Real Function xpp(srt)
  Real xarray(14), earray(14)
  Save
  Data earray/20., 30., 40., 60., 80., 100., 170., 250., 310., 350., 460., 560., 660., 800./
  Data xarray/150., 90., 80.6, 48.0, 36.6, 31.6, 25.9, 24.0, 23.1, 24.0, 28.3, 33.6, 41.5, 47/
  pmass = 0.9383
  ekin = 2000.*pmass*((srt/(2.*pmass))**2-1.)
  If (ekin<earray(1)) Then
    xpp = xarray(1)
    If (xpp>55) xpp = 55
    Return
  End If
  If (ekin>earray(14)) Then
    xpp = xarray(14)
    Return
  End If
  Do ie = 1, 14
    If (earray(ie)==ekin) Then
      xpp = xarray(ie)
      If (xpp>55) xpp = 55.
      Return
    End If
    If (earray(ie)>ekin) Then
      ymin = alog(xarray(ie-1))
      ymax = alog(xarray(ie))
      xmin = alog(earray(ie-1))
      xmax = alog(earray(ie))
      xpp = exp(ymin+(alog(ekin)-xmin)*(ymax-ymin)/(xmax-xmin))
      If (xpp>55) xpp = 55.
      Goto 50
    End If
  End Do
  50 Continue
  Return
End Function xpp


C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE INCOMINGDIS9(IDF,AMATRX,AMASS,CDMAT,COORDS,PROPS,NPROPS,C
C    1                  MCRD,AWAVE,IWAVE,NNODE,NDOFEL,R00,RELA,RINE,   C
C    2                  RDAM,DT,KINC)                                  C
C                                                                      C
C   Computes effective forces consistent with the incoming wave field  C
C   at time t.                                                         C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE INCOMINGDIS9(IDF,AMATRX,COORDS,PROPS,NPROPS,MCRD,AWAVE,
     1                       IWAVE,NNODE,NDOFEL,R00,DT,KINC,NINCR,IOUT)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER(ONE=1.0D0,ONENEG=-1.0D0)
C
      DIMENSION AMATRX(NDOFEL,NDOFEL),COORDS(MCRD,NNODE),PROPS(NPROPS),
     1          R00(NDOFEL),U0(NDOFEL),AWAVE(5),
     2          IELCON(4,3),U00(NDOFEL),RP(NDOFEL) !,LB(6),LEE(6),LE(12)

      INTEGER, ALLOCATABLE, DIMENSION(:):: LB, LEE, LE
C
      U0=0.0D0
      U00=0.0D0

C     Evaluate incoming displacements at time t.

      CALL DISPINCT9(IDF,U0,COORDS,NNODE,PROPS,NPROPS,MCRD,
     1              AWAVE,IWAVE,DT,KINC,IOUT)

C     Convert displacements and velocities into
C     effective forces at time t.

      IF (IDF==1 .OR. IDF==2 .OR. IDF==3 .OR. IDF==4) THEN

        ALLOCATE(LB(6), LEE(6), LE(12))

        DO I=1,NDOFEL
            AMATRX(I,I)=0.0D0
            U00(I)=U0(I)
        END DO

        CALL LOCIEL(IELCON)

        IF (IDF.EQ.1) THEN
            LEE(1)=3
            LEE(2)=4
            LEE(3)=6
            LEE(4)=7
            LEE(5)=8
            LEE(6)=9
        END IF

        IF (IDF.EQ.2) THEN
            LEE(1)=1
            LEE(2)=4
            LEE(3)=5
            LEE(4)=7
            LEE(5)=8
            LEE(6)=9
        END IF

        IF (IDF.EQ.3) THEN
            LEE(1)=1
            LEE(2)=2
            LEE(3)=5
            LEE(4)=6
            LEE(5)=8
            LEE(6)=9
        END IF

        IF (IDF.EQ.4) THEN
            LEE(1)=2
            LEE(2)=3
            LEE(3)=5
            LEE(4)=6
            LEE(5)=7
            LEE(6)=9
        END IF

C     Creates list of exterior DOFs

        DO I=1,6
            J=LEE(I)
            LE(2*I-1)=2*J-1
            LE(2*I)=2*J
        END DO

C     Creates list of boundary DOFs

        DO I=1,3
            J=IELCON(IDF,I)
            LB(2*I-1)=2*J-1
            LB(2*I)=2*J
        END DO

C     Identifies DOF in LB.

        DO J=1,NDOFEL
            IFLAG=0
            CALL BELONGS(LB,6,J,IFLAG)
            IF (IFLAG.EQ.1) THEN
                U00(J)=0.0D0
            END IF
        END DO

        R00=0.0D0
        RP=0.0D0

        RP=MATMUL(AMATRX, U00)

C     Assembles effective forces.

        DO J=1,NDOFEL
            IFLAG=0
            CALL BELONGS(LB,6,J,IFLAG)
            IF (IFLAG.EQ.1) THEN
                R00(J)=-RP(J)
            END IF
        END DO

        U00=0.0D0

        DO I=1,NDOFEL
            U00(I)=U0(I)
        END DO

        RP=0.0D0

C     Identifies DOF in LE.

        DO J=1,NDOFEL
            IFLAG=0
            CALL BELONGS(LE,12,J,IFLAG)
            IF (IFLAG.EQ.1) THEN
                U00(J)=0.0D0
            END IF
        END DO

        RP=MATMUL(AMATRX, U00)

C     Assembles effective forces.

        DO J=1,NDOFEL
            IFLAG=0
            CALL BELONGS(LE,12,J,IFLAG)
            IF (IFLAG.EQ.1) THEN
                R00(J)=RP(J)
            END IF
        END DO

      ELSE

        ALLOCATE(LB(2), LEE(8), LE(16))

        DO I=1,NDOFEL
            AMATRX(I,I)=0.0D0
            U00(I)=U0(I)
        END DO

        IF (IDF.EQ.5) THEN
            LEE(1)=2
            LEE(2)=3
            LEE(3)=4
            LEE(4)=5
            LEE(5)=6
            LEE(6)=7
            LEE(7)=8
            LEE(8)=9

C     Creates list of boundary DOFs

            LB(1)=1
            LB(2)=2

        END IF

        IF (IDF.EQ.6) THEN
            LEE(1)=1
            LEE(2)=3
            LEE(3)=4
            LEE(4)=5
            LEE(5)=6
            LEE(6)=7
            LEE(7)=8
            LEE(8)=9

C     Creates list of boundary DOFs

            LB(1)=3
            LB(2)=4

        END IF

        IF (IDF.EQ.7) THEN
            LEE(1)=1
            LEE(2)=2
            LEE(3)=4
            LEE(4)=5
            LEE(5)=6
            LEE(6)=7
            LEE(7)=8
            LEE(8)=9

C     Creates list of boundary DOFs

            LB(1)=5
            LB(2)=6

        END IF

        IF (IDF.EQ.8) THEN
            LEE(1)=1
            LEE(2)=2
            LEE(3)=3
            LEE(4)=5
            LEE(5)=6
            LEE(6)=7
            LEE(7)=8
            LEE(8)=9

C     Creates list of boundary DOFs

            LB(1)=7
            LB(2)=8

        END IF

C     Creates list of exterior DOFs

        DO I=1,8
            J=LEE(I)
            LE(2*I-1)=2*J-1
            LE(2*I)=2*J
        END DO

C     Identifies DOF in LB.

        DO J=1,NDOFEL
            IFLAG=0
            CALL BELONGS(LB,2,J,IFLAG)
            IF (IFLAG.EQ.1) THEN
               U00(J)=0.0D0
            END IF
        END DO

        R00=0.0D0
        RP=0.0D0

        RP=MATMUL(AMATRX, U00)

C     Assembles effective forces.

        DO J=1,NDOFEL
            IFLAG=0
            CALL BELONGS(LB,2,J,IFLAG)
            IF (IFLAG.EQ.1) THEN
               R00(J)=-RP(J)
            END IF
        END DO

        U00=0.0D0

        DO I=1,NDOFEL
            U00(I)=U0(I)
        END DO

        RP=0.0D0

C     Identifies DOF in LE.

        DO J=1,NDOFEL
            IFLAG=0
            CALL BELONGS(LE,16,J,IFLAG)
            IF (IFLAG.EQ.1) THEN
               U00(J)=0.0D0
            END IF
        END DO

        RP=MATMUL(AMATRX, U00)

C     Assembles effective forces.

        DO J=1,NDOFEL
            IFLAG=0
            CALL BELONGS(LE,16,J,IFLAG)
            IF (IFLAG.EQ.1) THEN
               R00(J)=RP(J)
            END IF
        END DO

      END IF

      RETURN

      END

C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE INCOMINGDIS8(IDF,AMATRX,AMASS,CDMAT,COORDS,PROPS,NPROPS, C
C    1                  MCRD,AWAVE,IWAVE,NNODE,NDOFEL,R00,RELA,RINE,   C
C    2                  RDAM,DT,KINC)                                  C
C                                                                      C
C   Computes effective forces consistent with the incoming wave field  C
C   at time t.                                                         C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE INCOMINGDIS8(IDF,AMATRX,COORDS,PROPS,NPROPS,MCRD,AWAVE,
     1                       IWAVE,NNODE,NDOFEL,R00,DT,KINC,NINCR,IOUT)

      IMPLICIT REAL*8(A-H,O-Z)

      PARAMETER(ONE=1.0D0,ONENEG=-1.0D0)

      DIMENSION AMATRX(NDOFEL,NDOFEL),COORDS(MCRD,NNODE),PROPS(NPROPS),
     1          R00(NDOFEL),U0(NDOFEL),AWAVE(5),
     2          IELCON(4,3),U00(NDOFEL),RP(NDOFEL)! ,LB(6),LEE(5),LE(10)

      INTEGER, ALLOCATABLE, DIMENSION(:):: LB, LEE, LE

      U0=0.0D0
	  U00=0.0D0
C     Evaluate incoming displacements at time t.

      CALL DISPINCT8(IDF,U0,COORDS,NNODE,PROPS,NPROPS,MCRD,
     1              AWAVE,IWAVE,DT,KINC,IOUT)

C     Convert displacements and velocities into
C     effective forces at time t.

      IF (IDF==1 .OR. IDF==2 .OR. IDF==3 .OR. IDF==4) THEN

        ALLOCATE(LB(6), LEE(5), LE(10))

        DO I=1,NDOFEL
            AMATRX(I,I)=0.0D0
            U00(I)=U0(I)
        END DO

        CALL LOCIEL(IELCON)

        IF (IDF.EQ.1) THEN
            LEE(1)=3
            LEE(2)=4
            LEE(3)=6
            LEE(4)=7
            LEE(5)=8
        END IF

        IF (IDF.EQ.2) THEN
            LEE(1)=1
            LEE(2)=4
            LEE(3)=5
            LEE(4)=7
            LEE(5)=8
        END IF

        IF (IDF.EQ.3) THEN
            LEE(1)=1
            LEE(2)=2
            LEE(3)=5
            LEE(4)=6
            LEE(5)=8
        END IF

        IF (IDF.EQ.4) THEN
            LEE(1)=2
            LEE(2)=3
            LEE(3)=5
            LEE(4)=6
            LEE(5)=7
        END IF

C     Creates list of exterior DOFs

        DO I=1,5
            J=LEE(I)
            LE(2*I-1)=2*J-1
            LE(2*I)=2*J
        END DO

C     Creates list of boundary DOFs

        DO I=1,3
            J=IELCON(IDF,I)
            LB(2*I-1)=2*J-1
            LB(2*I)=2*J
        END DO

C     Identifies DOF in LB.

        DO J=1,NDOFEL
            IFLAG=0
            CALL BELONGS(LB,6,J,IFLAG)
            IF (IFLAG.EQ.1) THEN
                U00(J)=0.0D0
            END IF
        END DO

        R00=0.0D0
        RP=0.0D0

        RP=MATMUL(AMATRX, U00)

C     Assembles effective forces.

        DO J=1,NDOFEL
            IFLAG=0
            CALL BELONGS(LB,6,J,IFLAG)
            IF (IFLAG.EQ.1) THEN
               R00(J)=-RP(J)
            END IF
        END DO

        U00=0.0D0

        DO I=1,NDOFEL
            U00(I)=U0(I)
        END DO

        RP=0.0D0

C     Identifies DOF in LE.

        DO J=1,NDOFEL
            IFLAG=0
            CALL BELONGS(LE,10,J,IFLAG)
            IF (IFLAG.EQ.1) THEN
               U00(J)=0.0D0
            END IF
        END DO

        RP=MATMUL(AMATRX, U00)

C     Assembles effective forces.

        DO J=1,NDOFEL
            IFLAG=0
            CALL BELONGS(LE,10,J,IFLAG)
            IF (IFLAG.EQ.1) THEN
               R00(J)=RP(J)
            END IF
        END DO

      ELSE

        ALLOCATE(LB(2), LEE(7), LE(14))

        DO I=1,NDOFEL
            AMATRX(I,I)=0.0D0
            U00(I)=U0(I)
        END DO

        IF (IDF.EQ.5) THEN
            LEE(1)=2
            LEE(2)=3
            LEE(3)=4
            LEE(4)=5
            LEE(5)=6
            LEE(6)=7
            LEE(7)=8

C     Creates list of boundary DOFs

            LB(1)=1
            LB(2)=2

        END IF

        IF (IDF.EQ.6) THEN
            LEE(1)=1
            LEE(2)=3
            LEE(3)=4
            LEE(4)=5
            LEE(5)=6
            LEE(6)=7
            LEE(7)=8

C     Creates list of boundary DOFs

            LB(1)=3
            LB(2)=4

        END IF

        IF (IDF.EQ.7) THEN
            LEE(1)=1
            LEE(2)=2
            LEE(3)=4
            LEE(4)=5
            LEE(5)=6
            LEE(6)=7
            LEE(7)=8

C     Creates list of boundary DOFs

            LB(1)=5
            LB(2)=6

        END IF

        IF (IDF.EQ.8) THEN
            LEE(1)=1
            LEE(2)=2
            LEE(3)=3
            LEE(4)=5
            LEE(5)=6
            LEE(6)=7
            LEE(7)=8

C     Creates list of boundary DOFs

            LB(1)=7
            LB(2)=8

        END IF

C     Creates list of exterior DOFs

        DO I=1,7
            J=LEE(I)
            LE(2*I-1)=2*J-1
            LE(2*I)=2*J
        END DO

C     Identifies DOF in LB.

        DO J=1,NDOFEL
            IFLAG=0
            CALL BELONGS(LB,2,J,IFLAG)
            IF (IFLAG.EQ.1) THEN
               U00(J)=0.0D0
            END IF
        END DO

        R00=0.0D0
        RP=0.0D0

        RP=MATMUL(AMATRX, U00)

C     Assembles effective forces.

        DO J=1,NDOFEL
            IFLAG=0
            CALL BELONGS(LB,2,J,IFLAG)
            IF (IFLAG.EQ.1) THEN
               R00(J)=-RP(J)
            END IF
        END DO

        U00=0.0D0

        DO I=1,NDOFEL
            U00(I)=U0(I)
        END DO

        RP=0.0D0

C     Identifies DOF in LE.

        DO J=1,NDOFEL
            IFLAG=0
            CALL BELONGS(LE,14,J,IFLAG)
            IF (IFLAG.EQ.1) THEN
               U00(J)=0.0D0
            END IF
        END DO

        RP=MATMUL(AMATRX, U00)

C     Assembles effective forces.

        DO J=1,NDOFEL
            IFLAG=0
            CALL BELONGS(LE,14,J,IFLAG)
            IF (IFLAG.EQ.1) THEN
               R00(J)=RP(J)
            END IF
        END DO

      END IF

      RETURN
C
      END

C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE INCOMINGDIS4(IDF,AMATRX,AMASS,CDMAT,COORDS,PROPS,NPROPS,C
C    1                  MCRD,AWAVE,IWAVE,NNODE,NDOFEL,R00,RELA,RINE,   C
C    2                  RDAM,DT,KINC)                                  C
C                                                                      C
C   Computes effective forces consistent with the incoming wave field  C
C   at time t.                                                         C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE INCOMINGDIS4(IDF,AMATRX,COORDS,PROPS,NPROPS,MCRD,AWAVE,
     1                       IWAVE,NNODE,NDOFEL,R00,DT,KINC,NINCR,IOUT)

      IMPLICIT REAL*8(A-H,O-Z)

      PARAMETER(ONE=1.0D0,ONENEG=-1.0D0)

      DIMENSION AMATRX(NDOFEL,NDOFEL),COORDS(MCRD,NNODE),PROPS(NPROPS),
     1          R00(NDOFEL),U0(NDOFEL),AWAVE(5),
     2          IELCON(4,2),U00(NDOFEL),RP(NDOFEL)

      INTEGER, ALLOCATABLE, DIMENSION(:):: LB, LEE, LE

	  U0=0.0D0
	  U00=0.0D0

C     Evaluate incoming displacements at time t.

      CALL DISPINCT4(IDF,U0,COORDS,NNODE,PROPS,NPROPS,MCRD,
     1              AWAVE,IWAVE,DT,KINC,IOUT)

C     Convert displacements and velocities into
C     effective forces at time t.

      IF (IDF==1 .OR. IDF==2 .OR. IDF==3 .OR. IDF==4) THEN

        ALLOCATE(LB(4), LEE(2), LE(4))

        DO I=1,NDOFEL
            AMATRX(I,I)=0.0D0
            U00(I)=U0(I)
        END DO

        CALL LOCIEL2(IELCON)

        IF (IDF.EQ.1) THEN
            LEE(1)=3
            LEE(2)=4
        END IF

        IF (IDF.EQ.2) THEN
            LEE(1)=1
            LEE(2)=4
        END IF

        IF (IDF.EQ.3) THEN
            LEE(1)=1
            LEE(2)=2
        END IF

        IF (IDF.EQ.4) THEN
            LEE(1)=2
            LEE(2)=3
        END IF

C     Creates list of exterior DOFs

        DO I=1,2
            J=LEE(I)
            LE(2*I-1)=2*J-1
            LE(2*I)=2*J
        END DO

C     Creates list of boundary DOFs

        DO I=1,2
            J=IELCON(IDF,I)
            LB(2*I-1)=2*J-1
            LB(2*I)=2*J
        END DO

C     Identifies DOF in LB.

        DO J=1,NDOFEL
            IFLAG=0
            CALL BELONGS(LB,4,J,IFLAG)
            IF (IFLAG.EQ.1) THEN
                U00(J)=0.0D0
            END IF
        END DO

        R00=0.0D0
        RP=0.0D0

        RP=MATMUL(AMATRX, U00)

C     Assembles effective forces.

        DO J=1,NDOFEL
            IFLAG=0
            CALL BELONGS(LB,4,J,IFLAG)
            IF (IFLAG.EQ.1) THEN
               R00(J)=-RP(J)
            END IF
        END DO

        U00=0.0D0

        DO I=1,NDOFEL
            U00(I)=U0(I)
        END DO

        RP=0.0D0

C     Identifies DOF in LE.

        DO J=1,NDOFEL
            IFLAG=0
            CALL BELONGS(LE,4,J,IFLAG)
            IF (IFLAG.EQ.1) THEN
               U00(J)=0.0D0
            END IF
        END DO

        RP=MATMUL(AMATRX, U00)

C     Assembles effective forces.

        DO J=1,NDOFEL
            IFLAG=0
            CALL BELONGS(LE,4,J,IFLAG)
            IF (IFLAG.EQ.1) THEN
               R00(J)=RP(J)
            END IF
        END DO

      ELSE

        ALLOCATE(LB(2), LEE(3), LE(6))

        DO I=1,NDOFEL
            AMATRX(I,I)=0.0D0
            U00(I)=U0(I)
        END DO

        IF (IDF.EQ.5) THEN
            LEE(1)=2
            LEE(2)=3
            LEE(3)=4

C     Creates list of boundary DOFs

            LB(1)=1
            LB(2)=2

        END IF

        IF (IDF.EQ.6) THEN
            LEE(1)=1
            LEE(2)=3
            LEE(3)=4

C     Creates list of boundary DOFs

            LB(1)=3
            LB(2)=4

        END IF

        IF (IDF.EQ.7) THEN
            LEE(1)=1
            LEE(2)=2
            LEE(3)=4

C     Creates list of boundary DOFs

            LB(1)=5
            LB(2)=6

        END IF

        IF (IDF.EQ.8) THEN
            LEE(1)=1
            LEE(2)=2
            LEE(3)=3

C     Creates list of boundary DOFs

            LB(1)=7
            LB(2)=8

        END IF

C     Creates list of exterior DOFs

        DO I=1,3
            J=LEE(I)
            LE(2*I-1)=2*J-1
            LE(2*I)=2*J
        END DO

C     Identifies DOF in LB.

        DO J=1,NDOFEL
            IFLAG=0
            CALL BELONGS(LB,2,J,IFLAG)
            IF (IFLAG.EQ.1) THEN
               U00(J)=0.0D0
            END IF
        END DO

        R00=0.0D0
        RP=0.0D0

        RP=MATMUL(AMATRX, U00)

C     Assembles effective forces.

        DO J=1,NDOFEL
            IFLAG=0
            CALL BELONGS(LB,2,J,IFLAG)
            IF (IFLAG.EQ.1) THEN
               R00(J)=-RP(J)
            END IF
        END DO

        U00=0.0D0

        DO I=1,NDOFEL
            U00(I)=U0(I)
        END DO

        RP=0.0D0

C     Identifies DOF in LE.

        DO J=1,NDOFEL
            IFLAG=0
            CALL BELONGS(LE,6,J,IFLAG)
            IF (IFLAG.EQ.1) THEN
               U00(J)=0.0D0
            END IF
        END DO

        RP=MATMUL(AMATRX, U00)

C     Assembles effective forces.

        DO J=1,NDOFEL
            IFLAG=0
            CALL BELONGS(LE,6,J,IFLAG)
            IF (IFLAG.EQ.1) THEN
               R00(J)=RP(J)
            END IF
        END DO

      END IF

      RETURN
C
      END

C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE DISPINCT9(IDF,U0,V0,A0,COORDS,NNODE,PROPS,NPROPS,MCRD,   C
C                      AWAVE,IWAVE,IELCON,DT,KNINC)                    C
C                                                                      C
C   Evaluates and assembles the displacement field.                    C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE DISPINCT9(IDF,U0,COORDS,NNODE,PROPS,NPROPS,MCRD,
     1                    AWAVE,IWAVE,DT,KINC,IOUT)

      IMPLICIT REAL*8(A-H,O-Z)

      DIMENSION U0(18), AWAVE(5),COORDS(MCRD,NNODE),PROPS(NPROPS)

      PARAMETER (ZERO=0.0D0,ONE=1.0D0,HALF=0.5D0,TWO=2.0D0,FOUR=4.0D0)

C     Incident wave properties.

      FC=AWAVE(3)
      TMAX=AWAVE(1)
      TINI=AWAVE(2)
      AMPR=AWAVE(4)
      PHI=AWAVE(5)

C     Elastic properties

      AALFA=PROPS(1)
      ABETA=PROPS(2)
      RO=PROPS(3)

C     Compute incoming dispalcements for all the nodes in
C     an element.

      DO II=1,NNODE
        X1=COORDS(1,II)
        X3=COORDS(2,II)

        IF(IWAVE.EQ.1) THEN

          US1=0.0D0
          US2=0.0D0

          CALL PWDISPT(FC,TINI,AMPR,PHI,AALFA,ABETA,X1,X3,
     1                  KINC,DT,US1,US2)

          U0(2*II-1)=US1
          U0(2*II  )=US2

        ELSE

          US1=0.0D0
          US2=0.0D0

          CALL SWDISPT(FC,TINI,AMPR,PHI,AALFA,ABETA,X1,X3,
     1                  KINC,DT,US1,US2)

          U0(2*II-1)=US1
          U0(2*II  )=US2

        END IF

      END DO

      RETURN

      END

C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE DISPINCT8(IDF,U0,V0,A0,COORDS,NNODE,PROPS,NPROPS,MCRD,   C
C                      AWAVE,IWAVE,IELCON,DT,KNINC)                    C
C                                                                      C
C   Evaluates and assembles the displacement field.                    C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE DISPINCT8(IDF,U0,COORDS,NNODE,PROPS,NPROPS,MCRD,
     1                    AWAVE,IWAVE,DT,KINC,IOUT)

      IMPLICIT REAL*8(A-H,O-Z)

      DIMENSION U0(16), AWAVE(5),COORDS(MCRD,NNODE),PROPS(NPROPS)

      PARAMETER (ZERO=0.0D0,ONE=1.0D0,HALF=0.5D0,TWO=2.0D0,FOUR=4.0D0)

C     Incident wave properties.

      FC=AWAVE(3)
      TMAX=AWAVE(1)
      TINI=AWAVE(2)
      AMPR=AWAVE(4)
      PHI=AWAVE(5)

C     Elastic properties

      AALFA=PROPS(1)
      ABETA=PROPS(2)
      RO=PROPS(3)

C     Compute incoming dispalcements for all the nodes in
C     an element.

      DO II=1,NNODE
        X1=COORDS(1,II)
        X3=COORDS(2,II)

        IF(IWAVE.EQ.1) THEN

          US1=0.0D0
          US2=0.0D0

          CALL PWDISPT(FC,TINI,AMPR,PHI,AALFA,ABETA,X1,X3,
     1                  KINC,DT,US1,US2)

          U0(2*II-1)=US1
          U0(2*II  )=US2

        ELSE

          US1=0.0D0
          US2=0.0D0

          CALL SWDISPT(FC,TINI,AMPR,PHI,AALFA,ABETA,X1,X3,
     1                  KINC,DT,US1,US2)

          U0(2*II-1)=US1
          U0(2*II  )=US2

        END IF

      END DO

      RETURN

      END

C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE DISPINCT4(IDF,U0,V0,A0,COORDS,NNODE,PROPS,NPROPS,MCRD,  C
C                      AWAVE,IWAVE,IELCON,DT,KNINC)                    C
C                                                                      C
C   Evaluates and assembles the displacement field.                    C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE DISPINCT4(IDF,U0,COORDS,NNODE,PROPS,NPROPS,MCRD,
     1                    AWAVE,IWAVE,DT,KINC,IOUT)

      IMPLICIT REAL*8(A-H,O-Z)

      DIMENSION U0(8), AWAVE(5),COORDS(MCRD,NNODE),PROPS(NPROPS)

      PARAMETER (ZERO=0.0D0,ONE=1.0D0,HALF=0.5D0,TWO=2.0D0,FOUR=4.0D0)

C     Incident wave properties.

      FC=AWAVE(3)
      TMAX=AWAVE(1)
      TINI=AWAVE(2)
      AMPR=AWAVE(4)
      PHI=AWAVE(5)

C     Elastic properties

      AALFA=PROPS(1)
      ABETA=PROPS(2)
      RO=PROPS(3)

C     Compute incoming dispalcements for all the nodes in
C     an element.

      DO II=1,NNODE
        X1=COORDS(1,II)
        X3=COORDS(2,II)

        IF(IWAVE.EQ.1) THEN

          US1=0.0D0
          US2=0.0D0

          CALL PWDISPT(FC,TINI,AMPR,PHI,AALFA,ABETA,X1,X3,
     1                  KINC,DT,US1,US2)

          U0(2*II-1)=US1
          U0(2*II  )=US2

        ELSE

          US1=0.0D0
          US2=0.0D0

          CALL SWDISPT(FC,TINI,AMPR,PHI,AALFA,ABETA,X1,X3,
     1                  KINC,DT,US1,US2)

          U0(2*II-1)=US1
          U0(2*II  )=US2

        END IF

      END DO

      RETURN

      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE PWDISPT(FC,TMAX,TINI,AMP,PHI,AALFA,ABETA,RO,X1,X3,US1,C
C    1                   US2,VS1,VS2,AS1,AS2,NF)                       C
C                                                                      C
C     Computes the displacements vector for a P-Wave incident at a     C
C     point X1,X3.                                                     C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE PWDISPT(FC,TINI,AMP,PHI,AALFA,ABETA,X1,X3,
     1                   KINC,DT,US1,US2)

      IMPLICIT REAL*8(A-H,O-Z)

      PARAMETER (ZERO=0.0D0,ONE=1.0D0,HALF=0.5D0,TWO=2.0D0,FOUR=4.0D0)

      PI=4.0D0*DATAN(ONE)

      PHIR=PHI*PI/180.0D0
      PL=DSIN(PHIR)/AALFA
      ZHIR=DASIN(ABETA*PL)

      SNX=DSIN(PHIR)/AALFA*X1
      CNZ=DCOS(PHIR)/AALFA*X3
      ENX=DSIN(ZHIR)/ABETA*X1
      ENZ=DCOS(ZHIR)/ABETA*X3

      F1=ONE/ABETA**2-TWO*PL**2
      F1S=F1**2
      F2=FOUR*PL**2*(DCOS(PHIR)/AALFA)*(DCOS(ZHIR)/ABETA)

C     Compute reflection coefficients (PP,PS) and related constants.

      PP=(F2-F1S)/(F2+F1S)
      PS=(FOUR*AALFA/ABETA*PL*(DCOS(PHIR)/AALFA)*F1)/(F1S+F2)

C     Incident P-wave field.

      tao=(SNX-CNZ)-(DT*(KINC-1)-TINI)
      upft=(2.0D0*(PI*tao*FC)**2-1.0D0)*DEXP(-(PI*tao*FC)**2)

      UPPI= AMP*DSIN(PHIR)*upft
      WPPI=-AMP*DCOS(PHIR)*upft

C     Reflected P-wave field.

      tao=(SNX+CNZ)-(DT*(KINC-1)-TINI)
      upft=(2.0D0*(PI*tao*FC)**2-1.0D0)*DEXP(-(PI*tao*FC)**2)

      UPPR=AMP*DSIN(PHIR)*PP*upft
      WPPR=AMP*DCOS(PHIR)*PP*upft

C     Reflected S-wave field.

      tao=(ENX+ENZ)-(DT*(KINC-1)-TINI)
      upft=(2.0D0*(PI*tao*FC)**2-1.0D0)*DEXP(-(PI*tao*FC)**2)

      UPSR= AMP*DCOS(ZHIR)*PS*upft
      WPSR=-AMP*DSIN(ZHIR)*PS*upft

C     Total wave field.

      US1=UPPI+UPPR+UPSR
      US2=WPPI+WPPR+WPSR

      RETURN

      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE SWDISPT(FC,TMAX,TINI,AMP,ZHI,AALFA,ABETA,RO,X1,X3,US1,C
C    1                   US2,VS1,VS2,AS1,AS2,NF)                       C
C                                                                      C
C     Computes the displacements vector for a P-Wave incident at a     C
C     point X1,X3.                                                     C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE SWDISPT(FC,TINI,AMP,ZHI,AALFA,ABETA,X1,X3,
     1                   KINC,DT,US1,US2)

      IMPLICIT REAL*8(A-H,O-Z)

      PARAMETER (ZERO=0.0D0,ONE=1.0D0,HALF=0.5D0,TWO=2.0D0,FOUR=4.0D0)

      PI=4.0D0*DATAN(ONE)

      ZHIR=ZHI*PI/180.D0
      PL=DSIN(ZHIR)/ABETA
      PHIR=DASIN(AALFA*PL)

      SNX=DSIN(PHIR)/AALFA*X1
      CNZ=DCOS(PHIR)/AALFA*X3
      ENX=DSIN(ZHIR)/ABETA*X1
      ENZ=DCOS(ZHIR)/ABETA*X3

      F1=ONE/ABETA**2-TWO*PL**2
      F1S=F1**2
      F2=FOUR*PL**2*(DCOS(PHIR)/AALFA)*(DCOS(ZHIR)/ABETA)

C     Compute reflection coefficients PP,PS and related constants.

      SS=(F1S-F2)/(F2+F1S)
      SP=(FOUR*ABETA/AALFA*PL*(DCOS(ZHIR)/ABETA)*F1)/(F1S+F2)

C     Incident SV-wave field.

      tao=(ENX-ENZ)-(DT*(KINC-1)-TINI)
      usft=(2.0D0*(PI*tao*FC)**2-1.0D0)*DEXP(-(PI*tao*FC)**2)
      USVI= AMP*DCOS(ZHIR)*usft
      WSVI= AMP*DSIN(ZHIR)*usft

C     Reflected P-wave field.

      tao=(SNX+CNZ)-(DT*(KINC-1)-TINI)
      usft=(2.0D0*(PI*tao*FC)**2-1.D0)*DEXP(-(PI*tao*FC)**2)
      USPR= AMP*DSIN(PHIR)*SP*usft
      WSPR= AMP*DCOS(PHIR)*SP*usft

C     Reflected SV-wave field.

      tao=(ENX+ENZ)-(DT*(KINC-1)-TINI)
      usft=(2.0D0*(PI*tao*FC)**2-1.0D0)*DEXP(-(PI*tao*FC)**2)
      USVR= AMP*DCOS(ZHIR)*SS*usft
      WSVR=-AMP*DSIN(ZHIR)*SS*usft

C     Total wave field.

      US1=USVI+USPR+USVR
      US2=WSVI+WSPR+WSVR

      RETURN

      END

C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE LOCIEL(IELCON)                                          C
C                                                                      C
C   Creates the connectivity array for an 8-noded 2D element which is  C
C   considered like an assembly of 4 3-noded 1D elements               C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE LOCIEL(IELCON)

      IMPLICIT REAL*8(A-H,O-Z)

      DIMENSION IELCON(4,3)

      IELCON(1,1)=1
      IELCON(1,2)=2
      IELCON(1,3)=5

      IELCON(2,1)=2
      IELCON(2,2)=3
      IELCON(2,3)=6

      IELCON(3,1)=3
      IELCON(3,2)=4
      IELCON(3,3)=7

      IELCON(4,1)=4
      IELCON(4,2)=1
      IELCON(4,3)=8

      RETURN

      END

C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE LOCIEL2(IELCON)                                         C
C                                                                      C
C   Creates the connectivity array for an 8-noded 2D element which is  C
C   considered like an assembly of 4 3-noded 1D elements               C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE LOCIEL2(IELCON)

      IMPLICIT REAL*8(A-H,O-Z)

      DIMENSION IELCON(4,2)

      IELCON(1,1)=1
      IELCON(1,2)=2

      IELCON(2,1)=2
      IELCON(2,2)=3

      IELCON(3,1)=3
      IELCON(3,2)=4

      IELCON(4,1)=4
      IELCON(4,2)=1

      RETURN

      END


      SUBROUTINE DGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK,
     $                   WORK, INFO )
*
*  -- LAPACK driver routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, M, N, NRHS, RANK
      DOUBLE PRECISION   RCOND
*     ..
*     .. Array Arguments ..
      INTEGER            JPVT( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  This routine is deprecated and has been replaced by routine DGELSY.
*
*  DGELSX computes the minimum-norm solution to a real linear least
*  squares problem:
*      minimize || A * X - B ||
*  using a complete orthogonal factorization of A.  A is an M-by-N
*  matrix which may be rank-deficient.
*
*  Several right hand side vectors b and solution vectors x can be
*  handled in a single call; they are stored as the columns of the
*  M-by-NRHS right hand side matrix B and the N-by-NRHS solution
*  matrix X.
*
*  The routine first computes a QR factorization with column pivoting:
*      A * P = Q * [ R11 R12 ]
*                  [  0  R22 ]
*  with R11 defined as the largest leading submatrix whose estimated
*  condition number is less than 1/RCOND.  The order of R11, RANK,
*  is the effective rank of A.
*
*  Then, R22 is considered to be negligible, and R12 is annihilated
*  by orthogonal transformations from the right, arriving at the
*  complete orthogonal factorization:
*     A * P = Q * [ T11 0 ] * Z
*                 [  0  0 ]
*  The minimum-norm solution is then
*     X = P * Z' [ inv(T11)*Q1'*B ]
*                [        0       ]
*  where Q1 consists of the first RANK columns of Q.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix A.  M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix A.  N >= 0.
*
*  NRHS    (input) INTEGER
*          The number of right hand sides, i.e., the number of
*          columns of matrices B and X. NRHS >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the M-by-N matrix A.
*          On exit, A has been overwritten by details of its
*          complete orthogonal factorization.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,M).
*
*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
*          On entry, the M-by-NRHS right hand side matrix B.
*          On exit, the N-by-NRHS solution matrix X.
*          If m >= n and RANK = n, the residual sum-of-squares for
*          the solution in the i-th column is given by the sum of
*          squares of elements N+1:M in that column.
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B. LDB >= max(1,M,N).
*
*  JPVT    (input/output) INTEGER array, dimension (N)
*          On entry, if JPVT(i) .ne. 0, the i-th column of A is an
*          initial column, otherwise it is a free column.  Before
*          the QR factorization of A, all initial columns are
*          permuted to the leading positions; only the remaining
*          free columns are moved as a result of column pivoting
*          during the factorization.
*          On exit, if JPVT(i) = k, then the i-th column of A*P
*          was the k-th column of A.
*
*  RCOND   (input) DOUBLE PRECISION
*          RCOND is used to determine the effective rank of A, which
*          is defined as the order of the largest leading triangular
*          submatrix R11 in the QR factorization with pivoting of A,
*          whose estimated condition number < 1/RCOND.
*
*  RANK    (output) INTEGER
*          The effective rank of A, i.e., the order of the submatrix
*          R11.  This is the same as the order of the submatrix T11
*          in the complete orthogonal factorization of A.
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension
*                      (max( min(M,N)+3*N, 2*min(M,N)+NRHS )),
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            IMAX, IMIN
      PARAMETER          ( IMAX = 1, IMIN = 2 )
      DOUBLE PRECISION   ZERO, ONE, DONE, NTDONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, DONE = ZERO,
     $                   NTDONE = ONE )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IASCL, IBSCL, ISMAX, ISMIN, J, K, MN
      DOUBLE PRECISION   ANRM, BIGNUM, BNRM, C1, C2, S1, S2, SMAX,
     $                   SMAXPR, SMIN, SMINPR, SMLNUM, T1, T2
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, DLANGE
      EXTERNAL           DLAMCH, DLANGE
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGEQPF, DLAIC1, DLASCL, DLASET, DLATZM, DORM2R,
     $                   DTRSM, DTZRQF, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
*     ..
*     .. Executable Statements ..
*
      MN = MIN( M, N )
      ISMIN = MN + 1
      ISMAX = 2*MN + 1
*
*     Test the input arguments.
*
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
         INFO = -7
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGELSX', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( MIN( M, N, NRHS ).EQ.0 ) THEN
         RANK = 0
         RETURN
      END IF
*
*     Get machine parameters
*
      SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' )
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
*
*     Scale A, B if max elements outside range [SMLNUM,BIGNUM]
*
      ANRM = DLANGE( 'M', M, N, A, LDA, WORK )
      IASCL = 0
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
*
*        Scale matrix norm up to SMLNUM
*
         CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
         IASCL = 1
      ELSE IF( ANRM.GT.BIGNUM ) THEN
*
*        Scale matrix norm down to BIGNUM
*
         CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
         IASCL = 2
      ELSE IF( ANRM.EQ.ZERO ) THEN
*
*        Matrix all zero. Return zero solution.
*
         CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
         RANK = 0
         GO TO 100
      END IF
*
      BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK )
      IBSCL = 0
      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
*
*        Scale matrix norm up to SMLNUM
*
         CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
         IBSCL = 1
      ELSE IF( BNRM.GT.BIGNUM ) THEN
*
*        Scale matrix norm down to BIGNUM
*
         CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
         IBSCL = 2
      END IF
*
*     Compute QR factorization with column pivoting of A:
*        A * P = Q * R
*
      CALL DGEQPF( M, N, A, LDA, JPVT, WORK( 1 ), WORK( MN+1 ), INFO )
*
*     workspace 3*N. Details of Householder rotations stored
*     in WORK(1:MN).
*
*     Determine RANK using incremental condition estimation
*
      WORK( ISMIN ) = ONE
      WORK( ISMAX ) = ONE
      SMAX = ABS( A( 1, 1 ) )
      SMIN = SMAX
      IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN
         RANK = 0
         CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
         GO TO 100
      ELSE
         RANK = 1
      END IF
*
   10 CONTINUE
      IF( RANK.LT.MN ) THEN
         I = RANK + 1
         CALL DLAIC1( IMIN, RANK, WORK( ISMIN ), SMIN, A( 1, I ),
     $                A( I, I ), SMINPR, S1, C1 )
         CALL DLAIC1( IMAX, RANK, WORK( ISMAX ), SMAX, A( 1, I ),
     $                A( I, I ), SMAXPR, S2, C2 )
*
         IF( SMAXPR*RCOND.LE.SMINPR ) THEN
            DO 20 I = 1, RANK
               WORK( ISMIN+I-1 ) = S1*WORK( ISMIN+I-1 )
               WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 )
   20       CONTINUE
            WORK( ISMIN+RANK ) = C1
            WORK( ISMAX+RANK ) = C2
            SMIN = SMINPR
            SMAX = SMAXPR
            RANK = RANK + 1
            GO TO 10
         END IF
      END IF
*
*     Logically partition R = [ R11 R12 ]
*                             [  0  R22 ]
*     where R11 = R(1:RANK,1:RANK)
*
*     [R11,R12] = [ T11, 0 ] * Y
*
      IF( RANK.LT.N )
     $   CALL DTZRQF( RANK, N, A, LDA, WORK( MN+1 ), INFO )
*
*     Details of Householder rotations stored in WORK(MN+1:2*MN)
*
*     B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS)
*
      CALL DORM2R( 'Left', 'Transpose', M, NRHS, MN, A, LDA, WORK( 1 ),
     $             B, LDB, WORK( 2*MN+1 ), INFO )
*
*     workspace NRHS
*
*     B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS)
*
      CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK,
     $            NRHS, ONE, A, LDA, B, LDB )
*
      DO 40 I = RANK + 1, N
         DO 30 J = 1, NRHS
            B( I, J ) = ZERO
   30    CONTINUE
   40 CONTINUE
*
*     B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS)
*
      IF( RANK.LT.N ) THEN
         DO 50 I = 1, RANK
            CALL DLATZM( 'Left', N-RANK+1, NRHS, A( I, RANK+1 ), LDA,
     $                   WORK( MN+I ), B( I, 1 ), B( RANK+1, 1 ), LDB,
     $                   WORK( 2*MN+1 ) )
   50    CONTINUE
      END IF
*
*     workspace NRHS
*
*     B(1:N,1:NRHS) := P * B(1:N,1:NRHS)
*
      DO 90 J = 1, NRHS
         DO 60 I = 1, N
            WORK( 2*MN+I ) = NTDONE
   60    CONTINUE
         DO 80 I = 1, N
            IF( WORK( 2*MN+I ).EQ.NTDONE ) THEN
               IF( JPVT( I ).NE.I ) THEN
                  K = I
                  T1 = B( K, J )
                  T2 = B( JPVT( K ), J )
   70             CONTINUE
                  B( JPVT( K ), J ) = T1
                  WORK( 2*MN+K ) = DONE
                  T1 = T2
                  K = JPVT( K )
                  T2 = B( JPVT( K ), J )
                  IF( JPVT( K ).NE.I )
     $               GO TO 70
                  B( I, J ) = T1
                  WORK( 2*MN+K ) = DONE
               END IF
            END IF
   80    CONTINUE
   90 CONTINUE
*
*     Undo scaling
*
      IF( IASCL.EQ.1 ) THEN
         CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
         CALL DLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA,
     $                INFO )
      ELSE IF( IASCL.EQ.2 ) THEN
         CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
         CALL DLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA,
     $                INFO )
      END IF
      IF( IBSCL.EQ.1 ) THEN
         CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
      ELSE IF( IBSCL.EQ.2 ) THEN
         CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
      END IF
*
  100 CONTINUE
*
      RETURN
*
*     End of DGELSX
*
      END


*DECK CATAN
      COMPLEX FUNCTION CATAN (Z)
C***BEGIN PROLOGUE  CATAN
C***PURPOSE  Compute the complex arc tangent.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C4A
C***TYPE      COMPLEX (CATAN-C)
C***KEYWORDS  ARC TANGENT, ELEMENTARY FUNCTIONS, FNLIB, TRIGONOMETRIC
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C CATAN(Z) calculates the complex trigonometric arc tangent of Z.
C The result is in units of radians, and the real part is in the first
C or fourth quadrant.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770801  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C***END PROLOGUE  CATAN
      COMPLEX Z, Z2
      LOGICAL FIRST
      SAVE PI2, NTERMS, SQEPS, RMIN, RMAX, FIRST
      DATA PI2 / 1.5707963267 9489661923E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  CATAN
      IF (FIRST) THEN
C NTERMS = LOG(EPS)/LOG(RBND) WHERE RBND = 0.1
         NTERMS = -0.4343*LOG(R1MACH(3)) + 1.0
         SQEPS = SQRT(R1MACH(4))
         RMIN = SQRT (3.0*R1MACH(3))
         RMAX = 1.0/R1MACH(3)
      ENDIF
      FIRST = .FALSE.
C
      R = ABS(Z)
      IF (R.GT.0.1) GO TO 30
C
      CATAN = Z
      IF (R.LT.RMIN) RETURN
C
      CATAN = (0.0, 0.0)
      Z2 = Z*Z
      DO 20 I=1,NTERMS
        TWOI = 2*(NTERMS-I) + 1
        CATAN = 1.0/TWOI - Z2*CATAN
 20   CONTINUE
      CATAN = Z*CATAN
      RETURN
C
 30   IF (R.GT.RMAX) GO TO 50
      X = REAL(Z)
      Y = AIMAG(Z)
      R2 = R*R
      IF (R2 .EQ. 1.0 .AND. X .EQ. 0.0) CALL XERMSG ('SLATEC', 'CATAN',
     +   'Z IS +I OR -I', 2, 2)
      IF (ABS(R2-1.0).GT.SQEPS) GO TO 40
      IF (ABS(CMPLX(1.0, 0.0)+Z*Z) .LT. SQEPS) CALL XERMSG ('SLATEC',
     +   'CATAN', 'ANSWER LT HALF PRECISION, Z**2 CLOSE TO -1', 1, 1)
C
 40   XANS = 0.5*ATAN2(2.0*X, 1.0-R2)
      YANS = 0.25*LOG((R2+2.0*Y+1.0)/(R2-2.0*Y+1.0))
      CATAN = CMPLX (XANS, YANS)
      RETURN
C
 50   CATAN = CMPLX (PI2, 0.)
      IF (REAL(Z).LT.0.0) CATAN = CMPLX(-PI2,0.0)
      RETURN
C
      END


module auto_diff

    use ad_kinds, only: rk
    use ad_types, only: tree_t, assignment(=)
    use ad_operator, only: operator(+), operator(-), operator(*), operator(/), &
                           operator(**)
    use ad_intrinsic, only: abs, max, min, &
                            sin, cos, tan, &
                            exp, sqrt, log, log10
    use ad_usr_func, only: sigmoid
    implicit none

end module auto_diff


      FUNCTION ZBRENT(FUNC,X1,X2,TOL)
      PARAMETER (ITMAX=100,EPS=3.E-8)
      A=X1
      B=X2
      FA=FUNC(A)
      FB=FUNC(B)
      IF(FB*FA.GT.0.) PAUSE 'Root must be bracketed for ZBRENT.'
      FC=FB
      DO 11 ITER=1,ITMAX
        IF(FB*FC.GT.0.) THEN
          C=A
          FC=FA
          D=B-A
          E=D
        ENDIF
        IF(ABS(FC).LT.ABS(FB)) THEN
          A=B
          B=C
          C=A
          FA=FB
          FB=FC
          FC=FA
        ENDIF
        TOL1=2.*EPS*ABS(B)+0.5*TOL
        XM=.5*(C-B)
        IF(ABS(XM).LE.TOL1 .OR. FB.EQ.0.)THEN
          ZBRENT=B
          RETURN
        ENDIF
        IF(ABS(E).GE.TOL1 .AND. ABS(FA).GT.ABS(FB)) THEN
          S=FB/FA
          IF(A.EQ.C) THEN
            P=2.*XM*S
            Q=1.-S
          ELSE
            Q=FA/FC
            R=FB/FC
            P=S*(2.*XM*Q*(Q-R)-(B-A)*(R-1.))
            Q=(Q-1.)*(R-1.)*(S-1.)
          ENDIF
          IF(P.GT.0.) Q=-Q
          P=ABS(P)
          IF(2.*P .LT. MIN(3.*XM*Q-ABS(TOL1*Q),ABS(E*Q))) THEN
            E=D
            D=P/Q
          ELSE
            D=XM
            E=D
          ENDIF
        ELSE
          D=XM
          E=D
        ENDIF
        A=B
        FA=FB
        IF(ABS(D) .GT. TOL1) THEN
          B=B+D
        ELSE
          B=B+SIGN(TOL1,XM)
        ENDIF
        FB=FUNC(B)
11    CONTINUE
      PAUSE 'ZBRENT exceeding maximum iterations.'
      ZBRENT=B
      RETURN
      END


program main
  implicit none
  include 'mpif.h'
  integer i,ni,nj,ierr,mpisize,mpirank
  integer,dimension (128) :: iseed
  real(8),parameter :: pi=3.14159265358979312d0
  real(8) diff,norm
  real(8),allocatable,dimension(:) :: xi,ui,ud,xj,gj
  call mpi_init(ierr)
  call mpi_comm_size(mpi_comm_world,mpisize,ierr)
  call mpi_comm_rank(mpi_comm_world,mpirank,ierr)
  ni = 10000
  nj = 20000
  allocate( xi(3*ni),ui(3*ni),ud(3*ni),xj(3*nj),gj(3*nj) )
  do i = 1,128
     iseed(i) = mpirank
  enddo
  call random_seed(put=iseed)
  call random_number(xi)
  call random_number(xj)
  call random_number(gj)
  do i = 1,nj
     xj(3*i-2) = (xj(3*i-2) - 0.5) * pi
     xj(3*i-1) = (xj(3*i-1) - 0.5) * pi
     xj(3*i-0) = (xj(3*i-0) - 0.5) * pi
     gj(3*i-2) = (gj(3*i-2) - 0.5) / ni
     gj(3*i-1) = (gj(3*i-1) - 0.5) / ni
     gj(3*i-0) = (gj(3*i-0) - 0.5) / ni
  enddo
  do i = 1,ni
     xi(3*i-2) = (xi(3*i-2) - 0.5) * pi
     xi(3*i-1) = (xi(3*i-1) - 0.5) * pi
     xi(3*i-0) = (xi(3*i-0) - 0.5) * pi
     ui(3*i-2) = 0
     ui(3*i-1) = 0
     ui(3*i-0) = 0
     ud(3*i-2) = 0
     ud(3*i-1) = 0
     ud(3*i-0) = 0
  enddo
  call fmm_init()
  call fmm_partition(ni,xi,nj,xj,gj)
  call fmm_biot_savart(ni,xi,ui,nj,xj,gj)
  call direct_biot_savart(ni,xi,ud,nj,xj,gj)
  diff = 0
  norm = 0
  do i = 1,ni
     diff = diff + (ui(3*i-2) - ud(3*i-2)) ** 2
     diff = diff + (ui(3*i-1) - ud(3*i-1)) ** 2
     diff = diff + (ui(3*i-0) - ud(3*i-0)) ** 2
     norm = norm + ud(3*i-2) ** 2
     norm = norm + ud(3*i-1) ** 2
     norm = norm + ud(3*i-0) ** 2
  enddo
!  call mpi_allreduce(diff,diff,1,mpi_double_precision,mpi_sum,0,mpi_comm_world,ierr)
!  call mpi_allreduce(norm,norm,1,mpi_double_precision,mpi_sum,0,mpi_comm_world,ierr)
  print '(a,es12.5)',"error         :",sqrt(diff/norm)
  call mpi_finalize(ierr)
  call fmm_finalize()
  deallocate( xi,ui,ud,xj,gj )
end program main


! { dg-do run }
! { dg-options "-O" }
! Tests the fix for PR30400, in which the use of ANY in the
! FORALL mask was rejected.
!
! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr>
!
program pr30400_1
  real, dimension (5, 5, 5, 5) :: a

  a (:, :, :,  :)  = 4
  a (:, 2, :, 4) = 10
  a (:, 2, :, 1) = 0

  forall (i = 1:5, j = 1:5, k = 1:5, any (a (i, j, k,  :)  .gt. 6))
    forall (l = 1:5, any (a (:, :, :, l) .lt. 2))
      a (i, j, k, l) = i - j + k - l
    end forall
  end forall
  if (sum (a) .ne. 2625.0) call abort ()

 ! Check that the fix has not broken the treatment of the '=='
  forall (i = 1:5, i == 3) a(i, i, i, i) = -5
  if (sum (a) .ne. 2616.0) call abort ()
end


! Testcase for the COMPLEX intrinsic
! { dg-do run }
  if (complex(1_1, -1_2) /= complex(1.0_4, -1.0_8)) call abort
  if (complex(1_4, -1.0) /= complex(1.0_4, -1_8)) call abort
  end


! { dg-do run }
! { dg-options "-std=gnu" }
! Test that the BOZ constant on the RHS, which are of different KIND than
! the LHS, are correctly converted.
!
program boz

   implicit none

   integer(1), parameter :: b1 = b'000000000001111'
   integer(2), parameter :: b2 = b'00000000000000000111000011110000'
   integer(4), parameter :: &
   &  b4 = b'0000000000000000000000000000000001110000111100001111000011110000'

   integer(1), parameter :: o1 = o'0012'
   integer(2), parameter :: o2 = o'0004321'
   integer(4), parameter :: o4 = o'0000000043210765'

   integer(1), parameter :: z1 = z'0a'
   integer(2), parameter :: z2 = z'00ab'
   integer(4), parameter :: z4 = z'0000dead'

   if (b1 /= 15_1) call abort
   if (b2 /= 28912_2) call abort
   if (b4 /= 1894838512_4) call abort

   if (o1 /= 10_1) call abort
   if (o2 /= 2257_2) call abort
   if (o4 /= 9245173_4) call abort

   if (z1 /= 10_1) call abort
   if (z2 /= 171_2) call abort
   if (z4 /= 57005_4) call abort

end program boz


C File: array2d-slice-07.f
C Illustrates array slicing

      program main
      implicit none

      integer, dimension (5,5) :: A
      integer, dimension(3) :: K = (/ 1, 3, 5 /)
      integer :: i, j

      do i = 1, 5
          do j = 1, 5
              A(i,j) = 11*(i+j)
          end do
      end do

      do i = 1, 5
          write (*,10) A(i,1), A(i,2), A(i,3), A(i,4), A(i,5)
      end do
      write(*,11)

 10   format(5(I5,X))
 11   format('')

C      Modifying elements in the slice of A defined by K
       A(2, K ) = 999

      do i = 1, 5
          write (*,10) A(i,1), A(i,2), A(i,3), A(i,4), A(i,5)
      end do
      write(*,11)

C     Modifying K
      do i = 1, 3
          K(i) = (K(i)+3)/2
      end do

C      Modifying elements in the slice of A defined by K
       A(4, K ) = -1

      do i = 1, 5
          write (*,10) A(i,1), A(i,2), A(i,3), A(i,4), A(i,5)
      end do

      stop
      end program main


C     File: SADOURNY_x.f

C
C     DDY
C
      SUBROUTINE DDY(DF,F,DY,NX,NY)

      use omp_lib
      INTEGER :: NX, NY
      REAL*8, DIMENSION(NX, NY)   :: F
      REAL*8, DIMENSION(NX, NY-1) :: DF
      REAL*8 :: DY

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

C     LOOP INDEX
      INTEGER :: I,J

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

      END

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

      use omp_lib
      INTEGER :: NX, NY
      REAL*8, DIMENSION(NX, NY)   :: F
      REAL*8, DIMENSION(NX, NY-1) :: AF

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

C     LOOP INDEX
      INTEGER :: I,J

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

      END

C
C     DDY_PERIODIC
C
      SUBROUTINE DDY_PERIODIC(DF,F,DY,NX,NY)

      use omp_lib
      INTEGER :: NX, NY
      REAL*8, DIMENSION(NX, NY)   :: F
      REAL*8, DIMENSION(NX, NY+1) :: DF
      REAL*8 :: DY

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

C     LOOP INDEX
      INTEGER :: I,J

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

      END

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

      use omp_lib
      INTEGER :: NX, NY
      REAL*8, DIMENSION(NX, NY)   :: F
      REAL*8, DIMENSION(NX, NY+1) :: AF

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

C     LOOP INDEX
      INTEGER :: I,J

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

      END

C
C     DDY_WALLS
C
      SUBROUTINE DDY_WALLS(DF,F,DY,NX,NY)

      use omp_lib
      INTEGER :: NX, NY
      REAL*8, DIMENSION(NX, NY)   :: F
      REAL*8, DIMENSION(NX, NY+1) :: DF
      REAL*8 :: DY

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

C     LOOP INDEX
      INTEGER :: I,J

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

      END

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

      use omp_lib
      INTEGER :: NX, NY
      REAL*8, DIMENSION(NX, NY)   :: F
      REAL*8, DIMENSION(NX, NY+1) :: AF

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

C     LOOP INDEX
      INTEGER :: I,J

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

      END


      subroutine sphere_tag4refinement(mx,my,mbc,
     &      meqn, xlower,ylower,dx,dy,t, blockno,
     &      q, tag_threshold, init_flag,tag_patch)
      implicit none

      integer mx,my, mbc, meqn, tag_patch, init_flag
      integer blockno
      double precision xlower, ylower, dx, dy, t
      double precision tag_threshold
      double precision q(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)

      integer example
      common /example_comm/ example

      integer refine_pattern
      common /refine_comm/ refine_pattern

      integer initchoice
      common /initchoice_comm/ initchoice

      integer*8 cont, get_context

      integer i,j, mq
      double precision qmin, qmax, xc, yc, lap
      logical refine

      cont = get_context()

c     # Refine based only on first variable in system.
      refine = .false.
      mq = 1
      do j = 1,my
         do i = 1,mx
c            xc = xlower + (i-0.5)*dx
c            yc = ylower + (j-0.5)*dy
c            lap = (q(i+1,j,1) + q(i-1,j,1) + q(i,j+1,1) + q(i,j-1,1)
c     &            - 4*q(i,j,1))/dx**2
c            if (abs(lap) .gt. tag_threshold) then
c                  refine = .true.
c            endif
            if (init choice .le. 3) then
                refine = q(i,j,mq) .gt.  tag_threshold
            endif
            if (refine) then
                tag_patch = 1
                return
            endif
         enddo
      enddo

      end


      PROGRAM LA_CGESV_ET_EXAMPLE
!
!  -- LAPACK95 INTERFACE DRIVER ROUTINE (VERSION 3.0) --
!     UNI-C, DENMARK; UNIV. OF TENNESSEE, USA; NAG LTD., UK
!     SEPTEMBER, 2000
!
!  .. "Use Statements" ..
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_GESV
!  .. "Implicit Statement" ..
      IMPLICIT NONE
!  .. "Parameters" ..
      CHARACTER(LEN=*), PARAMETER :: FMT =                              &
     &                   '(4(1X,1H(,F7.3,1H,,F7.3,1H):))'
      INTEGER, PARAMETER :: NIN=5, NOUT=6
!  .. "Local Scalars" ..
      INTEGER :: I, J, INFO, N, NRHS
!  .. "Local Arrays" ..
      INTEGER, ALLOCATABLE :: IPIV(:)
      COMPLEX(WP), ALLOCATABLE :: A(:,:), AA(:,:), B(:,:), BB(:,:), DUMMY(:,:)
      REAL(WP), ALLOCATABLE :: RR(:,:)
!  .. "Executable Statements" ..
      WRITE (NOUT,*) 'CGESV ET_Example Program Results.'
      READ ( NIN, * )   ! SKIP HEADING IN DATA FILE
      READ ( NIN, * ) N, NRHS
      ALLOCATE( A(N,N), AA(N,N), B(N,NRHS), BB(N,NRHS), IPIV(N), RR(N,N) )
!
      DO I = 1, N; READ (NIN, *) (RR(I, J), J = 1, N); ENDDO
      AA=RR
      DO J = 1, NRHS; BB(:,J) = SUM( AA, DIM=2)*J; ENDDO
      WRITE(NOUT,*) 'The matrix A:'
      DO I = 1, N; WRITE (NOUT,FMT) AA(I,:); ENDDO
      WRITE(NOUT,*) 'The RHS matrix B:'
      DO J = 1, NRHS; WRITE (NOUT,FMT) BB(:,J);
      ENDDO
!
      WRITE ( NOUT, * )'-----------------------------------------------'
      WRITE ( NOUT, * )
      WRITE ( NOUT, * )'Details of LA_CGESV LAPACK Subroutine Results.'
      WRITE ( NOUT, * )
!
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_GESV( A, B, IPIV, INFO )'
      A=AA; B=BB
      CALL LA_GESV(  A, B, IPIV, INFO )
      WRITE(NOUT,*) 'B - the solution vectors computed by LA_GESV,',    &
     &              ' INFO = ', INFO
      DO J = 1, NRHS; WRITE (NOUT,FMT) B(:,J); END DO
      WRITE(NOUT,*) 'Pivot vector'
      WRITE(NOUT,*) IPIV
!
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_GESV( A, B(:,1), IPIV, INFO )'
      A=AA; B=BB
      CALL LA_GESV(  A, B(:,1), IPIV, INFO )
      WRITE(NOUT,*) 'B - the solution vector computed by LA_GESV,',     &
     &              ' INFO = ', INFO
      WRITE (NOUT,FMT) B(:,1)
      WRITE(NOUT,*) 'Pivot vector'
      WRITE(NOUT,*) IPIV
!
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_GESV( A, B, INFO=INFO )'
      A=AA; B=BB
      CALL LA_GESV(  A, B, INFO=INFO )
      WRITE(NOUT,*) 'B - the solution vector computed by LA_GESV,',     &
     &              ' INFO = ', INFO
      DO J = 1, NRHS; WRITE (NOUT,FMT) B(:,J); END DO
!
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_GESV( A, B(:,1), INFO=INFO )'
      A=AA; B=BB
      CALL LA_GESV(  A, B(:,1), INFO=INFO )
      WRITE(NOUT,*) 'B - the solution vector computed by LA_GESV,',     &
     &              ' INFO = ', INFO
      WRITE (NOUT,FMT) B(:,1)
!
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_GESV( DUMMY, B, INFO=INFO )'
      A=AA; B=BB
      CALL LA_GESV(  DUMMY, B, INFO=INFO )
      WRITE(NOUT,*) 'INFO = ', INFO
!
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_GESV( DUMMY, B(:,1), INFO=INFO )'
      A=AA; B=BB
      CALL LA_GESV(  DUMMY, B(:,1), INFO=INFO )
      WRITE(NOUT,*) 'INFO = ', INFO
!
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_GESV( A, B(1:N-1,:), INFO=INFO )'
      A=AA; B=BB
      CALL LA_GESV(  A, B(1:N-1,:), INFO=INFO )
      WRITE(NOUT,*) 'INFO = ', INFO
!
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_GESV( A, B(1:N-1,1), INFO=INFO )'
      A=AA; B=BB
      CALL LA_GESV(  A, B(1:N-1,1), INFO=INFO )
      WRITE(NOUT,*) 'INFO = ', INFO
!
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_GESV( A, B, IPIV(1:N-1), INFO=INFO )'
      A=AA; B=BB
      CALL LA_GESV(  A, B, IPIV(1:N-1), INFO=INFO )
      WRITE(NOUT,*) 'INFO = ', INFO
!
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_GESV( A, B(:,1), IPIV(1:N-1) )'
      A=AA; B=BB
      CALL LA_GESV(  A, B(:,1), IPIV(1:N-1) )
      WRITE(NOUT,*) 'INFO = ', INFO
!
      END PROGRAM LA_CGESV_ET_EXAMPLE