! ##################################################################################################################################

      MODULE LAPACK_STD_EIG_1

      USE PENTIUM_II_KIND, ONLY          :  BYTE, LONG, DOUBLE
      USE IOUNT1, ONLY                   :  ERR, F04, F06, WRT_LOG
      USE SCONTR, ONLY                   :  LINKNO, BLNK_SUB_NAM
      USE TIMDAT, ONLY                   :  HOUR, MINUTE, SEC,
     &                                      SFRAC, STIME, TSEC
      USE SUBR_BEGEND_LEVELS, ONLY       :  LAPACK_BEGEND
      USE LAPACK_BLAS_AUX
      USE LAPACK_MISCEL                                    ! This contains DSTEQR, used in this module

      USE OURTIM_Interface
      USE OUTA_HERE_Interface

      CHARACTER(44*BYTE), PRIVATE       :: MODNAM          ! Name to write to screen to describe module being run.

      INTEGER(LONG), PARAMETER, PRIVATE :: SUBR_BEGEND =LAPACK_BEGEND+10

! This is a set of LAPACK routines for solving for all of the eigenvalues
! and, possibly, all eigenvectors of:

!                             Ax = (Lambda)x             (1)

! where A is real and symmetric.

! This module contains LAPACK subroutines described below:

!        DSYEV : Main driver for solving (1) for eigenvalues and eigenvectors

! DSYEV calls the LAPACK subroutines included herein and described below to do the main computations.

!        DSYTRD: To reduce A to tridiagonal form, and
!        DSTERF: To calc eigenvalues if NO eigenvectors are sought, or
!                NOTE: DSTEQR is not in this module, it is in module LAPACK_MISCEL, since it is used in several modules
!        DORGTR: To generate orthogonal matrices

! DSYEV also uses

!        DSTEQR: to compute all eigenvalues and all eigenvectors of the tridiagonal matrix (if eigenvectors are requested).
!                NOTE: DSTEQR is not in this module, it is in module LAPACK_MISCEL, since it is used in several other modules

! In addition, other LAPACK procedures are called from module LAPACK_BLAS_AUX_1

      CONTAINS

! ##################################################################################################################################
! 001 LAPACK_STD_EIG_1

      SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DSYEV'
*
*  -- LAPACK driver routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*     .. Scalar Arguments ..
      CHARACTER          JOBZ, UPLO
      INTEGER            INFO, LDA, LWORK, N
*     ..
*     .. Array Arguments ..
      REAL(DOUBLE)   A( LDA, * ), W( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DSYEV computes all eigenvalues and, optionally, eigenvectors of a
*  real symmetric matrix A.
*
*  Arguments
*  =========
*
*  JOBZ    (input) CHARACTER*1
*          = 'N':  Compute eigenvalues only;
*          = 'V':  Compute eigenvalues and eigenvectors.
*
*  UPLO    (input) CHARACTER*1
*          = 'U':  Upper triangle of A is stored;
*          = 'L':  Lower triangle of A is stored.
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  A       (input/output) REAL(DOUBLE) array, dimension (LDA, N)
*          On entry, the symmetric matrix A.  If UPLO = 'U', the
*          leading N-by-N upper triangular part of A contains the
*          upper triangular part of the matrix A.  If UPLO = 'L',
*          the leading N-by-N lower triangular part of A contains
*          the lower triangular part of the matrix A.
*          On exit, if JOBZ = 'V', then if INFO = 0, A contains the
*          orthonormal eigenvectors of the matrix A.
*          If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
*          or the upper triangle (if UPLO='U') of A, including the
*          diagonal, is destroyed.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  W       (output) REAL(DOUBLE) array, dimension (N)
*          If INFO = 0, the eigenvalues in ascending order.
*
*  WORK    (workspace/output) REAL(DOUBLE) array, dimension (LWORK)
*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
*  LWORK   (input) INTEGER
*          The length of the array WORK.  LWORK >= max(1,3*N-1).
*          For optimal efficiency, LWORK >= (NB+2)*N,
*          where NB is the blocksize for DSYTRD returned by ILAENV.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*          > 0:  if INFO = i, the algorithm failed to converge; i
*                off-diagonal elements of an intermediate tridiagonal
*                form did not converge to zero.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL(DOUBLE)   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LOWER, WANTZ
      INTEGER            IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE,
     $                   LLWORK, LOPT
      REAL(DOUBLE)   ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
     $                   SMLNUM
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME

      INTEGER            ILAENV
      EXTERNAL           ILAENV

      REAL(DOUBLE)       DLAMCH
      EXTERNAL           DLAMCH
*     ..
*     .. External Subroutines ..
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, SQRT
*     ..
*     .. Executable Statements ..

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
*
*     Test the input parameters.
*
      WANTZ = LSAME( JOBZ, 'V' )
      LOWER = LSAME( UPLO, 'L' )
*
      INFO = 0
      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LWORK.LT.MAX( 1, 3*N-1 ) ) THEN
         INFO = -8
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSYEV ', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
*
      IF( N.EQ.1 ) THEN
         W( 1 ) = A( 1, 1 )
         WORK( 1 ) = 3
         IF( WANTZ )
     $      A( 1, 1 ) = ONE
         RETURN
      END IF
*
*     Get machine constants.
*
      SAFMIN = DLAMCH( 'Safe minimum' )
      EPS = DLAMCH( 'Precision' )
      SMLNUM = SAFMIN / EPS
      BIGNUM = ONE / SMLNUM
      RMIN = SQRT( SMLNUM )
      RMAX = SQRT( BIGNUM )
*
*     Scale matrix to allowable range, if necessary.
*
      ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK )
      ISCALE = 0
      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
         ISCALE = 1
         SIGMA = RMIN / ANRM
      ELSE IF( ANRM.GT.RMAX ) THEN
         ISCALE = 1
         SIGMA = RMAX / ANRM
      END IF
      IF( ISCALE.EQ.1 )
     $   CALL DLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO )
*
*     Call DSYTRD to reduce symmetric matrix to tridiagonal form.
*
      INDE = 1
      INDTAU = INDE + N
      INDWRK = INDTAU + N
      LLWORK = LWORK - INDWRK + 1
      CALL DSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ),
     $             WORK( INDWRK ), LLWORK, IINFO )
      LOPT = 2*N + WORK( INDWRK )
*
*     For eigenvalues only, call DSTERF.  For eigenvectors, first call
*     DORGTR to generate the orthogonal matrix, then call DSTEQR.
*
      IF( .NOT.WANTZ ) THEN
         CALL DSTERF( N, W, WORK( INDE ), INFO )
      ELSE
         CALL DORGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ),
     $                LLWORK, IINFO )
         CALL DSTEQR( JOBZ, N, W, WORK( INDE ), A, LDA, WORK( INDTAU ),
     $                INFO )
      END IF
*
*     If matrix was scaled, then rescale eigenvalues appropriately.
*
      IF( ISCALE.EQ.1 ) THEN
         IF( INFO.EQ.0 ) THEN
            IMAX = N
         ELSE
            IMAX = INFO - 1
         END IF
         CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
      END IF
*
*     Set WORK(1) to optimal workspace size.
*
      WORK( 1 ) = MAX( 3*N-1, LOPT )
*

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

! **********************************************************************************************************************************
      RETURN
*
*     End of DSYEV
*
      END SUBROUTINE DSYEV

! ##################################################################################################################################
! 002 LAPACK_STD_EIG_1

      SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DSYTRD'
*
*  -- LAPACK routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, LWORK, N
*     ..
*     .. Array Arguments ..
      REAL(DOUBLE)   A( LDA, * ), D( * ), E( * ), TAU( * ),
     $                   WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DSYTRD reduces a real symmetric matrix A to real symmetric
*  tridiagonal form T by an orthogonal similarity transformation:
*  Q**T * A * Q = T.
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          = 'U':  Upper triangle of A is stored;
*          = 'L':  Lower triangle of A is stored.
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  A       (input/output) REAL(DOUBLE) array, dimension (LDA,N)
*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
*          N-by-N upper triangular part of A contains the upper
*          triangular part of the matrix A, and the strictly lower
*          triangular part of A is not referenced.  If UPLO = 'L', the
*          leading N-by-N lower triangular part of A contains the lower
*          triangular part of the matrix A, and the strictly upper
*          triangular part of A is not referenced.
*          On exit, if UPLO = 'U', the diagonal and first superdiagonal
*          of A are overwritten by the corresponding elements of the
*          tridiagonal matrix T, and the elements above the first
*          superdiagonal, with the array TAU, represent the orthogonal
*          matrix Q as a product of elementary reflectors; if UPLO
*          = 'L', the diagonal and first subdiagonal of A are over-
*          written by the corresponding elements of the tridiagonal
*          matrix T, and the elements below the first subdiagonal, with
*          the array TAU, represent the orthogonal matrix Q as a product
*          of elementary reflectors. See Further Details.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  D       (output) REAL(DOUBLE) array, dimension (N)
*          The diagonal elements of the tridiagonal matrix T:
*          D(i) = A(i,i).
*
*  E       (output) REAL(DOUBLE) array, dimension (N-1)
*          The off-diagonal elements of the tridiagonal matrix T:
*          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
*
*  TAU     (output) REAL(DOUBLE) array, dimension (N-1)
*          The scalar factors of the elementary reflectors (see Further
*          Details).
*
*  WORK    (workspace/output) REAL(DOUBLE) array, dimension (LWORK)
*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
*  LWORK   (input) INTEGER
*          The dimension of the array WORK.  LWORK >= 1.
*          For optimum performance LWORK >= N*NB, where NB is the
*          optimal blocksize.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*
*  Further Details
*  ===============
*
*  If UPLO = 'U', the matrix Q is represented as a product of elementary
*  reflectors
*
*     Q = H(n-1) . . . H(2) H(1).
*
*  Each H(i) has the form
*
*     H(i) = I - tau * v * v'
*
*  where tau is a real scalar, and v is a real vector with
*  v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
*  A(1:i-1,i+1), and tau in TAU(i).
*
*  If UPLO = 'L', the matrix Q is represented as a product of elementary
*  reflectors
*
*     Q = H(1) H(2) . . . H(n-1).
*
*  Each H(i) has the form
*
*     H(i) = I - tau * v * v'
*
*  where tau is a real scalar, and v is a real vector with
*  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
*  and tau in TAU(i).
*
*  The contents of A on exit are illustrated by the following examples
*  with n = 5:
*
*  if UPLO = 'U':                       if UPLO = 'L':
*
*    (  d   e   v2  v3  v4 )              (  d                  )
*    (      d   e   v3  v4 )              (  e   d              )
*    (          d   e   v4 )              (  v1  e   d          )
*    (              d   e  )              (  v1  v2  e   d      )
*    (                  d  )              (  v1  v2  v3  e   d  )
*
*  where d and e denote diagonal and off-diagonal elements of T, and vi
*  denotes an element of the vector defining H(i).
*
*  =====================================================================
*
*     .. Parameters ..
      REAL(DOUBLE)   ONE
      PARAMETER          ( ONE = 1.0D0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I, IINFO, IWS, J, KK, LDWORK, NB, NBMIN, NX
*     ..
*     .. External Subroutines ..
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME

      INTEGER            ILAENV
      EXTERNAL           ILAENV
*     ..
*     .. Executable Statements ..

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND+1) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
*
*     Test the input parameters
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( LWORK.LT.1 ) THEN
         INFO = -9
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSYTRD', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
*
*     Determine the block size.
*
      NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
      NX = N
      IWS = 1
      IF( NB.GT.1 .AND. NB.LT.N ) THEN
*
*        Determine when to cross over from blocked to unblocked code
*        (last block is always handled by unblocked code).
*
         NX = MAX( NB, ILAENV( 3, 'DSYTRD', UPLO, N, -1, -1, -1 ) )
         IF( NX.LT.N ) THEN
*
*           Determine if workspace is large enough for blocked code.
*
            LDWORK = N
            IWS = LDWORK*NB
            IF( LWORK.LT.IWS ) THEN
*
*              Not enough workspace to use optimal NB:  determine the
*              minimum value of NB, and reduce NB or force use of
*              unblocked code by setting NX = N.
*
               NB = MAX( LWORK / LDWORK, 1 )
               NBMIN = ILAENV( 2, 'DSYTRD', UPLO, N, -1, -1, -1 )
               IF( NB.LT.NBMIN )
     $            NX = N
            END IF
         ELSE
            NX = N
         END IF
      ELSE
         NB = 1
      END IF
*
      IF( UPPER ) THEN
*
*        Reduce the upper triangle of A.
*        Columns 1:kk are handled by the unblocked method.
*
         KK = N - ( ( N-NX+NB-1 ) / NB )*NB
         DO 20 I = N - NB + 1, KK + 1, -NB
*
*           Reduce columns i:i+nb-1 to tridiagonal form and form the
*           matrix W which is needed to update the unreduced part of
*           the matrix
*
            CALL DLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK,
     $                   LDWORK )
*
*           Update the unreduced submatrix A(1:i-1,1:i-1), using an
*           update of the form:  A := A - V*W' - W*V'
*
            CALL DSYR2K( UPLO, 'No transpose', I-1, NB, -ONE, A( 1, I ),
     $                   LDA, WORK, LDWORK, ONE, A, LDA )
*
*           Copy superdiagonal elements back into A, and diagonal
*           elements into D
*
            DO 10 J = I, I + NB - 1
               A( J-1, J ) = E( J-1 )
               D( J ) = A( J, J )
   10       CONTINUE
   20    CONTINUE
*
*        Use unblocked code to reduce the last or only block
*
         CALL DSYTD2( UPLO, KK, A, LDA, D, E, TAU, IINFO )
      ELSE
*
*        Reduce the lower triangle of A
*
         DO 40 I = 1, N - NX, NB
*
*           Reduce columns i:i+nb-1 to tridiagonal form and form the
*           matrix W which is needed to update the unreduced part of
*           the matrix
*
            CALL DLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ),
     $                   TAU( I ), WORK, LDWORK )
*
*           Update the unreduced submatrix A(i+ib:n,i+ib:n), using
*           an update of the form:  A := A - V*W' - W*V'
*
            CALL DSYR2K( UPLO, 'No transpose', N-I-NB+1, NB, -ONE,
     $                   A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE,
     $                   A( I+NB, I+NB ), LDA )
*
*           Copy subdiagonal elements back into A, and diagonal
*           elements into D
*
            DO 30 J = I, I + NB - 1
               A( J+1, J ) = E( J )
               D( J ) = A( J, J )
   30       CONTINUE
   40    CONTINUE
*
*        Use unblocked code to reduce the last or only block
*
         CALL DSYTD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ),
     $                TAU( I ), IINFO )
      END IF
*
      WORK( 1 ) = IWS

! **********************************************************************************************************************************
 9000 IF (WRT_LOG >= SUBR_BEGEND+1) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

! **********************************************************************************************************************************
      RETURN
*
*     End of DSYTRD
*
      END SUBROUTINE DSYTRD

! ##################################################################################################################################
! 003 LAPACK_STD_EIG_1

      SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DORGTR'
*
*  -- LAPACK routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, LWORK, N
*     ..
*     .. Array Arguments ..
      REAL(DOUBLE)   A( LDA, * ), TAU( * ), WORK( LWORK )
*     ..
*
*  Purpose
*  =======
*
*  DORGTR generates a real orthogonal matrix Q which is defined as the
*  product of n-1 elementary reflectors of order N, as returned by
*  DSYTRD:
*
*  if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
*
*  if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          = 'U': Upper triangle of A contains elementary reflectors
*                 from DSYTRD;
*          = 'L': Lower triangle of A contains elementary reflectors
*                 from DSYTRD.
*
*  N       (input) INTEGER
*          The order of the matrix Q. N >= 0.
*
*  A       (input/output) REAL(DOUBLE) array, dimension (LDA,N)
*          On entry, the vectors which define the elementary reflectors,
*          as returned by DSYTRD.
*          On exit, the N-by-N orthogonal matrix Q.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A. LDA >= max(1,N).
*
*  TAU     (input) REAL(DOUBLE) array, dimension (N-1)
*          TAU(i) must contain the scalar factor of the elementary
*          reflector H(i), as returned by DSYTRD.
*
*  WORK    (workspace/output) REAL(DOUBLE) array, dimension (LWORK)
*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
*  LWORK   (input) INTEGER
*          The dimension of the array WORK. LWORK >= max(1,N-1).
*          For optimum performance LWORK >= (N-1)*NB, where NB is
*          the optimal blocksize.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*
*  =====================================================================
*
*     .. Parameters ..
      REAL(DOUBLE)   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I, IINFO, J
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND+1) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
*
*     Test the input arguments
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( LWORK.LT.MAX( 1, N-1 ) ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DORGTR', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
*
      IF( UPPER ) THEN
*
*        Q was determined by a call to DSYTRD with UPLO = 'U'
*
*        Shift the vectors which define the elementary reflectors one
*        column to the left, and set the last row and column of Q to
*        those of the unit matrix
*
         DO 20 J = 1, N - 1
            DO 10 I = 1, J - 1
               A( I, J ) = A( I, J+1 )
   10       CONTINUE
            A( N, J ) = ZERO
   20    CONTINUE
         DO 30 I = 1, N - 1
            A( I, N ) = ZERO
   30    CONTINUE
         A( N, N ) = ONE
*
*        Generate Q(1:n-1,1:n-1)
*
         CALL DORGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO )
*
      ELSE
*
*        Q was determined by a call to DSYTRD with UPLO = 'L'.
*
*        Shift the vectors which define the elementary reflectors one
*        column to the right, and set the first row and column of Q to
*        those of the unit matrix
*
         DO 50 J = N, 2, -1
            A( 1, J ) = ZERO
            DO 40 I = J + 1, N
               A( I, J ) = A( I, J-1 )
   40       CONTINUE
   50    CONTINUE
         A( 1, 1 ) = ONE
         DO 60 I = 2, N
            A( I, 1 ) = ZERO
   60    CONTINUE
         IF( N.GT.1 ) THEN
*
*           Generate Q(2:n,2:n)
*
            CALL DORGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
     $                   LWORK, IINFO )
         END IF
      END IF

! **********************************************************************************************************************************
 9000 IF (WRT_LOG >= SUBR_BEGEND+1) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

! **********************************************************************************************************************************
      RETURN
*
*     End of DORGTR
*
      END SUBROUTINE DORGTR

      END MODULE LAPACK_STD_EIG_1


      SUBROUTINE pgain( t, b, dt, nsamps, stime, etime, timmax, alpha )
c    Computes and applies a unique gain correction designed by M.W. Lee
c  of the U.S.G.S. Branch of Petroleum Geology, Denver (303)-236-5753
c     The gain = (time*1000.)**alpha
c   modified by pch to use stime in the calculation of the gain.
c   (it previously assumed both the gain function and the first sample
c   started at time zero, but then only applied the gain from stime
c   to etime)
c
      DIMENSION t(1), b(1)
      LOGICAL virgin
      SAVE virgin
      DATA virgin/.TRUE./
c  t : trace buffer nsamps long
c  b : scratch buffer
c  dt : sample interval in msec
c  nsamps : number of samples
c  stime : start time of trace in msec
c  etime : ending time to apply gain function
c  timmax : maximum time expected in msec
c  alpha : exponent to the time
c
      IF( virgin ) THEN
          virgin = .FALSE.
          jsamp = IFIX(timmax / dt) + 1
          isamp = IFIX(etime / dt) + 1
          DO 100 k = 1, isamp
             time = stime + (k-1) * dt
             b(k) = time ** alpha
  100     CONTINUE
          IF( isamp .LT. jsamp ) THEN
              DO 110 k = isamp + 1, jsamp
  110         b(k) = b(isamp)
          ENDIF
      ENDIF
c
c Apply gain function to the trace
c
      DO 200 k = 1, nsamps
  200 t(k) = t(k) * b( k)
      RETURN
      END


module mod_rk
  use mod_debug, only: chk_mean
  use mod_mom  , only: momx_a,momy_a,momz_a, &
                       momx_d,momy_d,momz_d, &
                       momx_p,momy_p,momz_p, cmpt_wallshear
#if defined(_IMPDIFF_1D)
  use mod_mom  , only: momx_d_xy,momy_d_xy,momz_d_xy, &
                       momx_d_z ,momy_d_z ,momz_d_z
#endif
  use mod_scal , only: scal
  use mod_types
  implicit none
  private
  public rk
  contains
  subroutine rk(rkpar,n,dli,l,dzci,dzfi,visc,dt,p,is_bound,is_forced,velf,bforce, &
                dudtrko,dvdtrko,dwdtrko,tauxo,tauyo,tauzo,u,v,w,f)
    !
    ! low-storage 3rd-order Runge-Kutta scheme
    ! for time integration of the momentum equations.
    !
    implicit none
    real(rp), intent(in), dimension(2) :: rkpar
    integer , intent(in), dimension(3) :: n
    real(rp), intent(in) :: visc,dt
    real(rp), intent(in   ), dimension(3) :: dli,l
    real(rp), intent(in   ), dimension(0:) :: dzci,dzfi
    real(rp), intent(in   ), dimension(0:,0:,0:) :: p
    logical , intent(in   ), dimension(0:1,3)    :: is_bound
    logical , intent(in   ), dimension(3)        :: is_forced
    real(rp), intent(in   ), dimension(3)        :: velf,bforce
    real(rp), intent(inout), dimension(:,:,:) :: dudtrko,dvdtrko,dwdtrko
    real(rp), intent(inout), dimension(3) :: tauxo,tauyo,tauzo
    real(rp), intent(inout), dimension(0:,0:,0:) :: u,v,w
    real(rp), intent(out), dimension(3) :: f
    real(rp),              dimension(n(1),n(2),n(3)) :: dudtrk ,dvdtrk ,dwdtrk
#if defined(_IMPDIFF)
    real(rp),              dimension(n(1),n(2),n(3)) :: dudtrkd,dvdtrkd,dwdtrkd
#endif
    real(rp) :: factor1,factor2,factor12
    real(rp), dimension(3) :: taux,tauy,tauz
    integer :: i,j,k
    real(rp) :: mean,grid_vol_ratio(0:n(3)+1)
    !
    factor1 = rkpar(1)*dt
    factor2 = rkpar(2)*dt
    factor12 = factor1 + factor2
    !
    ! compute mean wall shear stresses
    !
    call cmpt_wallshear(n,is_bound,l,dli,dzci,dzfi,visc,u,v,w,taux,tauy,tauz)
#if !defined(_IMPDIFF)
    f(1) = (factor1*sum(taux(:)/l(:)) + factor2*sum(tauxo(:)/l(:)))
    f(2) = (factor1*sum(tauy(:)/l(:)) + factor2*sum(tauyo(:)/l(:)))
    f(3) = (factor1*sum(tauz(:)/l(:)) + factor2*sum(tauzo(:)/l(:)))
    tauxo(:) = taux(:)
    tauyo(:) = tauy(:)
    tauzo(:) = tauz(:)
#else
    f(:) = factor12*[sum(taux(:)/l(:)), &
                     sum(tauy(:)/l(:)), &
                     sum(tauz(:)/l(:))]
#endif
    !
    !$OMP WORKSHARE
    dudtrk(:,:,:) = 0._rp
    dvdtrk(:,:,:) = 0._rp
    dwdtrk(:,:,:) = 0._rp
    !$OMP END WORKSHARE
#if !defined(_IMPDIFF)
    call momx_d(n(1),n(2),n(3),dli(1),dli(2),dzci,dzfi,visc,u,dudtrk)
    call momy_d(n(1),n(2),n(3),dli(1),dli(2),dzci,dzfi,visc,v,dvdtrk)
    call momz_d(n(1),n(2),n(3),dli(1),dli(2),dzci,dzfi,visc,w,dwdtrk)
#else
    !$OMP WORKSHARE
    dudtrkd(:,:,:) = 0._rp
    dvdtrkd(:,:,:) = 0._rp
    dwdtrkd(:,:,:) = 0._rp
    !$OMP END WORKSHARE
#if !defined(_IMPDIFF_1D)
    call momx_d(n(1),n(2),n(3),dli(1),dli(2),dzci,dzfi,visc,u,dudtrkd)
    call momy_d(n(1),n(2),n(3),dli(1),dli(2),dzci,dzfi,visc,v,dvdtrkd)
    call momz_d(n(1),n(2),n(3),dli(1),dli(2),dzci,dzfi,visc,w,dwdtrkd)
#else
    call momx_d_xy(n(1),n(2),n(3),dli(1),dli(2),visc,u,dudtrk )
    call momy_d_xy(n(1),n(2),n(3),dli(1),dli(2),visc,v,dvdtrk )
    call momz_d_xy(n(1),n(2),n(3),dli(1),dli(2),visc,w,dwdtrk )
    call momx_d_z( n(1),n(2),n(3),dzci  ,dzfi  ,visc,u,dudtrkd)
    call momy_d_z( n(1),n(2),n(3),dzci  ,dzfi  ,visc,v,dvdtrkd)
    call momz_d_z( n(1),n(2),n(3),dzci  ,dzfi  ,visc,w,dwdtrkd)
#endif
#endif
    call momx_a(n(1),n(2),n(3),dli(1),dli(2),dzci,dzfi,u,v,w,dudtrk)
    call momy_a(n(1),n(2),n(3),dli(1),dli(2),dzci,dzfi,u,v,w,dvdtrk)
    call momz_a(n(1),n(2),n(3),dli(1),dli(2),dzci,dzfi,u,v,w,dwdtrk)
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
#if defined(_IMPDIFF)
    !$OMP SHARED(factor12,dudtrkd,dvdtrkd,dwdtrkd) &
#endif
    !$OMP SHARED(n,factor1,factor2,u,v,w,dudtrk,dvdtrk,dwdtrk,dudtrko,dvdtrko,dwdtrko)
    do k=1,n(3)
      do j=1,n(2)
        do i=1,n(1)
          u(i,j,k) = u(i,j,k) + factor1*dudtrk(i,j,k) + factor2*dudtrko(i,j,k)
          v(i,j,k) = v(i,j,k) + factor1*dvdtrk(i,j,k) + factor2*dvdtrko(i,j,k)
          w(i,j,k) = w(i,j,k) + factor1*dwdtrk(i,j,k) + factor2*dwdtrko(i,j,k)
#if defined(_IMPDIFF)
          u(i,j,k) = u(i,j,k) + factor12*dudtrkd(i,j,k)
          v(i,j,k) = v(i,j,k) + factor12*dvdtrkd(i,j,k)
          w(i,j,k) = w(i,j,k) + factor12*dwdtrkd(i,j,k)
#endif
          dudtrko(i,j,k) = dudtrk(i,j,k)
          dvdtrko(i,j,k) = dvdtrk(i,j,k)
          dwdtrko(i,j,k) = dwdtrk(i,j,k)
        end do
      end do
    end do
    !$OMP END PARALLEL DO
!#if 0 /*pressure gradient term treated explicitly later */
!    !$OMP WORKSHARE
!    dudtrk(:,:,:) = 0._rp
!    dvdtrk(:,:,:) = 0._rp
!    dwdtrk(:,:,:) = 0._rp
!    !$OMP END WORKSHARE
!    call momx_p(n(1),n(2),n(3),dli(1),bforce(1),p,dudtrk)
!    call momy_p(n(1),n(2),n(3),dli(2),bforce(2),p,dvdtrk)
!    call momz_p(n(1),n(2),n(3),dzci  ,bforce(3),p,dwdtrk)
!    !$OMP PARALLEL DO DEFAULT(none) &
!    !$OMP PRIVATE(i,j,k) &
!    !$OMP SHARED(n,factor12,u,v,w,dudtrk,dvdtrk,dwdtrk)
!    do k=1,n(3)
!      do j=1,n(2)
!        do i=1,n(1)
!          u(i,j,k) = u(i,j,k) + factor12*dudtrk(i,j,k)
!          v(i,j,k) = v(i,j,k) + factor12*dvdtrk(i,j,k)
!          w(i,j,k) = w(i,j,k) + factor12*dwdtrk(i,j,k)
!        end do
!      end do
!    end do
!    !$OMP END PARALLEL DO
!#endif
    ! pressure gradient term in the loop below
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP SHARED(n,factor12,dli,dzci,bforce,u,v,w,p)
    do k=1,n(3)
      do j=1,n(2)
        do i=1,n(1)
          u(i,j,k) = u(i,j,k) + factor12*(bforce(1) - dli(1)*( p(i+1,j,k)-p(i,j,k)))
          v(i,j,k) = v(i,j,k) + factor12*(bforce(2) - dli(2)*( p(i,j+1,k)-p(i,j,k)))
          w(i,j,k) = w(i,j,k) + factor12*(bforce(3) - dzci(k)*(p(i,j,k+1)-p(i,j,k)))
        end do
      end do
    end do
    !$OMP END PARALLEL DO
    !
    ! bulk velocity forcing
    !
    f(:) = 0.
    if(is_forced(1)) then
      grid_vol_ratio(:) = 1./(dzfi(:)*dli(1)*dli(2)*l(1)*l(2)*l(3))
      call chk_mean(n,grid_vol_ratio,u,mean)
      f(1) = velf(1) - mean
    end if
    if(is_forced(2)) then
      grid_vol_ratio(:) = 1./(dzfi(:)*dli(1)*dli(2)*l(1)*l(2)*l(3))
      call chk_mean(n,grid_vol_ratio,v,mean)
      f(2) = velf(2) - mean
    end if
    if(is_forced(3)) then
      grid_vol_ratio(:) = 1./(dzci(:)*dli(1)*dli(2)*l(1)*l(2)*l(3))
      call chk_mean(n,grid_vol_ratio,w,mean)
      f(3) = velf(3) - mean
    end if
#if defined(_IMPDIFF)
    !
    ! compute rhs of helmholtz equation
    !
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP SHARED(n,factor12,u,v,w,dudtrkd,dvdtrkd,dwdtrkd)
    do k=1,n(3)
      do j=1,n(2)
        do i=1,n(1)
          u(i,j,k) = u(i,j,k) - .5_rp*factor12*dudtrkd(i,j,k)
          v(i,j,k) = v(i,j,k) - .5_rp*factor12*dvdtrkd(i,j,k)
          w(i,j,k) = w(i,j,k) - .5_rp*factor12*dwdtrkd(i,j,k)
        end do
      end do
    end do
    !$OMP END PARALLEL DO
#endif
  end subroutine rk
  subroutine rk_scal(rkpar,n,dli,dzci,dzfi,visc,dt,u,v,w,dsdtrko,s)
    !
    ! low-storage 3rd-order Runge-Kutta scheme
    ! for time integration of the scalar field.
    !
    implicit none
    real(rp), intent(in   ), dimension(2) :: rkpar
    integer , intent(in   ), dimension(3) :: n
    real(rp), intent(in   ), dimension(3) :: dli
    real(rp), intent(in   ), dimension(0:) :: dzci,dzfi
    real(rp), intent(in   ) :: visc,dt
    real(rp), intent(in   ), dimension(0:,0:,0:) :: u,v,w
    real(rp), intent(inout), dimension(:,:,:) :: dsdtrko
    real(rp), intent(inout), dimension(0:,0:,0:) :: s
    real(rp),              dimension(n(1),n(2),n(3)) :: dsdtrk
    real(rp) :: factor1,factor2,factor12
    integer :: i,j,k
    !
    factor1 = rkpar(1)*dt
    factor2 = rkpar(2)*dt
    factor12 = factor1 + factor2
    call scal(n(1),n(2),n(3),dli(1),dli(2),dli(3),dzci,dzfi,visc,u,v,w,s,dsdtrk)
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP SHARED(n,factor1,factor2,s,dsdtrk,dsdtrko)
    do k=1,n(3)
      do j=1,n(2)
        do i=1,n(1)
          s(i,j,k) = s(i,j,k) + factor1*dsdtrk(i,j,k) + factor2*dsdtrko(i,j,k)
          dsdtrko(i,j,k) = dsdtrk(i,j,k)
        end do
      end do
    end do
    !$OMP END PARALLEL DO
  end subroutine rk_scal
end module mod_rk


      subroutine init_MOM
!@sum  init_MOM sets an order dependent coefficient for AVRX
      USE constant, only : byrt2
      USE DYNAMICS, only : XAVRX
      XAVRX = byrt2 ! for 4th order scheme, 1 for 2nd order scheme
      CALL AVRX0
      RETURN
      END subroutine init_MOM

      SUBROUTINE ADVECV (PA,UT,VT,PB,U,V,P,DT1)
!@sum  ADVECV Advects momentum (incl. coriolis) using 4-th order scheme
!@auth Original development team
!@ver  1.0
      USE constant, only : by3,by6,by12
      USE MODEL_COM, only : im,jm,lm,ls1,mrch,dsig,psfmpt,modd5k
      USE GEOM, only : fcor,dxyp,dxv,ravpn,ravps
      USE DYNAMICS, only : pu,pv,pit,sd,spa,dut,dvt
      IMPLICIT NONE

      REAL*8 U(IM,JM,LM),V(IM,JM,LM),P(IM,JM,LM)
      REAL*8 UT(IM,JM,LM),VT(IM,JM,LM),PA(IM,JM),PB(IM,JM),FD(IM,0:JM+1)
      REAL*8 FLUXQ(IM),DUMMYS(IM),DUMMYN(IM)
      REAL*8 FDU1(IM,JM+1),FDU2(IM,JM)
      REAL*8 FX(IM,0:JM+1),GY(IM,JM),FX1(IM,JM),GY1(IM,JM)
      REAL*8,SAVE :: FDU(IM,JM+1,LM)

      INTEGER,SAVE :: IFIRST = 1
      INTEGER I,J,IP1,IM1,L,K  !@var I,J,IP1,IM1,L,K  loop variables
      REAL*8 VMASS,RVMASS,ALPH,PDT4,SDU,DT1,DT2,DT3,DT6,DT8,DT24
     *     ,FLUX,FLUXU,FLUXV
      REAL*8 ASDU(IM,2:JM,LM-1)
C****
         IF(MODD5K.LT.MRCH) CALL DIAG5F (U,V)
C****
C**** Find scaling factors FDU for const. pressure layers (time indep)
C****
      IF (IFIRST .eq. 1) then
        DO J=2,JM-1
        DO I=1,IM
          FD(I,J)=PSFMPT*DXYP(J)
        END DO
        END DO
        FD(:,0)    = 0.
        FD(:,JM+1) = 0.
        FD(:,1)    = 2.*PSFMPT*DXYP(1)
        FD(:,JM)   = 2.*PSFMPT*DXYP(JM)

        I=IM
        DO J=1,JM+1
        DO IP1=1,IM
          FDU1(I,J) = .25*(FD(I,J)+FD(IP1,J)+FD(I,J-1)+FD(IP1,J-1))
          I=IP1
        END DO
        END DO

        I=IM
        IM1=I-1
        DO J=2,JM
        DO IP1=1,IM
         FDU2(I,J)=.25*(FDU1(IP1,J)+FDU1(I,J+1)+FDU1(I,J-1)+FDU1(IM1,J))
         IM1=I
         I=IP1
        END DO
        END DO

        DO J=2,JM
        DO I=1,IM
          FDU2(I,J)=(5.*FDU1(I,J)-2.*FDU2(I,J))*by3
        END DO
        END DO

        DO L=LS1,LM
        DO J=2,JM
        DO I=1,IM
          FDU(I,J,L)=FDU2(I,J)*DSIG(L)
        END DO
        END DO
        END DO
      END IF

      DT2=DT1/2.
      DT3=DT1*by3
      DT6=DT1*by6
      DT8=DT1/8.
      DT24=DT1*by12/2.
C****
C**** Scale UT and VT which may then be physically interpreted as
C**** the momentum components
C****
C**** USE FOURTH ORDER ON THE INTERIOR.
C**** CONSIDER FLUXES PU AND PV TO BE ZERO BEYOND POLES.
C**** CONSIDER P TO BE ZERO BEYOND THE POLES
      DO J=2,JM-1
      DO I=1,IM
        FD(I,J)   = PA(I,J)*DXYP(J)
      END DO
      END DO
      FD(:,0)     = 0.
      FD(:,JM+1)  = 0.
      FD(:,1)     = 2.*PA(1,1)*DXYP(1)
      FD(:,JM)    = 2.*PA(1,JM)*DXYP(JM)

      I=IM
      DO J=1,JM+1
      DO IP1=1,IM
        FDU1(I,J) = .25*(FD(I,J)+FD(IP1,J)+FD(I,J-1)+FD(IP1,J-1))
        I=IP1
      END DO
      END DO

      I=IM
      IM1=I-1
      DO J=2,JM
      DO IP1=1,IM
        FDU2(I,J)=.25*(FDU1(IP1,J)+FDU1(I,J+1)+FDU1(I,J-1)+FDU1(IM1,J))
        IM1=I
        I=IP1
      END DO
      END DO

      DO J=2,JM
      DO I=1,IM
        FDU2(I,J)=(5.*FDU1(I,J)-2.*FDU2(I,J))*by3
      END DO
      END DO

      DO L=1,LS1-1
      DO J=2,JM
      DO I=1,IM
        FDU(I,J,L)=FDU2(I,J)*DSIG(L)
      END DO
      END DO
      END DO

C     DUT=0.
C     DVT=0.
C$COMP  PARALLEL DO PRIVATE (I,J,L)
      DO L=1,LM
        DUT(:,1,L)=0.
        DVT(:,1,L)=0.
      DO J=2,JM
      DO I=1,IM
        UT(I,J,L)=UT(I,J,L)*FDU(I,J,L)
        VT(I,J,L)=VT(I,J,L)*FDU(I,J,L)
        DUT(I,J,L)=0.
        DVT(I,J,L)=0.
      END DO
      END DO
      END DO
C$COMP  END PARALLEL DO
C****
C**** BEGINNING OF LAYER LOOP : FIND HORIZONTAL FLUXES
C****
!$OMP  PARALLEL DO PRIVATE(I,J,L,IM1,IP1,FX,FX1,GY,GY1,
!$OMP*                     FLUX,FLUXU,FLUXV)
      DO 300 L=1,LM
      I=IM
      DO 175 J=1,JM
      DO 170 IP1=1,IM
      FX(I,J)=.5*(PU(IP1,J,L)+PU(I,J,L))
  170 I=IP1
  175 CONTINUE
C****
      DO 180 J=2,JM-1
      DO 180 I=1,IM
      GY(I,J)=.5*(PV(I,J,L)+PV(I,J+1,L))
  180 CONTINUE
C**** ASSUME FLUXES PU AND PV ARE ZERO BEYOND POLE
      DO 185 I=1,IM
      GY(I,1)=.5*PV(I,2,L)
      GY(I,JM)=.5*PV(I,JM,L)
      FX(I,0)=0.
      FX(I,JM+1)=0.
  185 CONTINUE
C****
      I=IM
      IM1=I-1
      DO 192 J=1,JM
      DO 190 IP1=1,IM
      FX1(I,J)=.25*(FX(IP1,J)+FX(IM1,J)+FX(I,J+1)+FX(I,J-1))
      IM1=I
  190 I=IP1
  192 CONTINUE
      DO 195 J=2,JM-1
      DO 193 IP1=1,IM
      GY1(I,J)=.25*(GY(IP1,J)+GY(IM1,J)+GY(I,J+1)+GY(I,J-1))
      IM1=I
  193 I=IP1
  195 CONTINUE
C****
C**** HORIZONTAL ADVECTION OF MOMENTUM
C****
      I=IM
C**** Contribution from the West-East mass flux
      DO 215 J=2,JM
      DO 210 IP1=1,IM
      FLUX = DT3*(FX(I,J)+FX(I,J-1))
      FLUXU = FLUX*(U(IP1,J,L)+U(I,J,L))
      DUT(IP1,J,L) = DUT(IP1,J,L) + FLUXU
      DUT(I,J,L)   = DUT(I,J,L)   - FLUXU
      FLUXV = FLUX*(V(IP1,J,L)+V(I,J,L))
      DVT(IP1,J,L) = DVT(IP1,J,L) + FLUXV
      DVT(I,J,L)   = DVT(I,J,L)   - FLUXV
  210 I = IP1
  215 CONTINUE
C**** Contribution from the South-North mass flux
      DO 230 J=2,JM-1
      DO 220 IP1=1,IM
      FLUX = DT3*(GY(I,J)+GY(IP1,J))
      FLUXU = FLUX*(U(I,J,L)+U(I,J+1,L))
      DUT(I,J+1,L) = DUT(I,J+1,L) + FLUXU
      DUT(I,J,L)   = DUT(I,J,L)   - FLUXU
      FLUXV = FLUX*(V(I,J,L)+V(I,J+1,L))
      DVT(I,J+1,L) = DVT(I,J+1,L) + FLUXV
      DVT(I,J,L)   = DVT(I,J,L)   - FLUXV
C**** Contribution from the Southwest-Northeast mass flux
      FLUX = DT6*(FX(I,J)+GY(IP1,J)-FX1(I,J)-GY1(IP1,J))
      FLUXU = FLUX*(U(IP1,J+1,L)+U(I,J,L))
      DUT(IP1,J+1,L) = DUT(IP1,J+1,L) + FLUXU
      DUT(I,J,L)     = DUT(I,J,L)     - FLUXU
      FLUXV = FLUX*(V(IP1,J+1,L)+V(I,J,L))
      DVT(IP1,J+1,L) = DVT(IP1,J+1,L) + FLUXV
      DVT(I,J,L)     = DVT(I,J,L)     - FLUXV
C**** Contribution from the Southeast-Northwest mass flux
      FLUX = DT6*(-FX(I,J)+GY(IP1,J)+FX1(I,J)-GY1(IP1,J))
      FLUXU = FLUX*(U(I,J+1,L)+U(IP1,J,L))
      DUT(I,J+1,L) = DUT(I,J+1,L) + FLUXU
      DUT(IP1,J,L) = DUT(IP1,J,L) - FLUXU
      FLUXV = FLUX*(V(I,J+1,L)+V(IP1,J,L))
      DVT(I,J+1,L) = DVT(I,J+1,L) + FLUXV
      DVT(IP1,J,L) = DVT(IP1,J,L) - FLUXV
  220 I=IP1
  230 CONTINUE
      I=IM
      IM1=I-1
C**** CONTRIBUTION FROM THE BIG STEP WEST-EAST MASS FLUX
      DO 245 J=2,JM
      DO 240 IP1=1,IM
      FLUX=-DT24*(PU(I,J,L)+PU(I,J-1,L))
      FLUXU=FLUX*(U(IP1,J,L)+U(IM1,J,L))
      DUT(IP1,J,L)=DUT(IP1,J,L)+FLUXU
      DUT(IM1,J,L)=DUT(IM1,J,L)-FLUXU
      FLUXV=FLUX*(V(IP1,J,L)+V(IM1,J,L))
      DVT(IP1,J,L)=DVT(IP1,J,L)+FLUXV
      DVT(IM1,J,L)=DVT(IM1,J,L)-FLUXV
      IM1=I
  240 I=IP1
  245 CONTINUE
C**** CONTRIBUTION FROM THE BIG STEP SOUTH-NORTH MASS FLUX
      DO 260 J=3,JM-1
      DO 250 IP1=1,IM
      FLUX=-DT24*(PV(I,J,L)+PV(IP1,J,L))
      FLUXU=FLUX*(U(I,J-1,L)+U(I,J+1,L))
      DUT(I,J+1,L)=DUT(I,J+1,L)+FLUXU
      DUT(I,J-1,L)=DUT(I,J-1,L)-FLUXU
      FLUXV=FLUX*(V(I,J-1,L)+V(I,J+1,L))
      DVT(I,J+1,L)=DVT(I,J+1,L)+FLUXV
      DVT(I,J-1,L)=DVT(I,J-1,L)-FLUXV
  250 I=IP1
  260 CONTINUE
  300 CONTINUE
!$OMP  END PARALLEL DO
C****
C**** VERTICAL ADVECTION OF MOMENTUM
C****
C     DO 310 L=1,LM-1
C     DO 310 J=2,JM
C     I=IM
C     DO 310 IP1=1,IM
C     SDU=DT2*((SD(I,J-1,L)+SD(IP1,J-1,L))*RAVPN(J-1)+
C    *  (SD(I,J,L)+SD(IP1,J,L))*RAVPS(J))
C     DUT(I,J,L)  =DUT(I,J,L)  +SDU*(U(I,J,L)+U(I,J,L+1))
C     DUT(I,J,L+1)=DUT(I,J,L+1)-SDU*(U(I,J,L)+U(I,J,L+1))
C     DVT(I,J,L)  =DVT(I,J,L)  +SDU*(V(I,J,L)+V(I,J,L+1))
C     DVT(I,J,L+1)=DVT(I,J,L+1)-SDU*(V(I,J,L)+V(I,J,L+1))
C 310 I=IP1
!$OMP  PARALLEL DO PRIVATE (I,J,L)
      DO L=1,LM-1
      DO J=2,JM
         DO I=1,IM-1
            ASDU(I,J,L)=DT2*((SD(I,J-1,L)+SD(I+1,J-1,L))*RAVPN(J-1)+
     *                  (SD(I,J,L)+SD(I+1,J,L))*RAVPS(J))
         END DO
         ASDU(IM,J,L)=DT2*((SD(IM,J-1,L)+SD(1,J-1,L))*RAVPN(J-1)+
     *                (SD(IM,J,L)+SD(1,J,L))*RAVPS(J))
      END DO
      END DO
!$OMP  END PARALLEL DO
      L=1
      DO J=2,JM
        DUT(:,J,L)  =DUT(:,J,L)  +ASDU(:,J,L)  *(U(:,J,L)+U(:,J,L+1))
        DVT(:,J,L)  =DVT(:,J,L)  +ASDU(:,J,L)  *(V(:,J,L)+V(:,J,L+1))
      END DO
!$OMP  PARALLEL DO PRIVATE (J,L)
      DO L=2,LM-1
      DO J=2,JM
         DUT(:,J,L)  =DUT(:,J,L)  -ASDU(:,J,L-1)*(U(:,J,L-1)+U(:,J,L))
         DUT(:,J,L)  =DUT(:,J,L)  +ASDU(:,J,L)  *(U(:,J,L)+U(:,J,L+1))
         DVT(:,J,L)  =DVT(:,J,L)  -ASDU(:,J,L-1)*(V(:,J,L-1)+V(:,J,L))
         DVT(:,J,L)  =DVT(:,J,L)  +ASDU(:,J,L)  *(V(:,J,L)+V(:,J,L+1))
      END DO
      END DO
!$OMP  END PARALLEL DO
      L=LM
      DO J=2,JM
         DUT(:,J,L)=DUT(:,J,L)-ASDU(:,J,L-1)*(U(:,J,L-1)+U(:,J,L))
         DVT(:,J,L)=DVT(:,J,L)-ASDU(:,J,L-1)*(V(:,J,L-1)+V(:,J,L))
      END DO
C**** CALL DIAGNOSTICS
         IF(MODD5K.LT.MRCH) CALL DIAG5D (4,MRCH,DUT,DVT)
         IF(MRCH.GT.0) CALL DIAGCD (1,U,V,DUT,DVT,DT1,PIT)
!$OMP  PARALLEL DO PRIVATE (I,J,L)
      DO L=1,LM
      DO J=2,JM
      DO I=1,IM
        UT(I,J,L)=UT(I,J,L)+DUT(I,J,L)
        VT(I,J,L)=VT(I,J,L)+DVT(I,J,L)
        DUT(I,J,L)=0.
        DVT(I,J,L)=0.
      END DO
      END DO
      END DO
!$OMP  END PARALLEL DO
C****
C**** CORIOLIS FORCE
C****
!$OMP  PARALLEL DO PRIVATE (I,IM1,J,L,FD,PDT4,ALPH)
      DO 430 L=1,LM
      IM1=IM
      DO 405 I=1,IM
C     FD(I,1)=FCOR(1)*2.-.5*(SPA(IM1,1,L)+SPA(I,1,L))*DXV(2)
C     FD(I,JM)=FCOR(JM)*2.+.5*(SPA(IM1,JM,L)+SPA(I,JM,L))*DXV(JM)
C**** Set the Coriolis term to zero at the Poles:
      FD(I,1)=  -.5*(SPA(IM1,1,L)+SPA(I,1,L))*DXV(2)
      FD(I,JM)=  .5*(SPA(IM1,JM,L)+SPA(I,JM,L))*DXV(JM)
  405 IM1=I
      DO 410 J=2,JM-1
      DO 410 I=1,IM
      FD(I,J)=FCOR(J)+.25*(SPA(IM1,J,L)+SPA(I,J,L))*(DXV(J)-DXV(J+1))
  410 IM1=I
  415 CONTINUE
      DO 425 J=2,JM
      DO 420 I=1,IM
      PDT4=DT8*(P(I,J-1,L)+P(I,J,L))
      ALPH=PDT4*(FD(I,J)+FD(I,J-1))*DSIG(L)
      DUT(I,J,L)=DUT(I,J,L)+ALPH*V(I,J,L)
      DUT(IM1,J,L)=DUT(IM1,J,L)+ALPH*V(IM1,J,L)
      DVT(I,J,L)=DVT(I,J,L)-ALPH*U(I,J,L)
      DVT(IM1,J,L)=DVT(IM1,J,L)-ALPH*U(IM1,J,L)
  420 IM1=I
  425 CONTINUE
  430 CONTINUE
!$OMP  END PARALLEL DO
C**** CALL DIAGNOSTICS, ADD CORIOLIS FORCE INCREMENTS TO UT AND VT
         IF(MODD5K.LT.MRCH) CALL DIAG5D (5,MRCH,DUT,DVT)
         IF(MRCH.GT.0) CALL DIAGCD (2,U,V,DUT,DVT,DT1)
!$OMP  PARALLEL DO PRIVATE (I,J,L)
      DO L=1,LM
      DO J=2,JM
      DO I=1,IM
        UT(I,J,L)=UT(I,J,L)+DUT(I,J,L)
        VT(I,J,L)=VT(I,J,L)+DVT(I,J,L)
        DUT(I,J,L)=0.
        DVT(I,J,L)=0.
      END DO
      END DO
      END DO
!$OMP  END PARALLEL DO
C****
C**** UNDO SCALING PERFORMED AT BEGINNING OF ADVECV
C****
      DO J=2,JM-1
      DO I=1,IM
        FD(I,J)   = PB(I,J)*DXYP(J)
      END DO
      END DO
      FD(:,0)     = 0.
      FD(:,JM+1)  = 0.
      FD(:,1)     = 2.*PB(1,1)*DXYP(1)
      FD(:,JM)    = 2.*PB(1,JM)*DXYP(JM)

      I=IM
      DO J=1,JM+1
      DO IP1=1,IM
        FDU1(I,J) = .25*(FD(I,J)+FD(IP1,J)+FD(I,J-1)+FD(IP1,J-1))
        I=IP1
      END DO
      END DO

      I=IM
      IM1=I-1
      DO J=2,JM
      DO IP1=1,IM
        FDU2(I,J)=.25*(FDU1(IP1,J)+FDU1(I,J+1)+FDU1(I,J-1)+FDU1(IM1,J))
        IM1=I
        I=IP1
      END DO
      END DO

      DO J=2,JM
      DO I=1,IM
        FDU2(I,J)=(5.*FDU1(I,J)-2.*FDU2(I,J))*by3
      END DO
      END DO

      DO L=1,LS1-1
      DO J=2,JM
      DO I=1,IM
        FDU(I,J,L)=FDU2(I,J)*DSIG(L)
      END DO
      END DO
      END DO

C     DUT=0.
C     DVT=0.
!$OMP  PARALLEL DO PRIVATE (I,J,L)
      DO L=1,LM
        DUT(:,1,L)=0.
        DVT(:,1,L)=0.
      DO J=2,JM
      DO I=1,IM
        UT(I,J,L)=UT(I,J,L)/FDU(I,J,L)
        VT(I,J,L)=VT(I,J,L)/FDU(I,J,L)
        DUT(I,J,L)=0.
        DVT(I,J,L)=0.
      END DO
      END DO
      END DO
!$OMP  END PARALLEL DO
      RETURN
      END SUBROUTINE ADVECV


       program NS
       parameter (nvar=3,nxm=2000,nym=2000)
       real phi(nvar,nxm,nym), phi1(nvar,nxm,nym)
       real xcoef(nxm,nym)

       nx=101
       ny=101

       unorm=0.
! This loop nest should be distributed,
! the reduction on unorm output as OpenMP
! and the 2 resulting loop nests parallelized.
       do j=1,ny
          do i=1,nx
             unorm=unorm+(phi1(1,i,j)-phi(1,i,j))**2
     1            +(phi1(2,i,j)-phi(2,i,j))**2
             do iv=1,nvar
                phi(iv,i,j)=phi1(iv,i,j)
             enddo
          enddo
       enddo
       end


      PROGRAM CCPSPV
C
C Define the error file, the Fortran unit number, the workstation type,
C and the workstation ID to be used in calls to GKS routines.
C
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)   ! NCGM
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=8,  IWKID=1)   ! X Windows
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=11, IWKID=1)   ! PDF
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=20, IWKID=1)   ! PostScript
C
      PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)

      PARAMETER (K=40,N=40,LRWK=1000,LIWK=1000)
      REAL Z(K,N), RWRK(LRWK)
      INTEGER M, IWRK(LIWK)

      CALL GETDAT (Z, K, M, N)
C
C Mark values near the center of the array with a value of -1.0
C
      DO 5, I=2*K/5,3*K/5
         DO 15, J=2*N/7,3*N/7
            Z(I,J)=-1.0
 15      CONTINUE
 5    CONTINUE
C
C Open GKS
C
      CALL GOPKS (IERRF, ISZDM)
      CALL GOPWK (IWKID, LUNIT, IWTYPE)
      CALL GACWK (IWKID)
C
C Tell Conpack that data points with a value of -1.0 shouldn't be drawn
C
      CALL CPSETR('SPV - SPECIAL VALUE',-1.0)
C
C Force Conpack to outline the special value region
C
      CALL CPSETI('PAI - PARAMETER ARRAY INDEX',-2)
      CALL CPSETI('CLU - CONTOUR LEVEL USE FLAGS',1)
C
C Initialize Conpack
C
      CALL CPRECT(Z,K,M,N,RWRK,LRWK,IWRK,LIWK)
C
C Draw perimeter
C
      CALL CPBACK(Z, RWRK, IWRK)
C
C Draw Contours
C
      CALL CPCLDR(Z,RWRK,IWRK)
C
C Close frame and close GKS
C
      CALL FRAME
      CALL GDAWK (IWKID)
      CALL GCLWK (IWKID)
      CALL GCLKS

      STOP
      END

      SUBROUTINE GETDAT (Z, K, M, N)
      INTEGER I,J,K,M,N
      REAL Z(K,N)

      M=K
      DO 10, I=1,M
         DO 20, J=1,N
            Z(I,J)= 10.E-5*(-16.*REAL(I**2*J) +
     1           34*REAL(I*J**2) - REAL(6*I) + 93.)
 20      CONTINUE
 10   CONTINUE

      RETURN
      END


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2020 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine objective_stress_dx_dy(nodeset,istartset,iendset,
     &  ialset,nk,idesvar1c,idesvar2c,iobject,dgdx,ndesi,nobject,stn,
     &  dstn1,dstn2,dstn12,objectset,g0,dgdxdy)
!
!     calculates derivative of the sum of the square of the
!     von Mises stress of a node set w.r.t. the coordinates of the mesh
!
      implicit none
!
      character*81 objectset(4,*)
!
      integer nk,istartset(*),iendset(*),ialset(*),nodeset,idesvar2c,
     &  idesvar1c,iobject,j,k,ndesi,nobject,idesvar1,idesvar2
!
      real*8 dgdx(ndesi,nobject),stn(6,*),dstn1(6,*),g0(nobject),
     &  rho,xstress,svm,dsvmd1,p,dstn2(6,*),dstn12(6,*),dsvmd2,
     &  dsvmd12,dgdxdy(ndesi,ndesi,nobject),argument
!
      idesvar1=idesvar1c+1
      idesvar2=idesvar2c+1
!
!     reading rho and the mean stress for the Kreisselmeier-Steinhauser
!     function
!
      read(objectset(2,iobject)(41:60),'(f20.0)') rho
      read(objectset(2,iobject)(61:80),'(f20.0)') xstress
!
!     check for the existence of a set, else take the complete mesh
!
      dgdx(idesvar1,iobject)=0.d0
      dgdx(idesvar2,iobject)=0.d0
!
      if(nodeset.eq.0) then
         do j=1,nk
            p=-(stn(1,j)+stn(2,j)+stn(3,j))/3.d0
            svm=dsqrt(1.5d0*
     &        ((stn(1,j)+p)**2+(stn(2,j)+p)**2+(stn(3,j)+p)**2+
     &         2.d0*(stn(4,j)**2+stn(5,j)**2+stn(6,j)**2)))
            dsvmd1=
     &          ((2.d0*stn(1,j)-stn(2,j)-stn(3,j))*dstn1(1,j)+
     &           (2.d0*stn(2,j)-stn(1,j)-stn(3,j))*dstn1(2,j)+
     &           (2.d0*stn(3,j)-stn(1,j)-stn(2,j))*dstn1(3,j)+
     &           6.d0*(stn(4,j)*dstn1(4,j)+stn(5,j)*dstn1(5,j)+
     &                 stn(6,j)*dstn1(6,j)))/(2.d0*svm)
            argument=rho*svm/xstress
            if(argument.gt.600.d0) then
               write(*,*) '*ERROR in objective_stress: argument'
               write(*,*) '       ',argument,
     &               ' of exponential function is too big;'
               write(*,*)
     &             '       choose other Kreisselmeier-Steinhauser'
               write(*,*) '       coefficients'
               call exit(201)
            endif
            dgdx(idesvar1,iobject)=dgdx(idesvar1,iobject)+
     &           dexp(argument)*dsvmd1
            dsvmd2=
     &          ((2.d0*stn(1,j)-stn(2,j)-stn(3,j))*dstn2(1,j)+
     &           (2.d0*stn(2,j)-stn(1,j)-stn(3,j))*dstn2(2,j)+
     &           (2.d0*stn(3,j)-stn(1,j)-stn(2,j))*dstn2(3,j)+
     &           6.d0*(stn(4,j)*dstn2(4,j)+stn(5,j)*dstn2(5,j)+
     &                 stn(6,j)*dstn2(6,j)))/(2.d0*svm)
            dgdx(idesvar2,iobject)=dgdx(idesvar2,iobject)+
     &           dexp(argument)*dsvmd2
            dsvmd12=-dsvmd1*dsvmd2/svm+
     &         ((2.d0*dstn2(1,j)-dstn2(2,j)-dstn2(3,j))*dstn1(1,j)+
     &          (2.d0*dstn2(2,j)-dstn2(3,j)-dstn2(1,j))*dstn1(2,j)+
     &          (2.d0*dstn2(3,j)-dstn2(1,j)-dstn2(2,j))*dstn1(3,j)+
     &          (2.d0*stn(1,j)-stn(2,j)-stn(3,j))*dstn12(1,j)+
     &          (2.d0*stn(2,j)-stn(3,j)-stn(1,j))*dstn12(1,j)+
     &          (2.d0*stn(3,j)-stn(1,j)-stn(2,j))*dstn12(1,j)+
     &          6.d0*(dstn1(4,j)*dstn2(4,j)+stn(4,j)*dstn12(4,j)+
     &                dstn1(5,j)*dstn2(5,j)+stn(5,j)*dstn12(5,j)+
     &                dstn1(6,j)+dstn2(6,j)+stn(6,j)*dstn12(6,j)))/
     &            (2.d0*svm)
            dgdxdy(idesvar1,idesvar2,iobject)=
     &        dgdxdy(idesvar1,idesvar2,iobject)+dexp(argument)*
     &        (dsvmd12+rho*dsvmd1*dsvmd2/xstress)
         enddo
         dgdx(idesvar1,iobject)=dgdx(idesvar1,iobject)*
     &         dexp(-rho*g0(iobject))/xstress
         dgdx(idesvar2,iobject)=dgdx(idesvar2,iobject)*
     &         dexp(-rho*g0(iobject))/xstress
         dgdxdy(idesvar1,idesvar2,iobject)=
     &      dgdxdy(idesvar1,idesvar2,iobject)
     &      *dexp(-rho*g0(iobject))/xstress
     &      -rho*dgdx(idesvar1,iobject)*dgdx(idesvar2,iobject)
      else
         do j=istartset(nodeset),iendset(nodeset)
            if(ialset(j).gt.0) then
               k=ialset(j)
               p=-(stn(1,k)+stn(2,k)+stn(3,k))/3.d0
               svm=dsqrt(1.5d0*
     &              ((stn(1,k)+p)**2+(stn(2,k)+p)**2+(stn(3,k)+p)**2+
     &              2.d0*(stn(4,k)**2+stn(5,k)**2+stn(6,k)**2)))
               dsvmd1=
     &             ((2.d0*stn(1,k)-stn(2,k)-stn(3,k))*dstn1(1,k)+
     &              (2.d0*stn(2,k)-stn(1,k)-stn(3,k))*dstn1(2,k)+
     &              (2.d0*stn(3,k)-stn(1,k)-stn(2,k))*dstn1(3,k)+
     &              6.d0*(stn(4,k)*dstn1(4,k)+stn(5,k)*dstn1(5,k)+
     &              stn(6,k)*dstn1(6,j)))/(2.d0*svm)
               argument=rho*svm/xstress
               if(argument.gt.600.d0) then
                  write(*,*) '*ERROR in objective_stress: argument'
                  write(*,*) '       ',argument,
     &               ' of exponential function is too big;'
                  write(*,*)
     &             '       choose other Kreisselmeier-Steinhauser'
                  write(*,*) '       coefficients'
                  call exit(201)
               endif
               dgdx(idesvar1,iobject)=dgdx(idesvar1,iobject)+
     &              dexp(argument)*dsvmd1
               dsvmd2=
     &             ((2.d0*stn(1,k)-stn(2,k)-stn(3,k))*dstn2(1,k)+
     &              (2.d0*stn(2,k)-stn(1,k)-stn(3,k))*dstn2(2,k)+
     &              (2.d0*stn(3,k)-stn(1,k)-stn(2,k))*dstn2(3,k)+
     &              6.d0*(stn(4,k)*dstn2(4,k)+stn(5,k)*dstn2(5,k)+
     &              stn(6,k)*dstn2(6,j)))/(2.d0*svm)
               dgdx(idesvar2,iobject)=dgdx(idesvar2,iobject)+
     &              dexp(argument)*dsvmd2
               dsvmd12=-dsvmd1*dsvmd2/svm+
     &         ((2.d0*dstn2(1,j)-dstn2(2,j)-dstn2(3,j))*dstn1(1,j)+
     &          (2.d0*dstn2(2,j)-dstn2(3,j)-dstn2(1,j))*dstn1(2,j)+
     &          (2.d0*dstn2(3,j)-dstn2(1,j)-dstn2(2,j))*dstn1(3,j)+
     &          (2.d0*stn(1,j)-stn(2,j)-stn(3,j))*dstn12(1,j)+
     &          (2.d0*stn(2,j)-stn(3,j)-stn(1,j))*dstn12(1,j)+
     &          (2.d0*stn(3,j)-stn(1,j)-stn(2,j))*dstn12(1,j)+
     &          6.d0*(dstn1(4,j)*dstn2(4,j)+stn(4,j)*dstn12(4,j)+
     &                dstn1(5,j)*dstn2(5,j)+stn(5,j)*dstn12(5,j)+
     &                dstn1(6,j)+dstn2(6,j)+stn(6,j)*dstn12(6,j)))/
     &            (2.d0*svm)
               dgdxdy(idesvar1,idesvar2,iobject)=
     &          dgdxdy(idesvar1,idesvar2,iobject)+dexp(argument)*
     &          (dsvmd12+rho*dsvmd1*dsvmd2/xstress)
            else
               k=ialset(j-2)
               do
                  k=k-ialset(j)
                  if(k.ge.ialset(j-1)) exit
                  p=-(stn(1,k)+stn(2,k)+stn(3,k))/3.d0
                  svm=dsqrt(1.5d0*
     &                 ((stn(1,k)+p)**2+(stn(2,k)+p)**2+(stn(3,k)+p)**2+
     &                 2.d0*(stn(4,k)**2+stn(5,k)**2+stn(6,k)**2)))
                  dsvmd1=
     &                ((2.d0*stn(1,k)-stn(2,k)-stn(3,k))*dstn1(1,k)+
     &                 (2.d0*stn(2,k)-stn(1,k)-stn(3,k))*dstn1(2,k)+
     &                 (2.d0*stn(3,k)-stn(1,k)-stn(2,k))*dstn1(3,k)+
     &                 6.d0*(stn(4,k)*dstn1(4,k)+stn(5,k)*dstn1(5,k)+
     &                 stn(6,k)*dstn1(6,j)))/(2.d0*svm)
                  argument=rho*svm/xstress
                  if(argument.gt.600.d0) then
                     write(*,*) '*ERROR in objective_stress: argument'
                     write(*,*) '       ',argument,
     &               ' of exponential function is too big;'
                     write(*,*)
     &             '       choose other Kreisselmeier-Steinhauser'
                     write(*,*) '       coefficients'
                     call exit(201)
                  endif
                  dgdx(idesvar1,iobject)=dgdx(idesvar1,iobject)+
     &                 dexp(argument)*dsvmd1
                  dsvmd2=
     &                ((2.d0*stn(1,k)-stn(2,k)-stn(3,k))*dstn2(1,k)+
     &                 (2.d0*stn(2,k)-stn(1,k)-stn(3,k))*dstn2(2,k)+
     &                 (2.d0*stn(3,k)-stn(1,k)-stn(2,k))*dstn2(3,k)+
     &                 6.d0*(stn(4,k)*dstn2(4,k)+stn(5,k)*dstn2(5,k)+
     &                 stn(6,k)*dstn2(6,j)))/(2.d0*svm)
                  dgdx(idesvar2,iobject)=dgdx(idesvar2,iobject)+
     &                 dexp(argument)*dsvmd2
                  dsvmd12=-dsvmd1*dsvmd2/svm+
     &            ((2.d0*dstn2(1,j)-dstn2(2,j)-dstn2(3,j))*dstn1(1,j)+
     &             (2.d0*dstn2(2,j)-dstn2(3,j)-dstn2(1,j))*dstn1(2,j)+
     &             (2.d0*dstn2(3,j)-dstn2(1,j)-dstn2(2,j))*dstn1(3,j)+
     &             (2.d0*stn(1,j)-stn(2,j)-stn(3,j))*dstn12(1,j)+
     &             (2.d0*stn(2,j)-stn(3,j)-stn(1,j))*dstn12(1,j)+
     &             (2.d0*stn(3,j)-stn(1,j)-stn(2,j))*dstn12(1,j)+
     &              6.d0*(dstn1(4,j)*dstn2(4,j)+stn(4,j)*dstn12(4,j)+
     &                dstn1(5,j)*dstn2(5,j)+stn(5,j)*dstn12(5,j)+
     &                dstn1(6,j)+dstn2(6,j)+stn(6,j)*dstn12(6,j)))/
     &             (2.d0*svm)
                  dgdxdy(idesvar1,idesvar2,iobject)=
     &                dgdxdy(idesvar1,idesvar2,iobject)+
     &                dexp(argument)*
     &                (dsvmd12+rho*dsvmd1*dsvmd2/xstress)
               enddo
            endif
         enddo
         dgdx(idesvar1,iobject)=dgdx(idesvar1,iobject)*
     &         dexp(-rho*g0(iobject))/xstress
         dgdx(idesvar2,iobject)=dgdx(idesvar2,iobject)*
     &         dexp(-rho*g0(iobject))/xstress
         dgdxdy(idesvar1,idesvar2,iobject)=
     &      dgdxdy(idesvar1,idesvar2,iobject)
     &      *dexp(-rho*g0(iobject))/xstress
     &      -rho*dgdx(idesvar1,iobject)*dgdx(idesvar2,iobject)
      endif
!
      return
      end


      SUBROUTINE MB03PD( JOBRQ, M, N, A, LDA, JPVT, RCOND, SVLMAX, TAU,
     $                   RANK, SVAL, DWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute (optionally) a rank-revealing RQ factorization of a
C     real general M-by-N matrix  A,  which may be rank-deficient,
C     and estimate its effective rank using incremental condition
C     estimation.
C
C     The routine uses an RQ factorization with row pivoting:
C        P * A = R * Q,  where  R = [ R11 R12 ],
C                                   [  0  R22 ]
C     with R22 defined as the largest trailing submatrix whose estimated
C     condition number is less than 1/RCOND.  The order of R22, RANK,
C     is the effective rank of A.
C
C     MB03PD  does not perform any scaling of the matrix A.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBRQ   CHARACTER*1
C             = 'R':  Perform an RQ factorization with row pivoting;
C             = 'N':  Do not perform the RQ factorization (but assume
C                     that it has been done outside).
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrix A.  M >= 0.
C
C     N       (input) INTEGER
C             The number of columns of the matrix A.  N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension
C             ( LDA, N )
C             On entry with JOBRQ = 'R', the leading M-by-N part of this
C             array must contain the given matrix A.
C             On exit with JOBRQ = 'R',
C             if M <= N, the upper triangle of the subarray
C             A(1:M,N-M+1:N) contains the M-by-M upper triangular
C             matrix R;
C             if M >= N, the elements on and above the (M-N)-th
C             subdiagonal contain the M-by-N upper trapezoidal matrix R;
C             the remaining elements, with the array TAU, represent the
C             orthogonal matrix Q as a product of min(M,N) elementary
C             reflectors (see METHOD).
C             On entry and on exit with JOBRQ = 'N',
C             if M <= N, the upper triangle of the subarray
C             A(1:M,N-M+1:N) must contain the M-by-M upper triangular
C             matrix R;
C             if M >= N, the elements on and above the (M-N)-th
C             subdiagonal must contain the M-by-N upper trapezoidal
C             matrix R;
C             the remaining elements are not referenced.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,M).
C
C     JPVT    (input/output) INTEGER array, dimension ( M )
C             On entry with JOBRQ = 'R', if JPVT(i) <> 0, the i-th row
C             of A is a final row, otherwise it is a free row. Before
C             the RQ factorization of A, all final rows are permuted
C             to the trailing positions; only the remaining free rows
C             are moved as a result of row pivoting during the
C             factorization.  For rank determination it is preferable
C             that all rows be free.
C             On exit with JOBRQ = 'R', if JPVT(i) = k, then the i-th
C             row of P*A was the k-th row of A.
C             Array JPVT is not referenced when JOBRQ = 'N'.
C
C     RCOND   (input) DOUBLE PRECISION
C             RCOND is used to determine the effective rank of A, which
C             is defined as the order of the largest trailing triangular
C             submatrix R22 in the RQ factorization with pivoting of A,
C             whose estimated condition number is less than 1/RCOND.
C             RCOND >= 0.
C             NOTE that when SVLMAX > 0, the estimated rank could be
C             less than that defined above (see SVLMAX).
C
C     SVLMAX  (input) DOUBLE PRECISION
C             If A is a submatrix of another matrix B, and the rank
C             decision should be related to that matrix, then SVLMAX
C             should be an estimate of the largest singular value of B
C             (for instance, the Frobenius norm of B).  If this is not
C             the case, the input value SVLMAX = 0 should work.
C             SVLMAX >= 0.
C
C     TAU     (output) DOUBLE PRECISION array, dimension ( MIN( M, N ) )
C             On exit with JOBRQ = 'R', the leading min(M,N) elements of
C             TAU contain the scalar factors of the elementary
C             reflectors.
C             Array TAU is not referenced when JOBRQ = 'N'.
C
C     RANK    (output) INTEGER
C             The effective (estimated) rank of A, i.e. the order of
C             the submatrix R22.
C
C     SVAL    (output) DOUBLE PRECISION array, dimension ( 3 )
C             The estimates of some of the singular values of the
C             triangular factor R:
C             SVAL(1): largest singular value of
C                      R(M-RANK+1:M,N-RANK+1:N);
C             SVAL(2): smallest singular value of
C                      R(M-RANK+1:M,N-RANK+1:N);
C             SVAL(3): smallest singular value of R(M-RANK:M,N-RANK:N),
C                      if RANK < MIN( M, N ), or of
C                      R(M-RANK+1:M,N-RANK+1:N), otherwise.
C             If the triangular factorization is a rank-revealing one
C             (which will be the case if the trailing rows were well-
C             conditioned), then SVAL(1) will also be an estimate for
C             the largest singular value of A, and SVAL(2) and SVAL(3)
C             will be estimates for the RANK-th and (RANK+1)-st singular
C             values of A, respectively.
C             By examining these values, one can confirm that the rank
C             is well defined with respect to the chosen value of RCOND.
C             The ratio SVAL(1)/SVAL(2) is an estimate of the condition
C             number of R(M-RANK+1:M,N-RANK+1:N).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension ( LDWORK )
C             where LDWORK = max( 1, 3*M ),           if JOBRQ = 'R';
C                   LDWORK = max( 1, 3*min( M, N ) ), if JOBRQ = 'N'.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The routine computes or uses an RQ factorization with row
C     pivoting of A,  P * A = R * Q,  with  R  defined above, and then
C     finds the largest trailing submatrix whose estimated condition
C     number is less than 1/RCOND, taking the possible positive value of
C     SVLMAX into account.  This is performed using an adaptation of the
C     LAPACK incremental condition estimation scheme and a slightly
C     modified rank decision test.
C
C     The matrix Q is represented as a product of elementary reflectors
C
C        Q = H(1) H(2) . . . H(k), where k = min(m,n).
C
C     Each H(i) has the form
C
C        H = I - tau * v * v'
C
C     where tau is a real scalar, and v is a real vector with
C     v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit
C     in A(m-k+i,1:n-k+i-1), and tau in TAU(i).
C
C     The matrix P is represented in jpvt as follows: If
C        jpvt(j) = i
C     then the jth row of P is the ith canonical unit vector.
C
C     REFERENCES
C
C     [1] Bischof, C.H. and P. Tang.
C         Generalizing Incremental Condition Estimation.
C         LAPACK Working Notes 32, Mathematics and Computer Science
C         Division, Argonne National Laboratory, UT, CS-91-132,
C         May 1991.
C
C     [2] Bischof, C.H. and P. Tang.
C         Robust Incremental Condition Estimation.
C         LAPACK Working Notes 33, Mathematics and Computer Science
C         Division, Argonne National Laboratory, UT, CS-91-133,
C         May 1991.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is backward stable.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996.
C
C     REVISIONS
C
C     Nov. 1997
C
C     KEYWORDS
C
C     Eigenvalue problem, matrix operations, orthogonal transformation,
C     singular values.
C
C    ******************************************************************
C
C     .. Parameters ..
      INTEGER            IMAX, IMIN
      PARAMETER          ( IMAX = 1, IMIN = 2 )
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER          JOBRQ
      INTEGER            INFO, LDA, M, N, RANK
      DOUBLE PRECISION   RCOND, SVLMAX
C     .. Array Arguments ..
      INTEGER            JPVT( * )
      DOUBLE PRECISION   A( LDA, * ), SVAL( 3 ), TAU( * ), DWORK( * )
C     .. Local Scalars ..
      LOGICAL            LJOBRQ
      INTEGER            I, ISMAX, ISMIN, JWORK, MN
      DOUBLE PRECISION   C1, C2, S1, S2, SMAX, SMAXPR, SMIN, SMINPR
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
      EXTERNAL           DCOPY, DLAIC1, MB04GD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
C     ..
C     .. Executable Statements ..
C
      LJOBRQ = LSAME( JOBRQ, 'R' )
      MN = MIN( M, N )
C
C     Test the input scalar arguments.
C
      INFO = 0
      IF( .NOT.LJOBRQ .AND. .NOT.LSAME( JOBRQ, 'N' ) ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      ELSE IF( RCOND.LT.ZERO ) THEN
         INFO = -7
      ELSE IF( SVLMAX.LT.ZERO ) THEN
         INFO = -8
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB03PD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( MN.EQ.0 ) THEN
         RANK = 0
         SVAL( 1 ) = ZERO
         SVAL( 2 ) = ZERO
         SVAL( 3 ) = ZERO
         RETURN
      END IF
C
      IF ( LJOBRQ ) THEN
C
C        Compute RQ factorization with row pivoting of A:
C           P * A = R * Q
C        Workspace 3*M. Details of Householder rotations stored in TAU.
C
         CALL MB04GD( M, N, A, LDA, JPVT, TAU, DWORK( 1 ), INFO )
      END IF
C
C     Determine RANK using incremental condition estimation.
C        Workspace 3*min(M,N).
C
      SMAX = ABS( A( M, N ) )
      IF( SMAX.EQ.ZERO .OR. SVLMAX*RCOND.GT.SMAX ) THEN
         RANK = 0
         SVAL( 1 ) = SMAX
         SVAL( 2 ) = ZERO
         SVAL( 3 ) = ZERO
      ELSE
         ISMIN = MN
         ISMAX = 2*MN
         JWORK = ISMAX + 1
         DWORK( ISMIN ) = ONE
         DWORK( ISMAX ) = ONE
         RANK = 1
         SMIN = SMAX
         SMINPR = SMIN
C
   10    CONTINUE
         IF( RANK.LT.MN ) THEN
            CALL DCOPY ( RANK, A( M-RANK, N-RANK+1 ), LDA,
     $                   DWORK( JWORK ), 1 )
            CALL DLAIC1( IMIN, RANK, DWORK( ISMIN ), SMIN,
     $                   DWORK( JWORK ), A( M-RANK, N-RANK ), SMINPR,
     $                   S1, C1 )
            CALL DLAIC1( IMAX, RANK, DWORK( ISMAX ), SMAX,
     $                   DWORK( JWORK ), A( M-RANK, N-RANK ), SMAXPR,
     $                   S2, C2 )
C
            IF( SVLMAX*RCOND.LE.SMAXPR ) THEN
               IF( SVLMAX*RCOND.LE.SMINPR ) THEN
                  IF( SMAXPR*RCOND.LE.SMINPR ) THEN
                     DO 20 I = 1, RANK
                        DWORK( ISMIN+I-1 ) = S1*DWORK( ISMIN+I-1 )
                        DWORK( ISMAX+I-1 ) = S2*DWORK( ISMAX+I-1 )
   20                CONTINUE
                     ISMIN = ISMIN - 1
                     ISMAX = ISMAX - 1
                     DWORK( ISMIN ) = C1
                     DWORK( ISMAX ) = C2
                     SMIN = SMINPR
                     SMAX = SMAXPR
                     RANK = RANK + 1
                     GO TO 10
                  END IF
               END IF
            END IF
         END IF
         SVAL( 1 ) = SMAX
         SVAL( 2 ) = SMIN
         SVAL( 3 ) = SMINPR
      END IF
C
      RETURN
C *** Last line of MB03PD ***
      END


C$Procedure ZZCK4D2I ( Unpack a set of integers from DP number )

      SUBROUTINE ZZCK4D2I ( DPCOEF, NSETS, PARCOD, I )

C$ Abstract
C
C     SPICE Private routine intended solely for the support of SPICE
C     routines. Users should not call this routine directly due
C     to the volatile nature of this routine.
C
C     This is the routine that unpacks a set integer numbers stored in
C     a single double precision number.
C
C     Its current specific use is to "uncompress" seven integer numbers
C     representing numbers of polynomial coefficients in a logical
C     type 4 CK record from a single DP number stored in a physical
C     type 4 CK record in a file.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     None.
C
C$ Declarations

      IMPLICIT NONE

      DOUBLE PRECISION        DPCOEF
      INTEGER                 NSETS
      DOUBLE PRECISION        PARCOD
      INTEGER                 I      ( * )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     DPCOEF     I   DP number containing packed integer numbers.
C     NSETS      I   Number of integer components packed in DPCOEF.
C     PARCOD     I   Packing base.
C     I          O   Array of NSETS integer components.
C
C$ Detailed_Input
C
C     DPCOEF     is a DP number containing NSETS integers packed
C                together.
C
C     NSETS      is the number of integers packed in the DPCOEF.
C
C     PARCOD     is the packing base.
C
C$ Detailed_Output
C
C     I          is an array containing unpacked integers.
C
C$ Parameters
C
C     None.
C
C$ Files
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Particulars
C
C     This routine unpacks NSETS integers packed in a single double
C     precision number using base specified by PARCOD and stored them
C     in the array I. The integers are packed in the DP using the
C     following algorithm:
C
C        [DPCOEF]= PARCOD ** ( NSETS - 1 ) * I( 1 )        +
C                  PARCOD ** ( NSETS - 2 ) * I( 2 )        +
C                  ...
C                  PARCOD ** 1             * I( NSETS - 1 )+
C                  PARCOD ** 0             * I( NSETS )
C     where:
C
C        I(1:NSETS) - is an array of integer numbers with values
C                     in the range [0:PARCOD-1].
C
C$ Examples
C
C     None.
C
C$ Restrictions
C
C     Output integer array I must have enough space to hold NSETS
C     numbers.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     Y.K. Zaiko     (JPL)
C     B.V. Semenov   (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 05-MAY-1999 (YKZ) (BVS)
C
C-&

C
C     Local variables.
C
      DOUBLE PRECISION        X
      INTEGER                 K

C
C     Let's unpack it!
C
      X = PARCOD ** ( NSETS - 1 )

      DO K = 0, NSETS - 1

         I( NSETS - K ) = DPCOEF / X
         DPCOEF = DPCOEF - I( NSETS - K ) * X
         X = X / PARCOD

      END DO

C
C     All done.
C
      RETURN

      END


      DOUBLE PRECISION FUNCTION basym(a,b,lambda,eps)
C-----------------------------------------------------------------------
C     ASYMPTOTIC EXPANSION FOR IX(A,B) FOR LARGE A AND B.
C     LAMBDA = (A + B)*Y - B  AND EPS IS THE TOLERANCE USED.
C     IT IS ASSUMED THAT LAMBDA IS NONNEGATIVE AND THAT
C     A AND B ARE GREATER THAN OR EQUAL TO 15.
C-----------------------------------------------------------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION a,b,eps,lambda
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION bsum,dsum,e0,e1,f,h,h2,hn,j0,j1,r,r0,r1,s,sum,t,
     +                 t0,t1,u,w,w0,z,z0,z2,zn,znm1
      INTEGER i,im1,imj,j,m,mm1,mmj,n,np1,num
C     ..
C     .. Local Arrays ..
      DOUBLE PRECISION a0(21),b0(21),c(21),d(21)
C     ..
C     .. External Functions ..
      DOUBLE PRECISION bcorr,erfc1,rlog1
      EXTERNAL bcorr,erfc1,rlog1
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC abs,exp,sqrt
C     ..
C     .. Data statements ..
C------------------------
C     ****** NUM IS THE MAXIMUM VALUE THAT N CAN TAKE IN THE DO LOOP
C            ENDING AT STATEMENT 50. IT IS REQUIRED THAT NUM BE EVEN.
C            THE ARRAYS A0, B0, C, D HAVE DIMENSION NUM + 1.
C
C------------------------
C     E0 = 2/SQRT(PI)
C     E1 = 2**(-3/2)
C------------------------
      DATA num/20/
      DATA e0/1.12837916709551D0/,e1/.353553390593274D0/
C     ..
C     .. Executable Statements ..
C------------------------
      basym = 0.0D0
      IF (a.GE.b) GO TO 10
      h = a/b
      r0 = 1.0D0/ (1.0D0+h)
      r1 = (b-a)/b
      w0 = 1.0D0/sqrt(a* (1.0D0+h))
      GO TO 20

   10 h = b/a
      r0 = 1.0D0/ (1.0D0+h)
      r1 = (b-a)/a
      w0 = 1.0D0/sqrt(b* (1.0D0+h))
C
   20 f = a*rlog1(-lambda/a) + b*rlog1(lambda/b)
      t = exp(-f)
      IF (t.EQ.0.0D0) RETURN
      z0 = sqrt(f)
      z = 0.5D0* (z0/e1)
      z2 = f + f
C
      a0(1) = (2.0D0/3.0D0)*r1
      c(1) = -0.5D0*a0(1)
      d(1) = -c(1)
      j0 = (0.5D0/e0)*erfc1(1,z0)
      j1 = e1
      sum = j0 + d(1)*w0*j1
C
      s = 1.0D0
      h2 = h*h
      hn = 1.0D0
      w = w0
      znm1 = z
      zn = z2
      DO 70 n = 2,num,2
          hn = h2*hn
          a0(n) = 2.0D0*r0* (1.0D0+h*hn)/ (n+2.0D0)
          np1 = n + 1
          s = s + hn
          a0(np1) = 2.0D0*r1*s/ (n+3.0D0)
C
          DO 60 i = n,np1
              r = -0.5D0* (i+1.0D0)
              b0(1) = r*a0(1)
              DO 40 m = 2,i
                  bsum = 0.0D0
                  mm1 = m - 1
                  DO 30 j = 1,mm1
                      mmj = m - j
                      bsum = bsum + (j*r-mmj)*a0(j)*b0(mmj)
   30             CONTINUE
                  b0(m) = r*a0(m) + bsum/m
   40         CONTINUE
              c(i) = b0(i)/ (i+1.0D0)
C
              dsum = 0.0D0
              im1 = i - 1
              DO 50 j = 1,im1
                  imj = i - j
                  dsum = dsum + d(imj)*c(j)
   50         CONTINUE
              d(i) = - (dsum+c(i))
   60     CONTINUE
C
          j0 = e1*znm1 + (n-1.0D0)*j0
          j1 = e1*zn + n*j1
          znm1 = z2*znm1
          zn = z2*zn
          w = w0*w
          t0 = d(n)*w*j0
          w = w0*w
          t1 = d(np1)*w*j1
          sum = sum + (t0+t1)
          IF ((abs(t0)+abs(t1)).LE.eps*sum) GO TO 80
   70 CONTINUE
C
   80 u = exp(-bcorr(a,b))
      basym = e0*t*u*sum
      RETURN

      END


SUBROUTINE FlexEFT_simple
use bio_MOD
implicit none
integer :: k
real    :: Qs,QN, mu0hat,V0hat, aI, RMchl
real    :: VNhat
real    :: A0hat,fA,larg1,larg
real    :: W_Y,ThetaHat,SI,mu0hatSI,muIhat,par_
real    :: Lno3, Ep, Ez, zetaN, zetaChl
real    :: NO3, PHY, ZOO, DET
real    :: pp_PN
real    :: ZINT,fV,muNet
real, external :: WAPR

Ep     = params(iEp)
Ez     = params(iEz)
zetaN  = params(izetaN)
zetaChl= params(izetaChl)

DO k=nlev,1,-1    ! k cannot be reversed
   DET  = Vars(iDET,k)
   NO3  = Vars(iNO3,k)
   PHY  = Vars(iPHY(1),k)
   ZOO  = Vars(iZOO,k)  !Zooplankton biomass

   ! Check whether in the MLD or not
   if (k .lt. N_MLD) then
      par_ = PAR(k)
   else
      par_ = PARavg
   endif

! Phytoplankton section:
   tf_p = TEMPBOL(Ep,Temp(k))
   Qs   = params(iQ0N)/2d0
 mu0hat = dtdays*tf_p*mu0
  V0hat = dtdays*tf_p*V0N
  ! Initial slope of P-I curve
  aI    = dtdays*params(iaI0)
  ! Cost of photosynthesis
  RMchl  = tf_p*RMchl0*dtdays
  ! Threshold irradiance and RMchl is set temperature dependent
  I_zero = zetaChl*RMchl/aI

!Define VNhat: the saturation function of ambient nutrient concentration
  SELECTCASE(nutrient_uptake)
  ! case 1: Classic Michaelis Menton
    case(1)
  ! Potential maximal nutrient-limited uptake
      ! Half-saturation constant of nitrate uptake
      VNhat  = V0hat*NO3/(NO3 + params(iKN))

 ! case 2: optimal uptake based on Pahlow (2005) and Smith et al. (2009)
    case(2)
      A0hat = dtdays*tf_p*params(iA0N)
      !Define fA
      fA    = 1D0/(1D0 + sqrt(A0hat*NO3/V0hat) )
      VNhat = (1D0-fA)*V0hat*fA*A0hat*NO3/((1D0-fA)*V0hat+fA*A0hat*NO3)
    case default
     write(6,*) 'Error: Incorrect option for nutrient uptake!'
     stop
  ENDSELECT

! Calculate thetahat (optimal g Chl/mol C for the chloroplast under nutrient replete conditions)
! Only calculate within the euphotic zone, otherwise many numerical problems.
  if( par_ .gt. (I_zero+.1) ) then
    larg1 = exp(1d0 + aI*par_/(mu0hat*zetaChl))
    larg  = (1d0 + RMchl/mu0hat)*larg1
     W_Y  = WAPR(larg)
   ThetaHat = 1d0/zetaChl + (1d0- W_Y)*mu0hat/(aI * par_)

    ! Effect of light limitation
    SI = 1d0 - max(exp(-aI * par_ * ThetaHat/mu0hat),0d0)
    Varout(oSI(1),k) = SI
! Light dependent growth rate
! (needs to take into account the cost of dark and light-dependent chl maintenance)
    mu0hatSI = mu0hat*SI !Gross specific carbon uptake (photosynthesis)
    muIhat   = mu0hatSI-(mu0hatSI+RMchl)*zetaChl*ThetaHat ! Net specific carbon uptake
    muIhat   = max(muIhat,0d0)

    ZINT   = Qs*(muIhat/VNhat + zetaN)

    fV = (-1d0 + sqrt(1d0 + 1d0/ZINT))*Qs*muIhat/VNhat
    fV = max(fV,0.01)

    else
    ! Under the conditions of no light:
    !   ThetaHat = 1d-2  !  a small positive value
       ZINT     = Qs*zetaN
       muIhat   = 0d0
       Varout(oSI(1),k) = 0d0
    endif
      ! Nutrient limitation index:
     Lno3 =1d0/(1d0 + sqrt(1D0 +1D0/ZINT))

     Varout(oLno3(1),k) = Lno3
     ! Optimal nutrient quota:
     QN   = Qs/Lno3
     Varout(oQN(1),k)   = QN

     if (par_ .gt. (I_zero+.1)) then
   !Net growth rate (d-1) of phytoplankton at the average size
       muNet = muIhat*(1d0-2d0*Lno3)  !Droop model
   !Chl:C ratio [ g chl / mol C ] of the whole cell
       Varout(oTheta(1),k) = ThetaHat*(1D0-fV-Qs/QN)

     else
       muNet = 0d0
      !Chl:C ratio [ g chl / mol C ] of the whole cell
       Varout(oTheta(1),k) =  Varout(oTheta(1),k+1)
     endif

   !Save net growth rate
    Varout(omuNet(1),k) = muNet/dtdays

   !Phytoplankton sinking rate at the average size
   ! Varout(ow_p(1),  k) = abs(w_p0)  !Positive
!---------------------------------------------------------------
!! ZOOplankton section:
   tf_z = TEMPBOL(Ez,Temp(k))

 ! The grazing dependence on total prey (dimensionless)
   gbar = grazing(grazing_formulation,params(ikp),PHY)
 !Zooplankton total ingestion rate
   INGES = tf_z*dtdays*params(igmax)*gbar

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

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

! Grazing rate on PHY(specific to N-based Phy biomass, unit: d-1)

   ! Calculate the specific grazing rate for PHY
   Varout(oGraz(1),k) = INGES*ZOO/PHY/dtdays

   Varout(oPHY(1),k)  = PHY*(1d0+muNet)/(1d0 + INGES*ZOO/PHY)
!!End of zooplankton section
!=============================================================
!! Solve ODE functions:
  Zmort = ZOO*ZOO*dtdays*params(imz)*tf_z  !Mortality term for ZOO

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

  Varout(oDET,k) = (DET+pp_DZ)/(1d0 + dtdays * params(irDN)*tf_z)
  Varout(oNO3,k) = (NO3+pp_ND+pp_NZ)/(1d0+pp_PN/NO3)

  Varout(oZOO,k) = (ZOO+pp_ZP)/(1d0   &
                 + EGES+ZOO*dtdays*params(imz)*tf_z+RES)

  Varout(oZ2N,k) = pp_NZ/dtdays
  Varout(oD2N,k) = pp_ND/dtdays
  Varout(oPPt,k) = pp_PN/dtdays/QN
  Varout(oCHLt,k)= Vars(iPHY(1),k)/Varout(oQN(1),k)*Varout(oTheta(1),k)
ENDDO
End subroutine FlexEFT_simple