*> \brief \b DSTEBZ
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DSTEBZ + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E,
*                          M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK,
*                          INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          ORDER, RANGE
*       INTEGER            IL, INFO, IU, M, N, NSPLIT
*       DOUBLE PRECISION   ABSTOL, VL, VU
*       ..
*       .. Array Arguments ..
*       INTEGER            IBLOCK( * ), ISPLIT( * ), IWORK( * )
*       DOUBLE PRECISION   D( * ), E( * ), W( * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DSTEBZ computes the eigenvalues of a symmetric tridiagonal
*> matrix T.  The user may ask for all eigenvalues, all eigenvalues
*> in the half-open interval (VL, VU], or the IL-th through IU-th
*> eigenvalues.
*>
*> To avoid overflow, the matrix must be scaled so that its
*> largest element is no greater than overflow**(1/2) * underflow**(1/4) in absolute value, and for greatest
*> accuracy, it should not be much smaller than that.
*>
*> See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
*> Matrix", Report CS41, Computer Science Dept., Stanford
*> University, July 21, 1966.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] RANGE
*> \verbatim
*>          RANGE is CHARACTER*1
*>          = 'A': ("All")   all eigenvalues will be found.
*>          = 'V': ("Value") all eigenvalues in the half-open interval
*>                           (VL, VU] will be found.
*>          = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
*>                           entire matrix) will be found.
*> \endverbatim
*>
*> \param[in] ORDER
*> \verbatim
*>          ORDER is CHARACTER*1
*>          = 'B': ("By Block") the eigenvalues will be grouped by
*>                              split-off block (see IBLOCK, ISPLIT) and
*>                              ordered from smallest to largest within
*>                              the block.
*>          = 'E': ("Entire matrix")
*>                              the eigenvalues for the entire matrix
*>                              will be ordered from smallest to
*>                              largest.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the tridiagonal matrix T.  N >= 0.
*> \endverbatim
*>
*> \param[in] VL
*> \verbatim
*>          VL is DOUBLE PRECISION
*>
*>          If RANGE='V', the lower bound of the interval to
*>          be searched for eigenvalues.  Eigenvalues less than or equal
*>          to VL, or greater than VU, will not be returned.  VL < VU.
*>          Not referenced if RANGE = 'A' or 'I'.
*> \endverbatim
*>
*> \param[in] VU
*> \verbatim
*>          VU is DOUBLE PRECISION
*>
*>          If RANGE='V', the upper bound of the interval to
*>          be searched for eigenvalues.  Eigenvalues less than or equal
*>          to VL, or greater than VU, will not be returned.  VL < VU.
*>          Not referenced if RANGE = 'A' or 'I'.
*> \endverbatim
*>
*> \param[in] IL
*> \verbatim
*>          IL is INTEGER
*>
*>          If RANGE='I', the index of the
*>          smallest eigenvalue to be returned.
*>          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
*>          Not referenced if RANGE = 'A' or 'V'.
*> \endverbatim
*>
*> \param[in] IU
*> \verbatim
*>          IU is INTEGER
*>
*>          If RANGE='I', the index of the
*>          largest eigenvalue to be returned.
*>          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
*>          Not referenced if RANGE = 'A' or 'V'.
*> \endverbatim
*>
*> \param[in] ABSTOL
*> \verbatim
*>          ABSTOL is DOUBLE PRECISION
*>          The absolute tolerance for the eigenvalues.  An eigenvalue
*>          (or cluster) is considered to be located if it has been
*>          determined to lie in an interval whose width is ABSTOL or
*>          less.  If ABSTOL is less than or equal to zero, then ULP*|T|
*>          will be used, where |T| means the 1-norm of T.
*>
*>          Eigenvalues will be computed most accurately when ABSTOL is
*>          set to twice the underflow threshold 2*DLAMCH('S'), not zero.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*>          D is DOUBLE PRECISION array, dimension (N)
*>          The n diagonal elements of the tridiagonal matrix T.
*> \endverbatim
*>
*> \param[in] E
*> \verbatim
*>          E is DOUBLE PRECISION array, dimension (N-1)
*>          The (n-1) off-diagonal elements of the tridiagonal matrix T.
*> \endverbatim
*>
*> \param[out] M
*> \verbatim
*>          M is INTEGER
*>          The actual number of eigenvalues found. 0 <= M <= N.
*>          (See also the description of INFO=2,3.)
*> \endverbatim
*>
*> \param[out] NSPLIT
*> \verbatim
*>          NSPLIT is INTEGER
*>          The number of diagonal blocks in the matrix T.
*>          1 <= NSPLIT <= N.
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*>          W is DOUBLE PRECISION array, dimension (N)
*>          On exit, the first M elements of W will contain the
*>          eigenvalues.  (DSTEBZ may use the remaining N-M elements as
*>          workspace.)
*> \endverbatim
*>
*> \param[out] IBLOCK
*> \verbatim
*>          IBLOCK is INTEGER array, dimension (N)
*>          At each row/column j where E(j) is zero or small, the
*>          matrix T is considered to split into a block diagonal
*>          matrix.  On exit, if INFO = 0, IBLOCK(i) specifies to which
*>          block (from 1 to the number of blocks) the eigenvalue W(i)
*>          belongs.  (DSTEBZ may use the remaining N-M elements as
*>          workspace.)
*> \endverbatim
*>
*> \param[out] ISPLIT
*> \verbatim
*>          ISPLIT is INTEGER array, dimension (N)
*>          The splitting points, at which T breaks up into submatrices.
*>          The first submatrix consists of rows/columns 1 to ISPLIT(1),
*>          the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
*>          etc., and the NSPLIT-th consists of rows/columns
*>          ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
*>          (Only the first NSPLIT elements will actually be used, but
*>          since the user cannot know a priori what value NSPLIT will
*>          have, N words must be reserved for ISPLIT.)
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is DOUBLE PRECISION array, dimension (4*N)
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*>          IWORK is INTEGER array, dimension (3*N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*>          > 0:  some or all of the eigenvalues failed to converge or
*>                were not computed:
*>                =1 or 3: Bisection failed to converge for some
*>                        eigenvalues; these eigenvalues are flagged by a
*>                        negative block number.  The effect is that the
*>                        eigenvalues may not be as accurate as the
*>                        absolute and relative tolerances.  This is
*>                        generally caused by unexpectedly inaccurate
*>                        arithmetic.
*>                =2 or 3: RANGE='I' only: Not all of the eigenvalues
*>                        IL:IU were found.
*>                        Effect: M < IU+1-IL
*>                        Cause:  non-monotonic arithmetic, causing the
*>                                Sturm sequence to be non-monotonic.
*>                        Cure:   recalculate, using RANGE='A', and pick
*>                                out eigenvalues IL:IU.  In some cases,
*>                                increasing the PARAMETER "FUDGE" may
*>                                make things work.
*>                = 4:    RANGE='I', and the Gershgorin interval
*>                        initially used was too small.  No eigenvalues
*>                        were computed.
*>                        Probable cause: your machine has sloppy
*>                                        floating-point arithmetic.
*>                        Cure: Increase the PARAMETER "FUDGE",
*>                              recompile, and try again.
*> \endverbatim
*
*> \par Internal Parameters:
*  =========================
*>
*> \verbatim
*>  RELFAC  DOUBLE PRECISION, default = 2.0e0
*>          The relative tolerance.  An interval (a,b] lies within
*>          "relative tolerance" if  b-a < RELFAC*ulp*max(|a|,|b|),
*>          where "ulp" is the machine precision (distance from 1 to
*>          the next larger floating point number.)
*>
*>  FUDGE   DOUBLE PRECISION, default = 2
*>          A "fudge factor" to widen the Gershgorin intervals.  Ideally,
*>          a value of 1 should work, but on machines with sloppy
*>          arithmetic, this needs to be larger.  The default for
*>          publicly released versions should be large enough to handle
*>          the worst machine around.  Note that this has no effect
*>          on accuracy of the solution.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2016
*
*> \ingroup auxOTHERcomputational
*
*  =====================================================================
      SUBROUTINE DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E,
     $                   M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK,
     $                   INFO )
*
*  -- LAPACK computational routine (version 3.6.1) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     June 2016
*
*     .. Scalar Arguments ..
      CHARACTER          ORDER, RANGE
      INTEGER            IL, INFO, IU, M, N, NSPLIT
      DOUBLE PRECISION   ABSTOL, VL, VU
*     ..
*     .. Array Arguments ..
      INTEGER            IBLOCK( * ), ISPLIT( * ), IWORK( * )
      DOUBLE PRECISION   D( * ), E( * ), W( * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO, HALF
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
     $                   HALF = 1.0D0 / TWO )
      DOUBLE PRECISION   FUDGE, RELFAC
      PARAMETER          ( FUDGE = 2.1D0, RELFAC = 2.0D0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            NCNVRG, TOOFEW
      INTEGER            IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO,
     $                   IM, IN, IOFF, IORDER, IOUT, IRANGE, ITMAX,
     $                   ITMP1, IW, IWOFF, J, JB, JDISC, JE, NB, NWL,
     $                   NWU
      DOUBLE PRECISION   ATOLI, BNORM, GL, GU, PIVMIN, RTOLI, SAFEMN,
     $                   TMP1, TMP2, TNORM, ULP, WKILL, WL, WLU, WU, WUL
*     ..
*     .. Local Arrays ..
      INTEGER            IDUMMA( 1 )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, ILAENV, DLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLAEBZ, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, INT, LOG, MAX, MIN, SQRT
*     ..
*     .. Executable Statements ..
*
      INFO = 0
*
*     Decode RANGE
*
      IF( LSAME( RANGE, 'A' ) ) THEN
         IRANGE = 1
      ELSE IF( LSAME( RANGE, 'V' ) ) THEN
         IRANGE = 2
      ELSE IF( LSAME( RANGE, 'I' ) ) THEN
         IRANGE = 3
      ELSE
         IRANGE = 0
      END IF
*
*     Decode ORDER
*
      IF( LSAME( ORDER, 'B' ) ) THEN
         IORDER = 2
      ELSE IF( LSAME( ORDER, 'E' ) ) THEN
         IORDER = 1
      ELSE
         IORDER = 0
      END IF
*
*     Check for Errors
*
      IF( IRANGE.LE.0 ) THEN
         INFO = -1
      ELSE IF( IORDER.LE.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( IRANGE.EQ.2 ) THEN
         IF( VL.GE.VU )
     $      INFO = -5
      ELSE IF( IRANGE.EQ.3 .AND. ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) )
     $          THEN
         INFO = -6
      ELSE IF( IRANGE.EQ.3 .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) )
     $          THEN
         INFO = -7
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSTEBZ', -INFO )
         RETURN
      END IF
*
*     Initialize error flags
*
      INFO = 0
      NCNVRG = .FALSE.
      TOOFEW = .FALSE.
*
*     Quick return if possible
*
      M = 0
      IF( N.EQ.0 )
     $   RETURN
*
*     Simplifications:
*
      IF( IRANGE.EQ.3 .AND. IL.EQ.1 .AND. IU.EQ.N )
     $   IRANGE = 1
*
*     Get machine constants
*     NB is the minimum vector length for vector bisection, or 0
*     if only scalar is to be done.
*
      SAFEMN = DLAMCH( 'S' )
      ULP = DLAMCH( 'P' )
      RTOLI = ULP*RELFAC
      NB = ILAENV( 1, 'DSTEBZ', ' ', N, -1, -1, -1 )
      IF( NB.LE.1 )
     $   NB = 0
*
*     Special Case when N=1
*
      IF( N.EQ.1 ) THEN
         NSPLIT = 1
         ISPLIT( 1 ) = 1
         IF( IRANGE.EQ.2 .AND. ( VL.GE.D( 1 ) .OR. VU.LT.D( 1 ) ) ) THEN
            M = 0
         ELSE
            W( 1 ) = D( 1 )
            IBLOCK( 1 ) = 1
            M = 1
         END IF
         RETURN
      END IF
*
*     Compute Splitting Points
*
      NSPLIT = 1
      WORK( N ) = ZERO
      PIVMIN = ONE
*
      DO 10 J = 2, N
         TMP1 = E( J-1 )**2
         IF( ABS( D( J )*D( J-1 ) )*ULP**2+SAFEMN.GT.TMP1 ) THEN
            ISPLIT( NSPLIT ) = J - 1
            NSPLIT = NSPLIT + 1
            WORK( J-1 ) = ZERO
         ELSE
            WORK( J-1 ) = TMP1
            PIVMIN = MAX( PIVMIN, TMP1 )
         END IF
   10 CONTINUE
      ISPLIT( NSPLIT ) = N
      PIVMIN = PIVMIN*SAFEMN
*
*     Compute Interval and ATOLI
*
      IF( IRANGE.EQ.3 ) THEN
*
*        RANGE='I': Compute the interval containing eigenvalues
*                   IL through IU.
*
*        Compute Gershgorin interval for entire (split) matrix
*        and use it as the initial interval
*
         GU = D( 1 )
         GL = D( 1 )
         TMP1 = ZERO
*
         DO 20 J = 1, N - 1
            TMP2 = SQRT( WORK( J ) )
            GU = MAX( GU, D( J )+TMP1+TMP2 )
            GL = MIN( GL, D( J )-TMP1-TMP2 )
            TMP1 = TMP2
   20    CONTINUE
*
         GU = MAX( GU, D( N )+TMP1 )
         GL = MIN( GL, D( N )-TMP1 )
         TNORM = MAX( ABS( GL ), ABS( GU ) )
         GL = GL - FUDGE*TNORM*ULP*N - FUDGE*TWO*PIVMIN
         GU = GU + FUDGE*TNORM*ULP*N + FUDGE*PIVMIN
*
*        Compute Iteration parameters
*
         ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) /
     $           LOG( TWO ) ) + 2
         IF( ABSTOL.LE.ZERO ) THEN
            ATOLI = ULP*TNORM
         ELSE
            ATOLI = ABSTOL
         END IF
*
         WORK( N+1 ) = GL
         WORK( N+2 ) = GL
         WORK( N+3 ) = GU
         WORK( N+4 ) = GU
         WORK( N+5 ) = GL
         WORK( N+6 ) = GU
         IWORK( 1 ) = -1
         IWORK( 2 ) = -1
         IWORK( 3 ) = N + 1
         IWORK( 4 ) = N + 1
         IWORK( 5 ) = IL - 1
         IWORK( 6 ) = IU
*
         CALL DLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN, D, E,
     $                WORK, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT,
     $                IWORK, W, IBLOCK, IINFO )
*
         IF( IWORK( 6 ).EQ.IU ) THEN
            WL = WORK( N+1 )
            WLU = WORK( N+3 )
            NWL = IWORK( 1 )
            WU = WORK( N+4 )
            WUL = WORK( N+2 )
            NWU = IWORK( 4 )
         ELSE
            WL = WORK( N+2 )
            WLU = WORK( N+4 )
            NWL = IWORK( 2 )
            WU = WORK( N+3 )
            WUL = WORK( N+1 )
            NWU = IWORK( 3 )
         END IF
*
         IF( NWL.LT.0 .OR. NWL.GE.N .OR. NWU.LT.1 .OR. NWU.GT.N ) THEN
            INFO = 4
            RETURN
         END IF
      ELSE
*
*        RANGE='A' or 'V' -- Set ATOLI
*
         TNORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ),
     $           ABS( D( N ) )+ABS( E( N-1 ) ) )
*
         DO 30 J = 2, N - 1
            TNORM = MAX( TNORM, ABS( D( J ) )+ABS( E( J-1 ) )+
     $              ABS( E( J ) ) )
   30    CONTINUE
*
         IF( ABSTOL.LE.ZERO ) THEN
            ATOLI = ULP*TNORM
         ELSE
            ATOLI = ABSTOL
         END IF
*
         IF( IRANGE.EQ.2 ) THEN
            WL = VL
            WU = VU
         ELSE
            WL = ZERO
            WU = ZERO
         END IF
      END IF
*
*     Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU.
*     NWL accumulates the number of eigenvalues .le. WL,
*     NWU accumulates the number of eigenvalues .le. WU
*
      M = 0
      IEND = 0
      INFO = 0
      NWL = 0
      NWU = 0
*
      DO 70 JB = 1, NSPLIT
         IOFF = IEND
         IBEGIN = IOFF + 1
         IEND = ISPLIT( JB )
         IN = IEND - IOFF
*
         IF( IN.EQ.1 ) THEN
*
*           Special Case -- IN=1
*
            IF( IRANGE.EQ.1 .OR. WL.GE.D( IBEGIN )-PIVMIN )
     $         NWL = NWL + 1
            IF( IRANGE.EQ.1 .OR. WU.GE.D( IBEGIN )-PIVMIN )
     $         NWU = NWU + 1
            IF( IRANGE.EQ.1 .OR. ( WL.LT.D( IBEGIN )-PIVMIN .AND. WU.GE.
     $          D( IBEGIN )-PIVMIN ) ) THEN
               M = M + 1
               W( M ) = D( IBEGIN )
               IBLOCK( M ) = JB
            END IF
         ELSE
*
*           General Case -- IN > 1
*
*           Compute Gershgorin Interval
*           and use it as the initial interval
*
            GU = D( IBEGIN )
            GL = D( IBEGIN )
            TMP1 = ZERO
*
            DO 40 J = IBEGIN, IEND - 1
               TMP2 = ABS( E( J ) )
               GU = MAX( GU, D( J )+TMP1+TMP2 )
               GL = MIN( GL, D( J )-TMP1-TMP2 )
               TMP1 = TMP2
   40       CONTINUE
*
            GU = MAX( GU, D( IEND )+TMP1 )
            GL = MIN( GL, D( IEND )-TMP1 )
            BNORM = MAX( ABS( GL ), ABS( GU ) )
            GL = GL - FUDGE*BNORM*ULP*IN - FUDGE*PIVMIN
            GU = GU + FUDGE*BNORM*ULP*IN + FUDGE*PIVMIN
*
*           Compute ATOLI for the current submatrix
*
            IF( ABSTOL.LE.ZERO ) THEN
               ATOLI = ULP*MAX( ABS( GL ), ABS( GU ) )
            ELSE
               ATOLI = ABSTOL
            END IF
*
            IF( IRANGE.GT.1 ) THEN
               IF( GU.LT.WL ) THEN
                  NWL = NWL + IN
                  NWU = NWU + IN
                  GO TO 70
               END IF
               GL = MAX( GL, WL )
               GU = MIN( GU, WU )
               IF( GL.GE.GU )
     $            GO TO 70
            END IF
*
*           Set Up Initial Interval
*
            WORK( N+1 ) = GL
            WORK( N+IN+1 ) = GU
            CALL DLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
     $                   D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ),
     $                   IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM,
     $                   IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
*
            NWL = NWL + IWORK( 1 )
            NWU = NWU + IWORK( IN+1 )
            IWOFF = M - IWORK( 1 )
*
*           Compute Eigenvalues
*
            ITMAX = INT( ( LOG( GU-GL+PIVMIN )-LOG( PIVMIN ) ) /
     $              LOG( TWO ) ) + 2
            CALL DLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
     $                   D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ),
     $                   IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT,
     $                   IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
*
*           Copy Eigenvalues Into W and IBLOCK
*           Use -JB for block number for unconverged eigenvalues.
*
            DO 60 J = 1, IOUT
               TMP1 = HALF*( WORK( J+N )+WORK( J+IN+N ) )
*
*              Flag non-convergence.
*
               IF( J.GT.IOUT-IINFO ) THEN
                  NCNVRG = .TRUE.
                  IB = -JB
               ELSE
                  IB = JB
               END IF
               DO 50 JE = IWORK( J ) + 1 + IWOFF,
     $                 IWORK( J+IN ) + IWOFF
                  W( JE ) = TMP1
                  IBLOCK( JE ) = IB
   50          CONTINUE
   60       CONTINUE
*
            M = M + IM
         END IF
   70 CONTINUE
*
*     If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU
*     If NWL+1 < IL or NWU > IU, discard extra eigenvalues.
*
      IF( IRANGE.EQ.3 ) THEN
         IM = 0
         IDISCL = IL - 1 - NWL
         IDISCU = NWU - IU
*
         IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN
            DO 80 JE = 1, M
               IF( W( JE ).LE.WLU .AND. IDISCL.GT.0 ) THEN
                  IDISCL = IDISCL - 1
               ELSE IF( W( JE ).GE.WUL .AND. IDISCU.GT.0 ) THEN
                  IDISCU = IDISCU - 1
               ELSE
                  IM = IM + 1
                  W( IM ) = W( JE )
                  IBLOCK( IM ) = IBLOCK( JE )
               END IF
   80       CONTINUE
            M = IM
         END IF
         IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN
*
*           Code to deal with effects of bad arithmetic:
*           Some low eigenvalues to be discarded are not in (WL,WLU],
*           or high eigenvalues to be discarded are not in (WUL,WU]
*           so just kill off the smallest IDISCL/largest IDISCU
*           eigenvalues, by simply finding the smallest/largest
*           eigenvalue(s).
*
*           (If N(w) is monotone non-decreasing, this should never
*               happen.)
*
            IF( IDISCL.GT.0 ) THEN
               WKILL = WU
               DO 100 JDISC = 1, IDISCL
                  IW = 0
                  DO 90 JE = 1, M
                     IF( IBLOCK( JE ).NE.0 .AND.
     $                   ( W( JE ).LT.WKILL .OR. IW.EQ.0 ) ) THEN
                        IW = JE
                        WKILL = W( JE )
                     END IF
   90             CONTINUE
                  IBLOCK( IW ) = 0
  100          CONTINUE
            END IF
            IF( IDISCU.GT.0 ) THEN
*
               WKILL = WL
               DO 120 JDISC = 1, IDISCU
                  IW = 0
                  DO 110 JE = 1, M
                     IF( IBLOCK( JE ).NE.0 .AND.
     $                   ( W( JE ).GT.WKILL .OR. IW.EQ.0 ) ) THEN
                        IW = JE
                        WKILL = W( JE )
                     END IF
  110             CONTINUE
                  IBLOCK( IW ) = 0
  120          CONTINUE
            END IF
            IM = 0
            DO 130 JE = 1, M
               IF( IBLOCK( JE ).NE.0 ) THEN
                  IM = IM + 1
                  W( IM ) = W( JE )
                  IBLOCK( IM ) = IBLOCK( JE )
               END IF
  130       CONTINUE
            M = IM
         END IF
         IF( IDISCL.LT.0 .OR. IDISCU.LT.0 ) THEN
            TOOFEW = .TRUE.
         END IF
      END IF
*
*     If ORDER='B', do nothing -- the eigenvalues are already sorted
*        by block.
*     If ORDER='E', sort the eigenvalues from smallest to largest
*
      IF( IORDER.EQ.1 .AND. NSPLIT.GT.1 ) THEN
         DO 150 JE = 1, M - 1
            IE = 0
            TMP1 = W( JE )
            DO 140 J = JE + 1, M
               IF( W( J ).LT.TMP1 ) THEN
                  IE = J
                  TMP1 = W( J )
               END IF
  140       CONTINUE
*
            IF( IE.NE.0 ) THEN
               ITMP1 = IBLOCK( IE )
               W( IE ) = W( JE )
               IBLOCK( IE ) = IBLOCK( JE )
               W( JE ) = TMP1
               IBLOCK( JE ) = ITMP1
            END IF
  150    CONTINUE
      END IF
*
      INFO = 0
      IF( NCNVRG )
     $   INFO = INFO + 1
      IF( TOOFEW )
     $   INFO = INFO + 2
      RETURN
*
*     End of DSTEBZ
*
      END


ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c $Id: spectral_tools_fcyl.f 41 2009-11-19 02:52:24Z marques $
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine coef(dr1,dz1,cx01,cx03,cz01,cz02,cz03,cz11,cz12,cz13,
     &                nr,nz)
      implicit none
      integer nz,nr,i
      real*8 dz1(0:nz,0:nz),dr1(0:nr,0:nr,2)
      real*8 cx01(2),cx03(1:nr,2),cz01,cz02,cz03(1:nz-1),
     $     cz11,cz12,cz13(1:nz-1),d

c     El 2 es para el par y el 1 para el impar
      cx01(2)=1d0/dr1(0,0,2)
      cx01(1)=1d0/dr1(0,0,1)
      do i=1,nr
         cx03(i,2)=-dr1(0,i,2)/dr1(0,0,2)
         cx03(i,1)=-dr1(0,i,1)/dr1(0,0,1)
      enddo

      d=dz1(nz,nz)*dz1(0,0)-dz1(0,nz)*dz1(nz,0)
      cz01=dz1(nz,nz)/d
      cz02=-dz1(0,nz)/d
      do i=1,nz-1
         cz03(i)=(dz1(0,nz)*dz1(nz,i)-dz1(nz,nz)*dz1(0,i))/d
      enddo

      cz11=-dz1(nz,0)/d
      cz12=dz1(0,0)/d
      do i=1,nz-1
         cz13(i)=(dz1(nz,0)*dz1(0,i)-dz1(0,0)*dz1(nz,i))/d
      enddo

      return
      end subroutine coef

c=======================================================================

      subroutine deriv(dx1,dz1,dx2,dz2,dr1,dr2,lap,M,x,z,r,ri,riq,nr,nz)
      implicit none
      integer nr,nx,nz
      real*8 dx1(0:2*nr+1,0:2*nr+1),dz1(0:nz,0:nz),dr1(0:nr,0:nr,2),
     $       dx2(0:2*nr+1,0:2*nr+1),dz2(0:nz,0:nz),dr2(0:nr,0:nr,2),
     $       lap(0:nr,0:nr,2), M(0:nr,0:nr,2)
      real*8 pi,x(0:2*nr+1),cx(0:2*nr+1),z(0:nz),cz(0:nz)
      real*8 r(0:nr), ri(0:nr), riq(0:nr), sign
      integer i,j

      nx=2*nr+1
      pi=dacos(-1d0)

***********************************************************************
*     X                                                               *
***********************************************************************

      do i=0,nx
         x(i)=dcos(pi*dfloat(i)/dfloat(nx))
      enddo
      do i=0,nr
         r(i)=dcos(pi*dfloat(i)/dfloat(nx))
         ri(i)=1d0/r(i)
         riq(i)=ri(i)**2d0
      enddo

      cx(0)=2d0
      cx(nx)=2d0
      do i=1,nx-1
         cx(i)=1d0
      enddo

      sign=1d0
      do j=0,nx
         do i=0,nx
            if(i.ne.j) then
              dx1(i,j)=cx(i)*sign/(cx(j)*(x(i)-x(j)))
            endif
            sign=-sign
         enddo
         if(mod(nx,2).ne.0) sign=-sign
      enddo

      dx1(0,0)=(2d0*nx*nx+1d0)/6.d0
      dx1(nx,nx)=-(2d0*nx*nx+1d0)/6.d0
      do i=1,nx-1
         dx1(i,i)=-x(i)/(2.0d0*(1d0-x(i)*x(i)))
      enddo

***************************

      sign=-1d0
      do j=0,nx
         do i=1,nx-1
            if(i.ne.j) then
              dx2(i,j)=sign*(x(i)*x(i)+x(i)*x(j)-2d0)/
     $             (cx(j)*(1d0-x(i)**2d0)*(x(i)-x(j))**2)
            endif
            sign=-sign
         enddo
         if(mod(nx,2).ne.0) sign=-sign
      enddo

      dx2(0,0)=(nx**4-1d0)/15.d0
      dx2(nx,nx)=(nx**4-1d0)/15.d0
      do i=1,nx-1
         dx2(i,i)=-((nx*nx-1d0)*(1d0-x(i)**2d0)+3.d0)/
     $        (3.d0*(1d0-x(i)**2d0)**2)
      enddo

      sign=-1d0
      do j=1,nx
         dx2(0,j)=sign*2d0*((2d0*nx*nx+1d0)*(1d0-x(j))-6.d0)/
     $        (3.d0*cx(j)*(1d0-x(j))**2)
         sign=-sign
      enddo

      sign=1d0
      if(mod(nx,2).ne.0) sign=-1d0
      do j=0,nx-1
         dx2(nx,j)=sign*2d0*((2d0*nx*nx+1d0)*(1d0+x(j))-6.d0)/
     $        (3.d0*cx(j)*(1d0+x(j))**2)
         sign=-sign
      enddo

      do j=0,nr
         do i=0,nr
            dr1(i,j,2)=dx1(i,j)+dx1(i,nx-j)
            dr2(i,j,2)=dx2(i,j)+dx2(i,nx-j)
            dr1(i,j,1)=dx1(i,j)-dx1(i,nx-j)
            dr2(i,j,1)=dx2(i,j)-dx2(i,nx-j)
            lap(i,j,2)=dr2(i,j,2)+ri(i)*dr1(i,j,2)
            lap(i,j,1)=dr2(i,j,1)+ri(i)*dr1(i,j,1)
         enddo
      enddo

***********************************************************************
*     Z                                                               *
***********************************************************************

      do i=0,nz
         z(i)=dcos(pi*dfloat(i)/dfloat(nz))
      enddo

      cz(0)=2d0
      cz(nz)=2d0
      do i=1,nz-1
         cz(i)=1d0
      enddo

      sign=1d0
      do j=0,nz
         do i=0,nz
            if(i.ne.j) then
              dz1(i,j)=cz(i)*sign/(cz(j)*(z(i)-z(j)))
            endif
            sign=-sign
         enddo
         if(mod(nz,2).ne.0) sign=-sign
      enddo

      dz1(0,0)=(2d0*nz*nz+1d0)/6.d0
      dz1(nz,nz)=-(2d0*nz*nz+1d0)/6.d0
      do i=1,nz-1
         dz1(i,i)=-z(i)/(2.0d0*(1d0-z(i)**2d0))
      enddo

***************************

      sign=-1d0
      do j=0,nz
         do i=1,nz-1
            if(i.ne.j) then
              dz2(i,j)=sign*(z(i)*z(i)+z(i)*z(j)-2d0)/
     $             (cz(j)*(1d0-z(i)**2d0)*(z(i)-z(j))**2)
            endif
            sign=-sign
         enddo
         if(mod(nz,2).ne.0) sign=-sign
      enddo

      dz2(0,0)=(nz**4-1d0)/15.d0
      dz2(nz,nz)=(nz**4-1d0)/15.d0
      do i=1,nz-1
         dz2(i,i)=-((nz*nz-1d0)*(1d0-z(i)**2d0)+3.d0)/
     $        (3.d0*(1d0-z(i)**2d0)**2)
      enddo

      sign=-1d0
      do j=1,nz
         dz2(0,j)=sign*2d0*((2d0*nz*nz+1d0)*(1d0-z(j))-6.d0)/
     $        (3.d0*cz(j)*(1d0-z(j))**2)
         sign=-sign
      enddo

      sign=1d0
      if(mod(nz,2).ne.0) sign=-1d0
      do j=0,nz-1
         dz2(nz,j)=sign*2d0*((2d0*nz*nz+1d0)*(1d0+z(j))-6.d0)/
     $        (3.d0*cz(j)*(1d0+z(j))**2)
         sign=-sign
      enddo

***********************************************************************
*     Matrix M for Boundary Condition at the top                      *
***********************************************************************

      do j=0,nr
        do i=0,nr
          M(i,j,1) = dr2(i,j,1) + dr1(i,j,1)/r(i) - 1d0/r(i)**2d0
          M(i,j,2) = dr2(i,j,2) + dr1(i,j,2)/r(i) - 1d0/r(i)**2d0
        enddo
      enddo

      return
      end subroutine deriv

c=======================================================================
c Se hace la derivada radial de cada modo de Fourier, se indica la paridad
c a partir de los valores de k y l.
c Si in1=1 y in2=2, empieza por modo cero impar y sigue n=1 par.......
c Si in1=2 y in2=1, empieza por modo cero par y sigue n=1 impar.......

      subroutine derivr(f,f3,in1,in2,dr1,RAD,nr,nz,nn)
      implicit none
      integer nr,nz,nn,nr1,nz1
      REAL*8 dr1(0:nr,0:nr,2)
      REAL*8 RAD,alpha,f(0:nr,0:nz,0:nn-1),f3(0:nr,0:nz,0:nn-1)
      INTEGER in(2),n,j,k,nk,in1,in2

      nr1=nr+1 ; nz1=nz+1
      alpha=1d0/RAD
      in(1)=in1 ; in(2)=in2

c     Hacemos n=0
      call DGEMM('N','N',nr1,nz1,nr1,alpha,dr1(0,0,in(1)),nr1,
     $           f(0,0,0),nr1,0.d0,f3(0,0,0),nr1)
      j=in(1)
      in(1)=in(2)
      in(2)=j

c     Hacemos los otros n
!$OMP PARALLEL
!$OMP+SHARED(alpha,dr1,in,f,f3,nn,nr1,nz1)
!$OMP+PRIVATE(n,k,nk,j)
!$OMP DO
      do n=1,nn-3,2
         do k=0,1
            nk=n+k
            call DGEMM('N','N',nr1,nz1,nr1,alpha,dr1(0,0,in(1)),nr1,
     $           f(0,0,nk),nr1,0.d0,f3(0,0,nk),nr1)
         enddo
         j=in(1)
         in(1)=in(2)
         in(2)=j
      enddo
!$OMP END DO
!$OMP END PARALLEL
c     Hacemos el nn/2 -1 (solo hay uno)
      nk=nn-1
      call DGEMM('N','N',nr1,nz1,nr1,alpha,dr1(0,0,in(1)),nr1,
     $     f(0,0,nk),nr1,0.d0,f3(0,0,nk),nr1)

      return
      end subroutine derivr

c=======================================================================

      subroutine mdiag(work,dz2,lap,riq,axd,vxd,bxd,azd,vzd,bzd,axn,
     &     vxn,bxn,azn,vzn,bzn,cx03,cz03,cz13,nr,nz,nn,nmax)
      implicit none
      integer nr,nz,nn,nmax
      real*8 dz2(0:nz,0:nz),lap(0:nr,0:nr,2),riq(0:nr)
      real*8 dxd(1:nr,1:nr),dxn(1:nr,1:nr),aux1(1:nr)
      real*8 dzd(1:nz-1,1:nz-1),dzn(1:nz-1,1:nz-1),aux2(1:nz-1)
      real*8 axd(1:nr,1:nr,0:nn/2+1),vxd(1:nr,0:nn/2+1),
     $     bxd(1:nr,1:nr,0:nn/2+1),axn(1:nr,1:nr,0:nn/2+1),
     $     vxn(1:nr,0:nn/2+1),bxn(1:nr,1:nr,0:nn/2+1),
     $     azd(1:nz-1,1:nz-1),vzd(1:nz-1),bzd(1:nz-1,1:nz-1),
     $     azn(1:nz-1,1:nz-1),vzn(1:nz-1),bzn(1:nz-1,1:nz-1)
      real*8 cx03(1:nr,2),cz03(1:nz-1),cz13(1:nz-1)
      integer index(nmax), LWORK
      real*8 WORK(1:(nmax+2)*6)
      integer i,j,n,nnq
      integer INFO,IPIV(nmax)

      LWORK=(nmax+2)*6

      do n=0,nn/2+1
         nnq=n*n

****************************************************************************
*     axd  vxd  bxd  r(dirichlet)                                          *
****************************************************************************
         if(mod(n,2).ne.0) then
            do i=1,nr
               do j=1,nr
                  dxd(i,j)=lap(i,j,1)
               enddo
               dxd(i,i)=dxd(i,i)-dfloat(nnq)*riq(i)
            enddo
         else
            do i=1,nr
               do j=1,nr
                  dxd(i,j)=lap(i,j,2)
               enddo
               dxd(i,i)=dxd(i,i)-dfloat(nnq)*riq(i)
            enddo
         endif
         call DGEEV('N','V',nr,dxd,nr,vxd(1,n),aux1,bxd(1,1,n),nr,
     $        axd(1,1,n),nr,WORK,LWORK,INFO)
         do i=1,nr
            index(i)=i
         enddo
         call SHELL(vxd(1,n),nr,index,nmax)
         do i=1,nr
            do j=1,nr
               dxd(i,j)=axd(i,index(nr+1-j),n)
            enddo
         enddo
         do i=1,nr
            do j=1,nr
               axd(i,j,n)=dxd(i,j)
            enddo
         enddo
         do i=1,nr
            aux1(i)=vxd(nr+1-i,n)
         enddo
         do i=1,nr
            vxd(i,n)=aux1(i)
         enddo
         do i=1,nr
            do j=1,nr
               bxd(i,j,n)=0
            enddo
         enddo
         do i=1,nr
            bxd(i,i,n)=1d0
         enddo
         do i=1,nr
            do j=1,nr
               dxd(i,j)=axd(i,j,n)
            enddo
         enddo
         call DGESV(nr,nr,dxd,nr,IPIV,bxd(1,1,n),nr,INFO)

*******************************************************************************
*     axn  vxn  bxn  r(newmann)                                               *
*******************************************************************************
         if(mod(n,2).ne.0) then
            do i=1,nr
               do j=1,nr
                  dxn(i,j)=lap(i,j,1)+lap(i,0,1)*cx03(j,1)
               enddo
               dxn(i,i)=dxn(i,i)-dfloat(nnq)*riq(i)
            enddo
         else
            do i=1,nr
               do j=1,nr
                  dxn(i,j)=lap(i,j,2)+lap(i,0,2)*cx03(j,2)
               enddo
               dxn(i,i)=dxn(i,i)-dfloat(nnq)*riq(i)
            enddo
         endif
         call DGEEV('N','V',nr,dxn,nr,vxn(1,n),aux1,bxn(1,1,n),nr,
     $        axn(1,1,n),nr,WORK,LWORK,INFO)
         do i=1,nr
            index(i)=i
         enddo
         call SHELL(vxn(1,n),nr,index,nmax)
         do i=1,nr
            do j=1,nr
               dxn(i,j)=axn(i,index(nr+1-j),n)
            enddo
         enddo
         do i=1,nr
            do j=1,nr
               axn(i,j,n)=dxn(i,j)
            enddo
         enddo
         do i=1,nr
            aux1(i)=vxn(nr+1-i,n)
         enddo
         do i=1,nr
            vxn(i,n)=aux1(i)
         enddo
         do i=1,nr
            do j=1,nr
               bxn(i,j,n)=0
            enddo
         enddo
         do i=1,nr
            bxn(i,i,n)=1d0
         enddo
         do i=1,nr
            do j=1,nr
               dxn(i,j)=axn(i,j,n)
            enddo
         enddo
         call DGESV(nr,nr,dxn,nr,IPIV,bxn(1,1,n),nr,INFO)
      enddo

***********************************************************************
*     azd  vzd  bzd     z (dirichlet)
***********************************************************************
      do i=1,nz-1
         do j=1,nz-1
            dzd(i,j)=dz2(i,j)
         enddo
      enddo
      call DGEEV('N','V',nz-1,dzd,nz-1,vzd,aux2,bzd,nz-1,azd,nz-1,
     $     WORK,LWORK,INFO)
      do i=1,nz-1
         index(i)=i
      enddo
      call SHELL(vzd,nz-1,index,nmax)
      do i=1,nz-1
         do j=1,nz-1
            dzd(i,j)=azd(i,index(nz-j))
         enddo
      enddo
      do i=1,nz-1
         do j=1,nz-1
            azd(i,j)=dzd(i,j)
         enddo
      enddo
      do i=1,nz-1
         aux2(i)=vzd(nz-i)
      enddo
      do i=1,nz-1
         vzd(i)=aux2(i)
      enddo
      do i=1,nz-1
         do j=1,nz-1
            bzd(i,j)=0
         enddo
      enddo
      do i=1,nz-1
         bzd(i,i)=1d0
      enddo
      do i=1,nz-1
         do j=1,nz-1
            dzd(i,j)=azd(i,j)
         enddo
      enddo
      call DGESV(nz-1,nz-1,dzd,nz-1,IPIV,bzd,nz-1,INFO)

**********************************************************************
*     azn  vzn  bzn            z (newmann)
***********************************************************************
      do i=1,nz-1
         do j=1,nz-1
            dzn(i,j)=dz2(i,j)+dz2(i,0)*cz03(j)+dz2(i,nz)*cz13(j)
         enddo
      enddo
      call DGEEV('N','V',nz-1,dzn,nz-1,vzn,aux2,bzn,nz-1,azn,nz-1,
     $     WORK,LWORK,INFO)
      do i=1,nz-1
         index(i)=i
      enddo
      call SHELL(vzn,nz-1,index,nmax)
      do i=1,nz-1
         do j=1,nz-1
            dzn(i,j)=azn(i,index(nz-j))
         enddo
      enddo
      do i=1,nz-1
         do j=1,nz-1
            azn(i,j)=dzn(i,j)
         enddo
      enddo
      do i=1,nz-1
         aux2(i)=vzn(nz-i)
      enddo
      do i=1,nz-1
         vzn(i)=aux2(i)
      enddo
      do i=1,nz-1
         do j=1,nz-1
            bzn(i,j)=0
         enddo
      enddo
      do i=1,nz-1
         bzn(i,i)=1d0
      enddo
      do i=1,nz-1
         do j=1,nz-1
            dzn(i,j)=azn(i,j)
         enddo
      enddo
      call DGESV(nz-1,nz-1,dzn,nz-1,IPIV,bzn,nz-1,INFO)
      return
      end subroutine mdiag

c=======================================================================

      subroutine shell(arr,n,index,nmax)
      implicit none
      integer nmax
      real*8 arr(nmax),t,aln2i,tiny
      integer index(nmax),i,j,k,l,m,n,lognb2,nnn
      aln2i=1d0/log(2d0)
      tiny=1.d-5
      lognb2=int(alog(float(n))*aln2i+tiny)
      m=n
      do nnn=1,lognb2
         m=m/2
         k=n-m
         do j=1,k
            i=j
 3          continue
            l=i+m
            if(arr(l).lt.arr(i)) then
               t=arr(i)
               k=index(i)
               arr(i)=arr(l)
               index(i)=index(l)
               arr(l)=t
               index(l)=k
               i=i-m
               if(i.ge.1) goto 3
            endif
         enddo
      enddo
      return
      end subroutine shell

c=====================================================================
c     Computes the direct and inverse Fourier transforms for real
c     (u,w,T) and imaginary (v) variables

      subroutine transform(tdr,tir,tdi,tii,nn)
      implicit none
      integer nn,j,n,nd,nd1
      real*8  tdr(0:nn-1,0:nn-1),tdi(0:nn-1,0:nn-1)
      real*8  tir(0:nn-1,0:nn-1),tii(0:nn-1,0:nn-1)
      real*8  con,px,pnj,pi

      pi=dacos(-1d0)
      con=1d0/(dfloat(nn))
      px=2d0*pi*con
      do j=0,nn-1
         tdr(j,0)=1d0
         tir(0,j)=con
         tdi(j,0)=1d0
         tii(0,j)=con
      enddo
      do n=1,nn/2-1
         nd=2*n
         nd1=2*n-1
         do j=0,nn-1
            pnj=px*dfloat(n)*dfloat(j)
            tdr(j,nd1)=2d0*dcos(pnj)
            tdr(j,nd)=-2d0*dsin(pnj)
            tir(nd1,j)=con*dcos(pnj)
            tir(nd,j)=-con*dsin(pnj)
            tdi(j,nd1)=2d0*dsin(pnj)
            tdi(j,nd)=2d0*dcos(pnj)
            tii(nd1,j)=con*dsin(pnj)
            tii(nd,j)=con*dcos(pnj)
         enddo
      enddo
      do j=0,nn-1
         pnj=px*dfloat(nn/2)*dfloat(j)
         tdr(j,nn-1)=dcos(pnj)
         tir(nn-1,j)=con*dcos(pnj)
         tdi(j,nn-1)=dcos(pnj)
         tii(nn-1,j)=con*dcos(pnj)
      enddo
      return
      end subroutine transform

c=======================================================================
c     Poisson solver for the pressure (Neumann boundary conditions on
c     end plates and wall)
      subroutine poisp(a,f,f3,dz2,lap,axn,vxn,bxn,azn,vzn,bzn,RAD,ALT,
     &     cx01,cx03,cz01,cz02,cz03,cz11,cz12,cz13,nr,nz,nn)
      implicit none
      integer nr,nz,nn
      real*8 dz2(0:nz,0:nz),lap(0:nr,0:nr,2)
      real*8 axn(1:nr,1:nr,0:nn/2+1),vxn(1:nr,0:nn/2+1),
     $       bxn(1:nr,1:nr,0:nn/2+1),
     $       azn(1:nz-1,1:nz-1),vzn(1:nz-1),bzn(1:nz-1,1:nz-1)
      real*8 cx01(2),cx03(1:nr,2),cz01,cz02,cz03(1:nz-1),
     $       cz11,cz12,cz13(1:nz-1)
      real*8 RAD,ALT
      real*8 a,f(0:nr,0:nz,0:nn-1),f3(0:nr,0:nz,0:nn-1)
      real*8 t,al2,radq,ar,nmq
      real*8 h(1:nr,1:nz-1),w(1:nr,1:nz-1),aux(1:nr,1:nz-1)
      integer in(2),n,nm,i,j,k,l,s,nk

      ar=RAD/ALT
      radq=RAD*RAD
      al2=ar*ar

c     Rescale Chebyshev radial derivative on the boundary to be used in
c     an interval of length RAD
      do n=0,nn-1
         do j=1,nz-1
            f(0,j,n)=f(0,j,n)*RAD
         enddo
      enddo
c     Rescale Chebyshev axial derivative on the boundary to be used in
c     an interval of length ALT/2d0
      do n=0,nn-1
         do i=0,nr
            f(i,0,n)=f(i,0,n)*ALT/2d0
            f(i,nz,n)=f(i,nz,n)*ALT/2d0
         enddo
      enddo

c=======================================================================
c     n=0 mode: even in radial direction
      in(1)=2
      in(2)=1
      do i=1,nr
         do j=1,nz-1
            h(i,j)=f(i,j,0)*radq-
     $           lap(i,0,in(1))*cx01(in(1))*f(0,j,0)-
     $           4.d0*al2*(dz2(j,0)*(cz01*f(i,0,0)+cz02*f(i,nz,0))+
     $           dz2(j,nz)*(cz11*f(i,0,0)+cz12*f(i,nz,0)))
         enddo
      enddo
      call DGEMM('N','T',nr,nz-1,nz-1,1d0,h(1,1),nr,bzn(1,1),nz-1,0.d0
     $     ,aux(1,1),nr)
      call DGEMM('N','N',nr,nz-1,nr,1d0,bxn(1,1,0),nr,aux(1,1),nr,0.d0
     $     ,w(1,1),nr)
      do i=2,nr
         do s=1,nz-1
            t=1d0/(vxn(i,0)+4.d0*al2*vzn(s))
            w(i,s)=t*w(i,s)
         enddo
      enddo
      do s=2,nz-1
         t=1d0/(vxn(1,0)+4.d0*al2*vzn(s))
         w(1,s)=t*w(1,s)
      enddo
c     Compute w(1,1). Set value in (1,1)
      t=0.d0
      do i=2,nr
         do s=1,nz-1
            t=t+axn(1,i,0)*azn(1,s)*w(i,s)
         enddo
      enddo
      do s=2,nz-1
         t=t+axn(1,1,0)*azn(1,s)*w(1,s)
      enddo
      w(1,1)=(a-t)/(axn(1,1,0)*azn(1,1))

      call DGEMM('N','T',nr,nz-1,nz-1,1d0,w(1,1),nr,azn(1,1),nz-1,0.d0
     $     ,aux(1,1),nr)
      call DGEMM('N','N',nr,nz-1,nr,1d0,axn(1,1,0),nr,aux(1,1),nr,0.d0
     $     ,f3(1,1,0),nr+1)

c      Compute f on the boundaries

c     Wall
      do j=1,nz-1
         f3(0,j,0)=cx01(in(1))*f(0,j,0)
         do k=1,nr
            f3(0,j,0)=f3(0,j,0)+cx03(k,in(1))*f3(k,j,0)
         enddo
      enddo

c     Plates
      do i=0,nr
         f3(i,0,0)=cz01*f(i,0,0)+cz02*f(i,nz,0)
         f3(i,nz,0)=cz11*f(i,0,0)+cz12*f(i,nz,0)
         do l=1,nz-1
            f3(i,0,0)=f3(i,0,0)+cz03(l)*f3(i,l,0)
            f3(i,nz,0)=f3(i,nz,0)+cz13(l)*f3(i,l,0)
         enddo
      enddo
      j=in(1)
      in(1)=in(2)
      in(2)=j

c=======================================================================
c     n!=0 modes
      do n=1,nn-3,2
         nm=(n+1)/2
         nmq=dfloat(nm*nm)
         do k=0,1
            nk=n+k
            do i=1,nr
               do j=1,nz-1
                  h(i,j)=f(i,j,nk)*radq-
     $                 lap(i,0,in(1))*cx01(in(1))*f(0,j,nk) - 4.d0*al2*
     $                 (dz2(j,0)*(cz01*f(i,0,nk)+cz02*f(i,nz,nk))+
     $                 dz2(j,nz)*(cz11*f(i,0,nk)+cz12*f(i,nz,nk)))
               enddo
            enddo

            call DGEMM('N','T',nr,nz-1,nz-1,1d0,h(1,1),nr,
     $           bzn(1,1),nz-1,0.d0,aux(1,1),nr)
            call DGEMM('N','N',nr,nz-1,nr,1d0,bxn(1,1,nm),nr,
     $           aux(1,1),nr,0.d0,w(1,1),nr)

            do i=1,nr
               do s=1,nz-1
                  t=1d0/(vxn(i,nm)+4.d0*al2*vzn(s))
                  w(i,s)=t*w(i,s)
               enddo
            enddo

            call DGEMM('N','T',nr,nz-1,nz-1,1d0,w(1,1),nr,
     $           azn(1,1),nz-1,0.d0,aux(1,1),nr)
            call DGEMM('N','N',nr,nz-1,nr,1d0,axn(1,1,nm),nr,
     $           aux(1,1),nr,0.d0,f3(1,1,nk),nr+1)

c     Compute f on the boundaries

c     Wall
            do j=1,nz-1
               f3(0,j,nk)=cx01(in(1))*f(0,j,nk)
               do i=1,nr
                  f3(0,j,nk)=f3(0,j,nk)+cx03(i,in(1))*f3(i,j,nk)
               enddo
            enddo

c     Plates
            do i=0,nr
               f3(i,0,nk)=cz01*f(i,0,nk)+cz02*f(i,nz,nk)
               f3(i,nz,nk)=cz11*f(i,0,nk)+cz12*f(i,nz,nk)
               do l=1,nz-1
                  f3(i,0,nk)=f3(i,0,nk)+cz03(l)*f3(i,l,nk)
                  f3(i,nz,nk)=f3(i,nz,nk)+cz13(l)*f3(i,l,nk)
               enddo
            enddo

c     end of loop in k
         enddo
         j=in(1)
         in(1)=in(2)
         in(2)=j

c     end of loop in n
      enddo

c=======================================================================
c     n/2-1 mode
      nm=nn/2
      nmq=dfloat(nm*nm)
      nk=nn-1
      do i=1,nr
         do j=1,nz-1
            h(i,j)=f(i,j,nk)*radq-
     $           lap(i,0,in(1))*cx01(in(1))*f(0,j,nk) -
     $           4.d0*al2*(dz2(j,0)*(cz01*f(i,0,nk)+cz02*f(i,nz,nk))+
     $           dz2(j,nz)*(cz11*f(i,0,nk)+cz12*f(i,nz,nk)))
         enddo
      enddo

      call DGEMM('N','T',nr,nz-1,nz-1,1d0,h(1,1),nr,
     $            bzn(1,1),nz-1,0.d0,aux(1,1),nr)
      call DGEMM('N','N',nr,nz-1,nr,1d0,bxn(1,1,nm),nr,
     $            aux(1,1),nr,0.d0,w(1,1),nr)
      do i=1,nr
         do s=1,nz-1
            t=1d0/(vxn(i,nm)+4.d0*al2*vzn(s))
            w(i,s)=t*w(i,s)
         enddo
      enddo
      call DGEMM('N','T',nr,nz-1,nz-1,1d0,w(1,1),nr,
     $     azn(1,1),nz-1,0.d0,aux(1,1),nr)
      call DGEMM('N','N',nr,nz-1,nr,1d0,axn(1,1,nm),nr,
     $     aux(1,1),nr,0.d0,f3(1,1,nk),nr+1)

c     Compute of f on the boundaries

c     Wall
      do j=1,nz-1
         f3(0,j,nk)=cx01(in(1))*f(0,j,nk)
         do k=1,nr
            f3(0,j,nk)=f3(0,j,nk)+cx03(k,in(1))*f3(k,j,nk)
         enddo
      enddo
c     Plates
      do i=0,nr
         f3(i,0,nk)=cz01*f(i,0,nk)+cz02*f(i,nz,nk)
         f3(i,nz,nk)=cz11*f(i,0,nk)+cz12*f(i,nz,nk)
         do k=1,nz-1
            f3(i,0,nk)=f3(i,0,nk)+cz03(k)*f3(i,k,nk)
            f3(i,nz,nk)=f3(i,nz,nk)+cz13(k)*f3(i,k,nk)
         enddo
      enddo

      RETURN
      END subroutine poisp

c=======================================================================
c     Es el poisson de la temperatura para el cilindro vertical.
c     Condiciones de funcion conocida en las tapas i derivada normal en
c     el lateral

      SUBROUTINE POISTA(a,f,f3,dz2,lap,axn,vxn,bxn,azd,vzd,bzd,RAD,ALT,
     &     cx01,cx03,nr,nz,nn)
      implicit none
      integer nr,nz,nn
      real*8 dz2(0:nz,0:nz),lap(0:nr,0:nr,2)
      real*8 axn(1:nr,1:nr,0:nn/2+1),vzd(1:nz-1),bzd(1:nz-1,1:nz-1),
     &     vxn(1:nr,0:nn/2+1),bxn(1:nr,1:nr,0:nn/2+1),azd(1:nz-1,1:nz-1)
      real*8 cx01(2),cx03(1:nr,2),RAD,ALT,t,al2,radq,ar,nmq
      real*8 a,f(0:nr,0:nz,0:nn-1),f3(0:nr,0:nz,0:nn-1)
      real*8 h(1:nr,1:nz-1),w(1:nr,1:nz-1),aux(1:nr,1:nz-1)
      integer in(2),n,nm,i,j,k,s,nk
      ar=RAD/ALT
      radq=RAD*RAD
      al2=ar*ar

c     multiplicamos la derivada radial real en el contorno por RAD para que
c     sea la derivada chebyshev
      do n=0,nn-1
         do j=1,nz-1
            f(0,j,n)=f(0,j,n)*RAD
         enddo
      enddo
c     Hacemos el n=0 que es par en r
      in(1)=2
      in(2)=1
      do i=1,nr
         do j=1,nz-1
            h(i,j)=f(i,j,0)*radq-
     &           lap(i,0,in(1))*cx01(in(1))*f(0,j,0)-
     &           4.d0*al2*(dz2(j,0)*f(i,0,0)+dz2(j,nz)*f(i,nz,0))
         enddo
      enddo
      call DGEMM('N','T',nr,nz-1,nz-1,1d0,h(1,1),nr,
     &     bzd(1,1),nz-1,0.d0,aux(1,1),nr)
      call DGEMM('N','N',nr,nz-1,nr,1d0,bxn(1,1,0),nr,
     &     aux(1,1),nr,0.d0,w(1,1),nr)
      do i=1,nr
         do s=1,nz-1
            t=1d0/(vxn(i,0)+4.d0*al2*vzd(s)-a*radq)
            w(i,s)=t*w(i,s)
         enddo
      enddo

      call DGEMM('N','T',nr,nz-1,nz-1,1d0,w(1,1),nr,
     &     azd(1,1),nz-1,0.d0,aux(1,1),nr)
      call DGEMM('N','N',nr,nz-1,nr,1d0,axn(1,1,0),nr,
     &     aux(1,1),nr,0.d0,f3(1,1,0),nr+1)

C     CONTORN DE LA FUNCIO F

C     TAPES
      do i=0,nr
         f3(i,0,0)=f(i,0,0)
         f3(i,nz,0)=f(i,nz,0)
      enddo

C     LATERALS
      do j=1,nz-1
         f3(0,j,0)=cx01(in(1))*f(0,j,0)
         do k=1,nr
            f3(0,j,0)=f3(0,j,0)+cx03(k,in(1))*f3(k,j,0)
         enddo
      enddo
      j=in(1)
      in(1)=in(2)
      in(2)=j

c     Hacemos los otros n
      do n=1,nn-3,2
         nm=(n+1)/2
         nmq=dfloat(nm*nm)
         do k=0,1
            nk=n+k
            do i=1,nr
               do j=1,nz-1
                  h(i,j)=f(i,j,nk)*radq-
     &                 lap(i,0,in(1))*cx01(in(1))*f(0,j,nk) - 4.d0*al2*
     &                 (dz2(j,0)*f(i,0,nk)+dz2(j,nz)*f(i,nz,nk))
               enddo
            enddo

            call DGEMM('N','T',nr,nz-1,nz-1,1d0,h(1,1),nr,
     &           bzd(1,1),nz-1,0.d0,aux(1,1),nr)
            call DGEMM('N','N',nr,nz-1,nr,1d0,bxn(1,1,nm),nr,
     &           aux(1,1),nr,0.d0,w(1,1),nr)

            do i=1,nr
               do s=1,nz-1
                  t=1d0/(vxn(i,nm)+4.d0*al2*vzd(s)-a*radq)
                  w(i,s)=t*w(i,s)
               enddo
            enddo

            call DGEMM('N','T',nr,nz-1,nz-1,1d0,w(1,1),nr,
     &           azd(1,1),nz-1,0.d0,aux(1,1),nr)
            call DGEMM('N','N',nr,nz-1,nr,1d0,axn(1,1,nm),nr,
     &           aux(1,1),nr,0.d0,f3(1,1,nk),nr+1)

C     CONTORN DE LA FUNCIO F

C     TAPES
            do i=0,nr
               f3(i,0,nk)=f(i,0,nk)
               f3(i,nz,nk)=f(i,nz,nk)
            enddo

C     LATERALS
            do j=1,nz-1
               f3(0,j,nk)=cx01(in(1))*f(0,j,nk)
               do i=1,nr
                  f3(0,j,nk)=f3(0,j,nk)+cx03(i,in(1))*f3(i,j,nk)
               enddo
            enddo

c     cierro el do de k             *
         enddo
         j=in(1)
         in(1)=in(2)
         in(2)=j

c     cierro el do de n             *
      enddo

c     Hacemos el nn/2 -1 (solo hay uno)
      nm=nn/2
      nmq=dfloat(nm*nm)
      nk=nn-1
      do i=1,nr
         do j=1,nz-1
            h(i,j)=f(i,j,nk)*radq-
     &           lap(i,0,in(1))*cx01(in(1))*f(0,j,nk) -
     &           4.d0*al2*(dz2(j,0)*f(i,0,nk)+dz2(j,nz)*f(i,nz,nk))
         enddo
      enddo

      call DGEMM('N','T',nr,nz-1,nz-1,1d0,h(1,1),nr,
     &     bzd(1,1),nz-1,0.d0,aux(1,1),nr)
      call DGEMM('N','N',nr,nz-1,nr,1d0,bxn(1,1,nm),nr,
     &     aux(1,1),nr,0.d0,w(1,1),nr)

      do i=1,nr
         do s=1,nz-1
            t=1d0/(vxn(i,nm)+4.d0*al2*vzd(s)-a*radq)
            w(i,s)=t*w(i,s)
         enddo
      enddo
      call DGEMM('N','T',nr,nz-1,nz-1,1d0,w(1,1),nr,
     &     azd(1,1),nz-1,0.d0,aux(1,1),nr)
      call DGEMM('N','N',nr,nz-1,nr,1d0,axn(1,1,nm),nr,
     &     aux(1,1),nr,0.d0,f3(1,1,nk),nr+1)

C     CONTORN DE LA FUNCIO F

C     TAPES
      do i=0,nr
         f3(i,0,nk)=f(i,0,nk)
         f3(i,nz,nk)=f(i,nz,nk)
      enddo

C     LATERALS
      do j=1,nz-1
         f3(0,j,nk)=cx01(in(1))*f(0,j,nk)
         do k=1,nr
            f3(0,j,nk)=f3(0,j,nk)+cx03(k,in(1))*f3(k,j,nk)
         enddo
      enddo

      return
      end subroutine poista

c=======================================================================

c     Es el poisson de la temperatura para el cilindro vertical, Condiciones
c     de funcion conocida en las tapas y en el lateral

      SUBROUTINE POIST(a,f,f3,dz2,lap,axd,vxd,bxd,azd,vzd,bzd,RAD,ALT,
     &                 nr,nz,nn)
      implicit none
      integer nr,nz,nn
      REAL*8 dz2(0:nz,0:nz),lap(0:nr,0:nr,2)
      REAL*8 axd(1:nr,1:nr,0:nn/2+1),vxd(1:nr,0:nn/2+1),
     &     azd(1:nz-1,1:nz-1),bxd(1:nr,1:nr,0:nn/2+1),
     &     vzd(1:nz-1),bzd(1:nz-1,1:nz-1)
      REAL*8 RAD,ALT,t,al2,radq,ar
      REAL*8 a,f(0:nr,0:nz,0:nn-1),f3(0:nr,0:nz,0:nn-1)
      REAL*8 h(1:nr,1:nz-1),w(1:nr,1:nz-1),aux(1:nr,1:nz-1)
      INTEGER n,nm,i,j,k,s,nk
      ar=RAD/ALT
      radq=RAD*RAD
      al2=ar*ar

c     Hacemos el n=0 que es par en r

      do i=1,nr
         do j=1,nz-1
            h(i,j)=f(i,j,0)*radq-
     $           lap(i,0,2)*f(0,j,0)-
     $           4.d0*al2*(dz2(j,0)*f(i,0,0)+dz2(j,nz)*f(i,nz,0))
         enddo
      enddo

      call DGEMM('N','T',nr,nz-1,nz-1,1d0,h(1,1),nr,
     $     bzd(1,1),nz-1,0.d0,aux(1,1),nr)
      call DGEMM('N','N',nr,nz-1,nr,1d0,bxd(1,1,0),nr,
     $     aux(1,1),nr,0.d0,w(1,1),nr)

      do i=1,nr
         do s=1,nz-1
            t=1d0/(vxd(i,0)+4.d0*al2*vzd(s)-a*radq)
            w(i,s)=t*w(i,s)
         enddo
      enddo

      call DGEMM('N','T',nr,nz-1,nz-1,1d0,w(1,1),nr,
     $     azd(1,1),nz-1,0.d0,aux(1,1),nr)
      call DGEMM('N','N',nr,nz-1,nr,1d0,axd(1,1,0),nr,
     $     aux(1,1),nr,0.d0,f3(1,1,0),nr+1)

C     CONTORN DE LA FUNCIO F

C     TAPES
      do i=0,nr
         f3(i,0,0)=f(i,0,0)
         f3(i,nz,0)=f(i,nz,0)
      enddo

C     LATERALS
      do j=1,nz-1
         f3(0,j,0)=f(0,j,0)
      enddo

c     Hacemos los otros n
      do n=1,nn-3,2
         nm=(n+1)/2
         do k=0,1
            nk=n+k
            do i=1,nr
               do j=1,nz-1
                  h(i,j)=f(i,j,nk)*radq-
     $                 lap(i,0,1)*f(0,j,nk) - 4.d0*al2*
     $                 (dz2(j,0)*f(i,0,nk)+dz2(j,nz)*f(i,nz,nk))
               enddo
            enddo

            call DGEMM('N','T',nr,nz-1,nz-1,1d0,h(1,1),nr,
     $           bzd(1,1),nz-1,0.d0,aux(1,1),nr)
            call DGEMM('N','N',nr,nz-1,nr,1d0,bxd(1,1,nm),nr,
     $           aux(1,1),nr,0.d0,w(1,1),nr)

            do i=1,nr
               do s=1,nz-1
                  t=1d0/(vxd(i,nm)+4.d0*al2*vzd(s)-a*radq)
                  w(i,s)=t*w(i,s)
               enddo
            enddo

            call DGEMM('N','T',nr,nz-1,nz-1,1d0,w(1,1),nr,
     $           azd(1,1),nz-1,0.d0,aux(1,1),nr)
            call DGEMM('N','N',nr,nz-1,nr,1d0,axd(1,1,nm),nr,
     $           aux(1,1),nr,0.d0,f3(1,1,nk),nr+1)

C     CONTORN DE LA FUNCIO F

C     TAPES
            do i=0,nr
               f3(i,0,nk)=f(i,0,nk)
               f3(i,nz,nk)=f(i,nz,nk)
            enddo

C     LATERALS
            do j=1,nz-1
               f3(0,j,nk)=f(0,j,nk)
            enddo

c     cierro el do de k             *
         enddo

c     cierro el do de n             *
      enddo

c     Hacemos el nn/2 -1 (solo hay uno)
      nm=nn/2
      nk=nn-1
      do i=1,nr
         do j=1,nz-1
            h(i,j)=f(i,j,nk)*radq-
     $           lap(i,0,2)*f(0,j,nk) -
     $           4.d0*al2*(dz2(j,0)*f(i,0,nk)+dz2(j,nz)*f(i,nz,nk))
         enddo
      enddo

      call DGEMM('N','T',nr,nz-1,nz-1,1d0,h(1,1),nr,
     $     bzd(1,1),nz-1,0.d0,aux(1,1),nr)
      call DGEMM('N','N',nr,nz-1,nr,1d0,bxd(1,1,nm),nr,
     $     aux(1,1),nr,0.d0,w(1,1),nr)

      do i=1,nr
         do s=1,nz-1
            t=1d0/(vxd(i,nm)+4.d0*al2*vzd(s)-a*radq)
            w(i,s)=t*w(i,s)
         enddo
      enddo

      call DGEMM('N','T',nr,nz-1,nz-1,1d0,w(1,1),nr,
     $     azd(1,1),nz-1,0.d0,aux(1,1),nr)
      call DGEMM('N','N',nr,nz-1,nr,1d0,axd(1,1,nm),nr,
     $     aux(1,1),nr,0.d0,f3(1,1,nk),nr+1)

C     CONTORN DE LA FUNCIO F

C     TAPES
      do i=0,nr
         f3(i,0,nk)=f(i,0,nk)
         f3(i,nz,nk)=f(i,nz,nk)
      enddo

C     LATERALS
      do j=1,nz-1
         f3(0,j,nk)=f(0,j,nk)
      enddo

      RETURN
      END subroutine poist
c     Es el poisson de ur-iutheta para el cilindro vertical,
c     Equivale a hacer ur + utheta (reales e imaginarias). Condiciones
c     de funcion conocida en las tapas y en el lateral

c=======================================================================

      subroutine POISUL(a,f,f3,dz2,lap,axd,vxd,bxd,azd,vzd,bzd,RAD,ALT,
     &                  nr,nz,nn)
      IMPLICIT NONE
      INTEGER nr,nz,nn
      REAL*8 dz2(0:nz,0:nz),lap(0:nr,0:nr,2)
      REAL*8 axd(1:nr,1:nr,0:nn/2+1),vxd(1:nr,0:nn/2+1),
     &     azd(1:nz-1,1:nz-1),bxd(1:nr,1:nr,0:nn/2+1),
     &     vzd(1:nz-1),bzd(1:nz-1,1:nz-1)
      REAL*8 a,f(0:nr,0:nz,0:nn-1),f3(0:nr,0:nz,0:nn-1)
      REAL*8 RAD,ALT,t,al2,radq,ar,nmq
      REAL*8 h(1:nr,1:nz-1),w(1:nr,1:nz-1),aux(1:nr,1:nz-1)
      INTEGER in(2),n,nm,i,j,k,s,nk
      ar=RAD/ALT
      radq=RAD*RAD
      al2=ar*ar

c     Hacemos el n=0 que es impar en r
      in(1)=1
      in(2)=2
      do i=1,nr
         do j=1,nz-1
            h(i,j)=f(i,j,0)*radq-
     $           lap(i,0,in(1))*f(0,j,0)-
     $           4.d0*al2*(dz2(j,0)*f(i,0,0)+dz2(j,nz)*f(i,nz,0))
         enddo
      enddo

      call DGEMM('N','T',nr,nz-1,nz-1,1d0,h(1,1),nr,
     $     bzd(1,1),nz-1,0.d0,aux(1,1),nr)
      call DGEMM('N','N',nr,nz-1,nr,1d0,bxd(1,1,1),nr,
     $     aux(1,1),nr,0.d0,w(1,1),nr)

      do i=1,nr
         do s=1,nz-1
            t=1d0/(vxd(i,1)+4.d0*al2*vzd(s)-a*radq)
            w(i,s)=t*w(i,s)
         enddo
      enddo

      call DGEMM('N','T',nr,nz-1,nz-1,1d0,w(1,1),nr,
     $     azd(1,1),nz-1,0.d0,aux(1,1),nr)
      call DGEMM('N','N',nr,nz-1,nr,1d0,axd(1,1,1),nr,
     $     aux(1,1),nr,0.d0,f3(1,1,0),nr+1)

C     CONTORN DE LA FUNCIO F

C     TAPES
      do i=0,nr
         f3(i,0,0)=f(i,0,0)
         f3(i,nz,0)=f(i,nz,0)
      enddo

C     LATERALS
      do j=1,nz-1
         f3(0,j,0)=f(0,j,0)
      enddo
      j=in(1)
      in(1)=in(2)
      in(2)=j

c     Hacemos los otros n
      do n=1,nn-3,2
         nm=((n+1)/2)-1
         nmq=dfloat(nm*nm)
         do k=0,1
            nk=n+k
            do i=1,nr
               do j=1,nz-1
                  h(i,j)=f(i,j,nk)*radq-
     $                 lap(i,0,in(1))*f(0,j,nk) - 4.d0*al2*
     $                 (dz2(j,0)*f(i,0,nk)+dz2(j,nz)*f(i,nz,nk))
               enddo
            enddo

            call DGEMM('N','T',nr,nz-1,nz-1,1d0,h(1,1),nr,
     $           bzd(1,1),nz-1,0.d0,aux(1,1),nr)
            call DGEMM('N','N',nr,nz-1,nr,1d0,bxd(1,1,nm),nr,
     $           aux(1,1),nr,0.d0,w(1,1),nr)

            do i=1,nr
               do s=1,nz-1
                  t=1d0/(vxd(i,nm)+4.d0*al2*vzd(s)-a*radq)
                  w(i,s)=t*w(i,s)
               enddo
            enddo

            call DGEMM('N','T',nr,nz-1,nz-1,1d0,w(1,1),nr,
     $           azd(1,1),nz-1,0.d0,aux(1,1),nr)
            call DGEMM('N','N',nr,nz-1,nr,1d0,axd(1,1,nm),nr,
     $           aux(1,1),nr,0.d0,f3(1,1,nk),nr+1)

C     CONTORN DE LA FUNCIO F

C     TAPES
            do i=0,nr
               f3(i,0,nk)=f(i,0,nk)
               f3(i,nz,nk)=f(i,nz,nk)
            enddo

C     LATERALS
            do j=1,nz-1
               f3(0,j,nk)=f(0,j,nk)
            enddo

c     cierro el do de k             *
         enddo
         j=in(1)
         in(1)=in(2)
         in(2)=j

c     cierro el do de n             *
      enddo

c     Hacemos el nn/2  (solo hay uno)
      nm=(nn/2)-1
      nmq=dfloat(nm*nm)
      nk=nn-1
      do i=1,nr
         do j=1,nz-1
            h(i,j)=f(i,j,nk)*radq-
     $           lap(i,0,in(1))*f(0,j,nk) -
     $           4.d0*al2*(dz2(j,0)*f(i,0,nk)+dz2(j,nz)*f(i,nz,nk))
         enddo
      enddo

      call DGEMM('N','T',nr,nz-1,nz-1,1d0,h(1,1),nr,
     $     bzd(1,1),nz-1,0.d0,aux(1,1),nr)
      call DGEMM('N','N',nr,nz-1,nr,1d0,bxd(1,1,nm),nr,
     $     aux(1,1),nr,0.d0,w(1,1),nr)

      do i=1,nr
         do s=1,nz-1
            t=1d0/(vxd(i,nm)+4.d0*al2*vzd(s)-a*radq)
            w(i,s)=t*w(i,s)
         enddo
      enddo

      call DGEMM('N','T',nr,nz-1,nz-1,1d0,w(1,1),nr,
     $     azd(1,1),nz-1,0.d0,aux(1,1),nr)
      call DGEMM('N','N',nr,nz-1,nr,1d0,axd(1,1,nm),nr,
     $     aux(1,1),nr,0.d0,f3(1,1,nk),nr+1)

C     CONTORN DE LA FUNCIO F

C     TAPES
      do i=0,nr
         f3(i,0,nk)=f(i,0,nk)
         f3(i,nz,nk)=f(i,nz,nk)
      enddo

C     LATERALS
      do j=1,nz-1
         f3(0,j,nk)=f(0,j,nk)
      enddo

      RETURN
      END subroutine poisul
c     Es el poisson de ur+iutheta para el cilindro vertical,
c     Equivale a hacer ur -utheta (reales e imaginarias). Condiciones
c     de funcion conocida en las tapas y en el lateral

c=======================================================================

      subroutine poisup(a,f,f3,dz2,lap,axd,vxd,bxd,azd,vzd,bzd,RAD,ALT,
     &                  nr,nz,nn)
      implicit none
      integer nr,nz,nn
      real*8 dz2(0:nz,0:nz),lap(0:nr,0:nr,2)
      real*8 axd(1:nr,1:nr,0:nn/2+1),vxd(1:nr,0:nn/2+1),
     &     azd(1:nz-1,1:nz-1),bxd(1:nr,1:nr,0:nn/2+1),
     &     vzd(1:nz-1),bzd(1:nz-1,1:nz-1)
      real*8 RAD,ALT,t,al2,radq,ar,nmq
      real*8 a,f(0:nr,0:nz,0:nn-1),f3(0:nr,0:nz,0:nn-1)
      real*8 h(1:nr,1:nz-1),w(1:nr,1:nz-1),aux(1:nr,1:nz-1)
      integer in(2),n,nm,i,j,k,s,nk

      ar=RAD/ALT
      radq=RAD*RAD
      al2=ar*ar

c     Hacemos el n=0 que es impar en r
      in(1)=1
      in(2)=2
      do i=1,nr
         do j=1,nz-1
            h(i,j)=f(i,j,0)*radq-
     &           lap(i,0,in(1))*f(0,j,0)-
     &           4.d0*al2*(dz2(j,0)*f(i,0,0)+dz2(j,nz)*f(i,nz,0))
         enddo
      enddo

      call DGEMM('N','T',nr,nz-1,nz-1,1d0,h(1,1),nr,
     &     bzd(1,1),nz-1,0.d0,aux(1,1),nr)
      call DGEMM('N','N',nr,nz-1,nr,1d0,bxd(1,1,1),nr,
     &     aux(1,1),nr,0.d0,w(1,1),nr)

      do i=1,nr
         do s=1,nz-1
            t=1d0/(vxd(i,1)+4.d0*al2*vzd(s)-a*radq)
            w(i,s)=t*w(i,s)
         enddo
      enddo

      call DGEMM('N','T',nr,nz-1,nz-1,1d0,w(1,1),nr,
     &     azd(1,1),nz-1,0.d0,aux(1,1),nr)
      call DGEMM('N','N',nr,nz-1,nr,1d0,axd(1,1,1),nr,
     &     aux(1,1),nr,0.d0,f3(1,1,0),nr+1)

C     CONTORN DE LA FUNCIO F

C     TAPES
      do i=0,nr
         f3(i,0,0)=f(i,0,0)
         f3(i,nz,0)=f(i,nz,0)
      enddo

C     LATERALS
      do j=1,nz-1
         f3(0,j,0)=f(0,j,0)
      enddo
      j=in(1)
      in(1)=in(2)
      in(2)=j

c     Hacemos los otros n
      do n=1,nn-3,2
         nm=((n+1)/2)+1
         nmq=dfloat(nm*nm)
         do k=0,1
            nk=n+k
            do i=1,nr
               do j=1,nz-1
                  h(i,j)=f(i,j,nk)*radq-
     &                 lap(i,0,in(1))*f(0,j,nk) - 4.d0*al2*
     &                 (dz2(j,0)*f(i,0,nk)+dz2(j,nz)*f(i,nz,nk))
               enddo
            enddo

            call DGEMM('N','T',nr,nz-1,nz-1,1d0,h(1,1),nr,
     &           bzd(1,1),nz-1,0.d0,aux(1,1),nr)
            call DGEMM('N','N',nr,nz-1,nr,1d0,bxd(1,1,nm),nr,
     &           aux(1,1),nr,0.d0,w(1,1),nr)

            do i=1,nr
               do s=1,nz-1
                  t=1d0/(vxd(i,nm)+4.d0*al2*vzd(s)-a*radq)
                  w(i,s)=t*w(i,s)
               enddo
            enddo

            call DGEMM('N','T',nr,nz-1,nz-1,1d0,w(1,1),nr,
     &           azd(1,1),nz-1,0.d0,aux(1,1),nr)
            call DGEMM('N','N',nr,nz-1,nr,1d0,axd(1,1,nm),nr,
     &           aux(1,1),nr,0.d0,f3(1,1,nk),nr+1)

C     CONTORN DE LA FUNCIO F

C     TAPES
            do i=0,nr
               f3(i,0,nk)=f(i,0,nk)
               f3(i,nz,nk)=f(i,nz,nk)
            enddo

C     LATERALS
            do j=1,nz-1
               f3(0,j,nk)=f(0,j,nk)
            enddo

c     cierro el do de k             *
         enddo
         j=in(1)
         in(1)=in(2)
         in(2)=j

c     cierro el do de n             *
      enddo

c     Hacemos el nn/2 -1 (solo hay uno)
      nm=(nn/2)+1
      nmq=dfloat(nm*nm)
      nk=nn-1
      do i=1,nr
         do j=1,nz-1
            h(i,j)=f(i,j,nk)*radq-
     &           lap(i,0,in(1))*f(0,j,nk) -
     &           4.d0*al2*(dz2(j,0)*f(i,0,nk)+dz2(j,nz)*f(i,nz,nk))
         enddo
      enddo

      call DGEMM('N','T',nr,nz-1,nz-1,1d0,h(1,1),nr,
     &     bzd(1,1),nz-1,0.d0,aux(1,1),nr)
      call DGEMM('N','N',nr,nz-1,nr,1d0,bxd(1,1,nm),nr,
     &     aux(1,1),nr,0.d0,w(1,1),nr)

      do i=1,nr
         do s=1,nz-1
            t=1d0/(vxd(i,nm)+4.d0*al2*vzd(s)-a*radq)
            w(i,s)=t*w(i,s)
         enddo
      enddo

      call DGEMM('N','T',nr,nz-1,nz-1,1d0,w(1,1),nr,
     &     azd(1,1),nz-1,0.d0,aux(1,1),nr)
      call DGEMM('N','N',nr,nz-1,nr,1d0,axd(1,1,nm),nr,
     &     aux(1,1),nr,0.d0,f3(1,1,nk),nr+1)

C     CONTORN DE LA FUNCIO F

C     TAPES
      do i=0,nr
         f3(i,0,nk)=f(i,0,nk)
         f3(i,nz,nk)=f(i,nz,nk)
      enddo

C     LATERALS
      do j=1,nz-1
         f3(0,j,nk)=f(0,j,nk)
      enddo

      RETURN
      END subroutine poisup


!****************************************************************************************
! Purpose:
!   Perform spatial interpolation using kring (geostatistical method). These are
! transformations of the MATLAB code developed by Haruko Wainwright.
!
! Author:
!   Jinsong Chen and Haruko Wainwright
!   Lawrence Berkeley National Lab
!   Earth and Environmental Sciences Area
!   Berkeley, CA 94720
!
! Written: May of 2016
!
!----------------------------------------------------------------------------------------
! Copyright Notices:
!
! "Bayesian Integration of multiscale environmental data” Copyright (c) 2016, The Regents
! of the University of California, through Lawrence Berkeley National Laboratory (subject
! to receipt of any required approvals from the U.S. Dept. of Energy). All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification, are
! permitted provided that the following conditions are met:
!   (1) Redistributions of source code must retain the above copyright notice, this list
!       of conditions and the following disclaimer.
!   (2) Redistributions in binary form must reproduce the above copyright notice, this
!       list of conditions and the following disclaimer in the documentation and/or other
!       materials provided with the distribution.
!   (3) Neither the name of the University of California, Lawrence Berkeley National
!       Laboratory, U.S. Dept. of Energy nor the names of its contributors may be used
!       to endorse or promote products derived from this software without specific prior
!       written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY
! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
! OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT
! SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
! INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
! TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
! BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY
! WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
! You are under no obligation whatsoever to provide any bug fixes, patches, or upgrades
! to the features, functionality or performance of the source code ("Enhancements") to
! anyone; however, if you choose to make your Enhancements available either publicly, or
! directly to Lawrence Berkeley National Laboratory, without imposing a separate written
! license agreement for such Enhancements, then you hereby grant the following license:
! a non-exclusive, royalty-free perpetual license to install, use, modify, prepare
! derivative works, incorporate into other computer software, distribute, and sublicense
! such enhancements or derivative works thereof, in binary and source code form.
!****************************************************************************************
!
module class_Prior
  use class_Global
  use class_Subfun
  !
  implicit none
  !
  private
  !
  public :: Prior_Free, Prior_InputPara, Prior_CalcMeanCova
  !
  integer :: nx,ny !Domain size
  integer :: ngrid !Total # of grid points
  integer :: nobs  !Total # of walking survey points
  !
  real               :: dx,dy !discretization
  real               :: gmu   !overall mean values
  real, dimension(3) :: muvec,stdvec,varvec
  !
  real, dimension(:), allocatable    :: xloc
  real, dimension(:), allocatable    :: yloc
  real, dimension(:), allocatable    :: dose
  integer, dimension(:), allocatable :: landuse
  type(geoModel)                     :: gstat(3)  !Variogram model information
  !
contains
  !
  subroutine Prior_Free
  !
  ! Deallocate memory
  !
  if(allocated(xloc)) deallocate(xloc)
  if(allocated(yloc)) deallocate(yloc)
  if(allocated(dose)) deallocate(dose)
  if(allocated(landuse)) deallocate(landuse)
  end subroutine Prior_Free

  subroutine Prior_InputPara(grid,gmod,walkdata)
  type(gridDomain) :: grid     !Hold general grid information
  type(geoModel)   :: gmod(3)  !Variogram model information
  type(surveyData) :: walkdata !Walking survey data
  !
  ! Input domain, variogram models, and walking survey data
  !
  integer            :: ierr(6)
  integer, parameter :: locDebug=0
  !
  nx=grid%nx
  ny=grid%ny
  dx=grid%dx
  dy=grid%dy
  gmu=grid%gmean
  ngrid=nx*ny
  !
  ! Allocate memory
  !
  nobs=walkdata%num
  allocate(xloc(nobs),STAT=ierr(1))
  allocate(yloc(nobs),STAT=ierr(2))
  allocate(dose(nobs),STAT=ierr(3))
  allocate(landuse(nobs),STAT=ierr(4))
  if(any(ierr(1:4)>0)) then
    write(ilog,*) 'Prior_InputPara: Errors in allocating'
    stop
  endif
  gstat(1:3)=gmod(1:3)
  muvec(1:3)=walkdata%muvec(1:3)
  stdvec(1:3)=walkdata%stdvec(1:3)
  varvec(1:3)=walkdata%varvec(1:3)
  xloc(1:nobs)=walkdata%datamat(1:nobs,1)
  yloc(1:nobs)=walkdata%datamat(1:nobs,2)
  dose(1:nobs)=walkdata%datamat(1:nobs,3)
  landuse(1:nobs)=walkdata%landuse(1:nobs)
  end subroutine Prior_InputPara

  subroutine Prior_CalcMeanCova(lusemat,rtnmean,rtncova)
  integer, intent(in)         :: lusemat(:,:)
  real(kind=q), intent(inout) :: rtnmean(:)
  real(kind=q), intent(inout) :: rtncova(:,:)
  !
  ! Calculate mean and standard deviation using kring by conditioning
  ! to walking survey data.
  !
  type(geoModel) :: mymodel
  integer        :: i,j,k,ng,nw,ii,jj
  integer        :: ierr(10)
  real           :: start_time,end_time
  !
  integer, dimension(:), allocatable        :: myindex1,myindex2
  real(kind=q)                              :: distx,disty
  real(kind=q), dimension(:), allocatable   :: beta,tmpvec1,tmpvec2
  real(kind=q), dimension(:,:), allocatable :: S11,S21,S22,invS11
  real(kind=q), dimension(:,:), allocatable :: R11,R21,R22,invR11
  real(kind=q), dimension(:,:), allocatable :: tR21,tmpMat1,tmpMat2
  !
  integer, parameter :: locDebug=0
  !
  if(locDebug==1) then
    write(idbg,*) '***START of Prior_CalcMeanStd***'
    write(*,*) '***START of Prior_CalcMeanStd***'
  endif
  !
  allocate(S11(nobs,nobs),STAT=ierr(1))
  allocate(S21(ngrid,nobs),STAT=ierr(2))
  allocate(S22(ngrid,ngrid),STAT=ierr(3))
  if(any(ierr(1:3)>0)) then
    write(ilog,*) 'Prior_CalcMeanStd: Errors in allocating memory'
    stop
  endif
  !
  ! Initializing matrices with zero values
  !
  S11(1:nobs,1:nobs)=real(0.0,kind=q)
  S21(1:ngrid,1:nobs)=real(0.0,kind=q)
  S22(1:ngrid,1:ngrid)=real(0.0,kind=q)
  !
  ! Main loop for constructing S11, S21, and S22 matrices
  !
  if(locDebug==1) call CPU_Time(start_time)
  !
  do k=1,3
     ng=count(lusemat(:,3)==k)
     nw=count(landuse==k)
     !
     ! If no the given land-use type, it should not have observations of the type.
     ! If it does, there is inconsistency between input landuse-id and walking data.
     !
     if(ng==0) then
       if(nw>0) then
         write(ilog,*) 'Prior_CalcMeanCova: Landuse and observation types are inconsistent.'
         write(ilog,*) 'Please check and re-run.'
         stop
       else
         cycle
       endif
     endif
     !
     allocate(myindex1(nw),STAT=ierr(1))
     allocate(myindex2(ng),STAT=ierr(2))
     allocate(R11(nw,nw),STAT=ierr(3))
     allocate(R21(ng,nw),STAT=ierr(4))
     allocate(R22(ng,ng),STAT=ierr(5))
     allocate(tR21(nw,ng),STAT=ierr(6))
     allocate(tmpMat1(nw,ng),STAT=ierr(7))
     allocate(tmpMat2(ng,ng),STAT=ierr(8))
     allocate(invR11(nw,nw),STAT=ierr(9))
     if(any(ierr(1:9)>0)) then
       write(ilog,*) 'Prior_CalcMeanStd: Errors in allocating memory-1.'
       stop
     endif
     !
     ! Find indices for a given land-use type
     !
     call GetIndex(landuse,nobs,k,myindex1)       !In walking data points
     call GetIndex(lusemat(:,3),ngrid,k,myindex2) !In overall grids
     !
     ! Do conditioning
     !
     mymodel=gstat(k)
     do i=1,ng
     do j=1,ng
        ii=myindex2(i)
        jj=myindex2(j)
        distx=real((lusemat(ii,1)-lusemat(jj,1))*dx,kind=q)
        disty=real((lusemat(ii,2)-lusemat(jj,2))*dy,kind=q)
        !
        ! Consider nugget effects
        !
        R22(i,j)=CorrCoeff(distx,disty,mymodel)*real(1.0-mymodel%nugget,kind=q)
        if(i==j) R22(i,j)=R22(i,j)+real(mymodel%nugget,kind=q)
     enddo
     enddo
     !
     if(nw>0) then
       do i=1,nw
       do j=1,nw
          ii=myindex1(i)
          jj=myindex1(j)
          distx=real(xloc(ii)-xloc(jj),kind=q)
          disty=real(yloc(ii)-yloc(jj),kind=q)
          R11(i,j)=CorrCoeff(distx,disty,mymodel)*real(1.0-mymodel%nugget,kind=q)
          if(i==j) R11(i,j)=R11(i,j)+real(mymodel%nugget,kind=q)
          !
          ! Construct global S11 matrix
          !
          S11(ii,jj)=R11(i,j)*real(mymodel%variance,kind=q)
       enddo
       enddo
       !
       ! Do inversion
       !
       invR11(1:nw,1:nw)=R11(1:nw,1:nw)
       call Subfun_invert_pd_matrix_lapack2(invR11,nw,ierr(1))
       if(ierr(1)>0) then
         write(ilog,*) 'Prior_CalcMeanCova: Errors in inverting R11 matrix.'
         stop
       endif
       !
       ! Cross-covariance
       !
       do i=1,ng
       do j=1,nw
          ii=myindex2(i)
          jj=myindex1(j)
          distx=real((lusemat(ii,1)-1)*dx-xloc(jj),kind=q)
          disty=real((lusemat(ii,2)-1)*dy-yloc(jj),kind=q)
          R21(i,j)=CrossCorrCoeff(distx,disty,mymodel)
          S21(ii,jj)=R21(i,j)*real(mymodel%variance,kind=q)
       enddo
       enddo
       tR21(1:nw,1:ng)=transpose(R21)
       !
       ! Update R22 by conditioning to walking data whenthey are available
       !
       call Subfun_mklMatmul(nw,nw,ng,invR11,tR21,tmpMat1)
       call Subfun_mklMatmul(ng,nw,ng,R21,tmpMat1,tmpMat2)
       R22(1:ng,1:ng)=R22(1:ng,1:ng)-tmpMat2(1:ng,1:ng)
     endif
     !
     ! Construct global S22 matrix
     !
     do i=1,ng
     do j=1,ng
          ii=myindex2(i)
          jj=myindex2(j)
          S22(ii,jj)=R22(i,j)*real(mymodel%variance,kind=q)
     enddo
     enddo
     !
     ! Deallocate memory
     !
     if(allocated(myindex1)) deallocate(myindex1)
     if(allocated(myindex2)) deallocate(myindex2)
     if(allocated(R11)) deallocate(R11)
     if(allocated(R21)) deallocate(R21)
     if(allocated(R22)) deallocate(R22)
     if(allocated(invR11)) deallocate(invR11)
     if(allocated(tR21)) deallocate(tR21)
     if(allocated(tmpMat1)) deallocate(tmpMat1)
     if(allocated(tmpMat2)) deallocate(tmpMat2)
  enddo
  if(locDebug==1) then
    call CPU_Time(end_time)
    write(*,*) 'CPU time for S11, S21, and S22 matrices:',(end_time-start_time)
  endif
  !
  ! Calculate conditional mean and covariance
  !
  if(locDebug==1) call CPU_Time(start_time)
  !
  allocate(tmpvec1(nobs),STAT=ierr(1))
  allocate(tmpvec2(nobs),STAT=ierr(2))
  allocate(beta(ngrid),STAT=ierr(3))
  allocate(invS11(nobs,nobs),STAT=ierr(4))
  if(any(ierr(1:4)>0)) then
     write(ilog,*) 'Prior_CalcMeanStd: Errors in allocating memory-2.'
     stop
  endif
  !
  ! Assign walking data to the nearest grid points and compute the
  ! difference between measurements and overall mean.
  !
  beta(1:ngrid)=gmu  !Overall mean
  do i=1,nobs
     ii=floor(xloc(i)/dx)+1
     jj=floor(yloc(i)/dy)+1
     k=(ii-1)*ny+jj
     tmpvec1(i)=dose(i)-beta(k)
  enddo
  !
  ! Invert S11 matrix
  !
  invS11(1:nobs,1:nobs)=S11(1:nobs,1:nobs)
  call Subfun_invert_pd_matrix_lapack2(invS11,nobs,ierr(1))
  if(ierr(1)>0) then
     write(ilog,*) 'Prior_CalcMeanStd: Errors in inverting S11 matrix.'
     stop
  endif
  tmpvec2=matmul(invS11,tmpvec1)
  if(allocated(S11)) deallocate(S11)
  if(allocated(invS11)) deallocate(invS11)
  !
  ! Return conditional mean
  !
  if(nobs>0) then
    rtnmean(1:ngrid)=beta(1:ngrid)+matmul(S21,tmpvec2)
  else
    rtnmean(1:ngrid)=beta(1:ngrid)
  endif
  if(allocated(S21)) deallocate(S21)
  if(allocated(beta)) deallocate(beta)
  if(allocated(tmpvec1)) deallocate(tmpvec1)
  if(allocated(tmpvec2)) deallocate(tmpvec2)
  !
  ! Return conditional covariance
  !
  rtncova(1:ngrid,1:ngrid)=S22(1:ngrid,1:ngrid)
  !
  if(locDebug==1) then
    call CPU_Time(end_time)
    write(*,*) 'CPU time for conditional mean and covariance:',(end_time-start_time)
  endif
  !
  ! Output prior mean and std for debuging
  !
  if(locDebug==1) then
    open(22,file='prior_mean_std.out',action='Write',iostat=ierr(1))
    do i=1,ngrid
       write(22,*) real(rtnmean(i)),real(sqrt(S22(i,i)))
    enddo
    close(22)
  endif
  if(allocated(S22)) deallocate(S22)
  !
  if(locDebug==1) then
    write(*,*) '***END of Prior_CalcMeanCova***'
    write(idbg,*) '***END of Prior_CalcMeanCova***'
  endif
  end subroutine Prior_CalcMeanCova

  function CorrCoeff(distx,disty,mymodel) result(rtnval)
  real(kind=q), intent(in)   :: distx
  real(kind=q), intent(in)   :: disty
  type(geoModel), intent(in) :: mymodel
  real(kind=q)               :: rtnval
  !
  ! This function is just for correlation coefficient function calculation
  !
  real(kind=q) :: tmpx,tmpy,tmpdist
  !
  tmpx=distx/real(mymodel%crlengthx,kind=q)
  tmpy=disty/real(mymodel%crlengthy,kind=q)
  tmpdist=sqrt(tmpx*tmpx+tmpy*tmpy)
  rtnval=exp(-tmpdist)
  end function CorrCoeff

  function CrossCorrCoeff(distx,disty,mymodel) result(rtnval)
  real(kind=q), intent(in)   :: distx
  real(kind=q), intent(in)   :: disty
  type(geoModel), intent(in) :: mymodel
  real(kind=q)               :: rtnval
  !
  ! This function is just for cross-correlation coefficient function calculation
  !
  real(kind=q) :: tmpx,tmpy,tmpdist
  !
  tmpx=distx/real(mymodel%crlengthx,kind=q)
  tmpy=disty/real(mymodel%crlengthy,kind=q)
  tmpdist=sqrt(tmpx*tmpx+tmpy*tmpy)
  rtnval=exp(-tmpdist)*real(1.0-mymodel%nugget,kind=q)
  end function CrossCorrCoeff

  subroutine GetIndex(lusevec,ndim,landtype,rtnvec)
  integer, intent(in)    :: lusevec(:)
  integer, intent(in)    :: ndim
  integer, intent(in)    :: landtype
  integer, intent(inout) :: rtnvec(:)
  !
  integer :: i,k
  !
  k=1
  do i=1,ndim
     if(lusevec(i)==landtype) then
       rtnvec(k)=i
       k=k+1
     endif
  enddo
  end subroutine GetIndex
end module class_Prior


submodule(euler_interface_m) euler_prob_0010_m
    implicit none

contains

    module character(len=20) function euler0010()
        write (euler0010, "(i20)") answer(2000000_int64)
    end function euler0010

    function answer(n) result(ret)
        use euler_primes_m, only: sieve_of_Eratosthenes
        implicit none
        integer(int64), intent(in) :: n
        integer(int64) :: i, ret
        logical, allocatable :: is_prime(:)

        call sieve_of_Eratosthenes(n, is_prime)
        do i = 0_int64, n
            if (is_prime(i)) ret = ret + i
        end do
    end function answer
end submodule euler_prob_0010_m


#INCLUDE 'MR_H_ALIGN_PADDING.H'
!***********************************************************************************************************************************
! UNIT:
!
!  (MODULE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  MODULE MR_MOD_UPDT_HYD

    USE MR_KINDS

    USE MR_DEF_RANKS
    USE MR_DEF_CURVED_GEOS
    USE MR_DEF_CONSTS_N_REF_PARS
    USE MR_DEF_FIELD_VARS
    USE MR_DEF_ACTIVITY

    IMPLICIT NONE

    PRIVATE

    PUBLIC :: MR_UPDT_HYD
  ! PUBLIC :: MR_CALC_UVA , MR_CALC_W   ! JUST FOR TEST

    REAL   (CARD_KIND) , ALLOCATABLE , DIMENSION(:,:,:    ) :: ALFA , BETA

    REAL   (CARD_KIND) , ALLOCATABLE , DIMENSION(:,:      ) :: A1 , B1 , C1 , D1
    REAL   (CARD_KIND) , ALLOCATABLE , DIMENSION(:,:      ) :: A2 , B2 , C2 , D2

    REAL   (CARD_KIND) , ALLOCATABLE , DIMENSION(:,:,  :  ) :: HYD_A3 , HYD_B3 , HYD_C3
    REAL   (CARD_KIND) , ALLOCATABLE , DIMENSION(:,:,:,:  ) :: HYD_D3

!***********************************************************************************************************************************

  CONTAINS

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_UPDT_HYD

    USE MR_MOD_INTERP_XY

    USE MR_MOD_CALC_ALFA_N_BETA
    USE MR_MOD_CALC_A_B_C_D
    USE MR_MOD_CALC_HYD_A3_B3_C3_D3

    USE MR_MOD_TDMA
    USE MR_MOD_TDMA3

    IMPLICIT NONE

    INTEGER(IJID_KIND) :: I , J
    INTEGER            :: DIM
    INTEGER(KKID_KIND) :: K

    ALLOCATE( HYD_D3(1:NI1(NI,CARD_KIND),1:NJ,1:2,1:NK) )

      CALL MR_CALC_RAW_HYD_D3( NI , NJ , NK , HYD_D3 )

      ALLOCATE( ALFA(1:NI1(NI,CARD_KIND),1:NJ,1:2) , BETA(1:NI1(NI,CARD_KIND),1:NJ,1:2) )

       !BLOCK
        CALL MR_CALC_ALFA_N_BETA( NI , NJ , NK , HYD_D3 , ALFA , BETA )
      ! HYD_D3 WILL BE REVISED IN THIS CALL
       !END BLOCK

        ALLOCATE( D1(1:NI1(NI,CARD_KIND),1:NJ) )
          CALL MR_CALC_D1( NI , NJ , ZS , ALFA , BETA , D1 )
          ALLOCATE( A1(2:NI2(NI,CARD_KIND),1:NJ) ,   &
          & B1(1:NI1(NI,CARD_KIND),1:NJ  ) ,   &
          & C1(1:NI2(NI,CARD_KIND)-1,1:NJ) )
            CALL MR_CALC_A1_B1_C1( NI , NJ , ALFA , A1 , B1 , C1 )
           !BLOCK
            ZS = MR_TDMA1( NI , NJ , A1 , B1 , C1 , D1 )
           !END BLOCK
          DEALLOCATE( A1 , B1 , C1 )
        DEALLOCATE( D1 )

        ALLOCATE( D2(1:NI1(NI,CARD_KIND),1:NJ) )
          CALL MR_CALC_D2( NI , NJ , ZS , BETA , D2 )
          ALLOCATE( A2(1:NI1(NI,CARD_KIND),2:NJ) ,   &
          & B2(1:NI1(NI,CARD_KIND),1:NJ  ) ,   &
          & C2(1:NI1(NI,CARD_KIND),1:NJ-1) )
            CALL MR_CALC_A2_B2_C2( NI , NJ , ALFA , A2 , B2 , C2 )
           !BLOCK
            ZS = MR_TDMA2( NI , NJ , A2 , B2 , C2 , D2 )
           !END BLOCK
          DEALLOCATE( A2 , B2 , C2 )
        DEALLOCATE( D2 )

        CALL MR_INTERP_XY_SS_U( NI , NJ , ZS , ZSU )
        CALL MR_INTERP_XY_SS_V( NI , NJ , ZS , ZSV )

        CALL MR_INTERP_XY_UV_U_BY_RCPRAC( NI , NJ , ZS , ALFA , BETA , UA )
        CALL MR_INTERP_XY_UV_V_BY_RCPRAC( NI , NJ , ZS , ALFA , BETA , VA )

        CALL MR_CALC_UVA( NI , NJ , ZSU , ZSV , ALFA , BETA , UVA )

      DEALLOCATE( ALFA , BETA )

      ALLOCATE( HYD_A3(1:NI1(NI,CARD_KIND),1:NJ,2:NK) ,   &
      & HYD_B3(1:NI1(NI,CARD_KIND),1:NJ,1:NK  ) ,   &
      & HYD_C3(1:NI1(NI,CARD_KIND),1:NJ,1:NK-1) )
        CALL MR_CALC_HYD_A3_B3_C3( NI , NJ , NK , HYD_A3 , HYD_B3 , HYD_C3 )
       !BLOCK
        UV = MR_TDMA3_UV( NI , NJ , NK , HYD_A3 , HYD_B3 , HYD_C3 , HYD_D3 )
       !END BLOCK
      DEALLOCATE( HYD_A3 , HYD_B3 , HYD_C3 )

    DEALLOCATE( HYD_D3 )

    DO K = 1 , NK
      CALL MR_INTERP_XY_UV_U_BY_LINEAR( NI , NJ , UV(:,:,1:2, K ) , U(:,:, K ) )
      CALL MR_INTERP_XY_UV_V_BY_LINEAR( NI , NJ , UV(:,:,1:2, K ) , V(:,:, K ) )
    END DO

  ! CALCULATE VERTICAL VELOCITY
    CALL MR_CALC_W( NI , NJ , NK , U , V , W )

  ! MERGE EXTERNAL AND INTERNAL
  ! COMPONENTS OF HORIZONTAL VELOCITY TOGETHER
    DO K = 1 , NK

      DO J = 1 , NJ
       !DIR$ VECTOR ALIGNED
        DO I = 0 , NI
          U( I , J , K ) = U( I , J , K ) + UA( I , J )
        END DO
      END DO

      DO J = 0 , NJ
       !DIR$ VECTOR ALIGNED
        DO I = 1 , NI
          V( I , J , K ) = V( I , J , K ) + VA( I , J )
        END DO
      END DO

      DO DIM = 1 , 2
        DO J = 1 , NJ
         !DIR$ VECTOR ALIGNED
          DO I = 1 , NI
            UV( I , J ,DIM, K ) = UV( I , J ,DIM, K ) + UVA( I , J ,DIM)
          END DO
        END DO
      END DO

    END DO

  END SUBROUTINE MR_UPDT_HYD

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_CALC_UVA( NI , NJ , ZSU , ZSV , ALFA , BETA , UVA )

    USE MR_MOD_CALC_GRAD_XY

    IMPLICIT NONE

    INTEGER(IJID_KIND) , INTENT(IN ) :: NI , NJ

    REAL   (FDRD_KIND) , INTENT(IN ) , DIMENSION(0:NI0(NI,FDRD_KIND),1:NJ    ) :: ZSU
    REAL   (FDRD_KIND) , INTENT(IN ) , DIMENSION(1:NI1(NI,FDRD_KIND),0:NJ    ) :: ZSV

    REAL   (CARD_KIND) , INTENT(IN ) , DIMENSION(1:NI1(NI,CARD_KIND),1:NJ,1:2) :: ALFA , BETA

    REAL   (FDRD_KIND) , INTENT(OUT) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ,1:2) :: UVA

    REAL   (FDRD_KIND) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ,1:2) :: GRAD_XY_ZS

    INTEGER(IJID_KIND) :: I , J
    INTEGER            :: DIM

    CALL MR_CALC_GRAD_XY_SS( NI , NJ , ZSU , ZSV , GRAD_XY_ZS )

    DO DIM = 1 , 2

      DO J = 1 , NJ
       !DIR$ VECTOR ALIGNED
        DO I = 1 , NI
          UVA( I , J ,DIM) = ( ALFA( I , J ,DIM) * GRAD_XY_ZS( I , J ,DIM) + BETA( I , J ,DIM) ) / MW( I , J ) / H( I , J )
        END DO
      END DO

    END DO

  END SUBROUTINE MR_CALC_UVA

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_CALC_W( NI , NJ , NK , UD , VD , W )

    USE MR_MOD_OPERATOR_SS
    USE MR_MOD_CALC_GRAD_XY

    IMPLICIT NONE

    INTEGER(IJID_KIND) , INTENT(IN ) :: NI , NJ
    INTEGER(KKID_KIND) , INTENT(IN ) :: NK

    REAL   (FDRD_KIND) , INTENT(IN ) , DIMENSION(0:NI0(NI,FDRD_KIND),1:NJ,1:NK) :: UD
    REAL   (FDRD_KIND) , INTENT(IN ) , DIMENSION(1:NI1(NI,FDRD_KIND),0:NJ,1:NK) :: VD

    REAL   (FDRD_KIND) , INTENT(OUT) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ,0:NK) :: W

    REAL   (FDRD_KIND) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ) :: REDC_GRAD_UVD

    INTEGER(IJID_KIND) :: I , J
    INTEGER(KKID_KIND) :: K

    W(1:NI,1:NJ, 0 ) = 0.0

    DO K = 1 , NK

      CALL MR_CALC_REDC_GRAD_XY_SS( NI , NJ ,   &
      & ( MU .MRSSSCL. ( UD(:,:, K ) .MRSSMTP. HU ) ) , ( MV .MRSSSCL. ( VD(:,:, K ) .MRSSMTP. HV ) ) , REDC_GRAD_UVD )

      DO J = 1 , NJ
       !DIR$ VECTOR ALIGNED
        DO I = 1 , NI
          W( I , J , K ) = W( I , J ,K-1) -   &
          & DSIGMA * REDC_GRAD_UVD( I , J ) / MW( I , J ) / H( I , J )
        END DO
      END DO

    END DO

  END SUBROUTINE MR_CALC_W

  END MODULE MR_MOD_UPDT_HYD


SUBROUTINE p93(input_file,output_file)
!-------------------------------------------------------------------------
! Program 9.3: One dimensional coupled consolidation analysis of a Biot
!              poro-elastic solid using 2-node "line" elements.
!              Freedoms numbered in order v-uw.
!-------------------------------------------------------------------------
 USE main
 USE geom
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::i,iel,j,k,loaded_nodes,ndof=4,nels,neq,nlen,nlfp,nls,nn,nod=2,  &
   nodof=2,npri,nprops=2,np_types,nr,nres,nstep,ntime
 REAL(iwp)::at,a0,dtim,hme,one=1.0_iwp,pt5=0.5_iwp,settl,theta,time,      &
   uav,uavs,zero=0.0_iwp
 CHARACTER(LEN=15)::argv
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g(:),g_g(:,:),kdiag(:),nf(:,:),no(:),num(:)
 REAL(iwp),ALLOCATABLE::al(:),ans(:),c(:,:),ell(:),kc(:,:),ke(:,:),       &
   km(:,:),kv(:),lf(:,:),loads(:),phi0(:),phi1(:),press(:),prop(:,:),     &
   store_kc(:,:,:),val(:)
!-----------------------input and initialisation--------------------------
 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)nels,np_types
 nn=nels+1
 ALLOCATE(num(nod),etype(nels),kc(nod,nod),prop(nprops,np_types),         &
   ell(nels),nf(nodof,nn),g(ndof),g_g(ndof,nels),km(nod,nod),             &
   store_kc(nod,nod,nels),ke(ndof,ndof),phi0(nodof),phi1(nodof),c(nod,nod))
!---prop(1,:)=permeability (k/gamma_w), prop(2,:)=compressibility (m_v)----
 READ(10,*)prop
 etype=1
 IF(np_types>1)READ(10,*)etype
 READ(10,*)ell
 READ(10,*)dtim,nstep,theta,npri,nres,ntime
 nf=1
 READ(10,*)nr,(k,nf(:,k),i=1,nr)
 CALL formnf(nf)
 neq=MAXVAL(nf)
 ALLOCATE(kdiag(neq),loads(0:neq),ans(0:neq),press(nn))
 READ(10,*)loaded_nodes
 ALLOCATE(no(loaded_nodes),val(loaded_nodes))
 READ(10,*)(no(i),val(i),i=1,loaded_nodes)
 READ(10,*)nlfp
 ALLOCATE(lf(2,nlfp))
 READ(10,*)lf
 nls=FLOOR(lf(1,nlfp)/dtim)
 IF(nstep>nls)nstep=nls
 ALLOCATE(al(nstep))
 CALL load_function(lf,dtim,al)
 kdiag=0
!-----------------------loop the elements to find global arrays sizes-----
 elements_1: DO iel=1,nels
   num=(/iel,iel+1/)
   g(1:2)=nf(1,num)
   g(3:4)=nf(2,num)
   g_g(:,iel)=g
   CALL fkdiag(kdiag,g)
 END DO elements_1
 DO i=2,neq
   kdiag(i)=kdiag(i)+kdiag(i-1)
 END DO
 ALLOCATE(kv(kdiag(neq)))
 WRITE(11,'(2(A,I5))')                                                    &
   " There are",neq," equations and the skyline storage is",kdiag(neq)
!-----------------------global conductivity and "mass" matrix assembly----
 kv=zero
 c(:,1)=-pt5
 c(:,2)= pt5
 elements_2: DO iel=1,nels
   g=g_g(:,iel)
   CALL rod_km(kc,prop(1,etype(iel)),ell(iel))
   kc=kc*dtim
   CALL rod_km(km,one/prop(2,etype(iel)),ell(iel))
   store_kc(:,:,iel)=kc
   CALL formke(km,kc,c,ke,theta)
   CALL fsparv(kv,ke,g,kdiag)
 END DO elements_2
 CALL sparin_gauss(kv,kdiag) !---factorise equations----
 WRITE(11,'(/2A,I4,A)')"    Time          Uav         Uavs",              &
   "    Settle_top  Pressure (node",nres,")"
 loads=zero
 hme=zero
 DO iel=1,nels
   hme=hme+ell(iel)*prop(2,etype(iel))
 END DO
 WRITE(11,'(5E12.4)')0.0,0.0,0.0,0.0,loads(nf(2,nres))
!-----------------------time stepping loop--------------------------------
 time_steps: DO j=1,nstep
   time=j*dtim
   ans=zero
   a0=zero
   settl=SUM(al(1:j))*hme
   elements_3: DO iel=1,nels
   g=g_g(:,iel)
   kc=store_kc(:,:,iel)
   phi0=loads(g(nodof+1:))
   phi1=MATMUL(kc,phi0)
   ans(g(nodof+1:))=ans(g(nodof+1:))+phi1
 END DO elements_3
!-----------------------apply loading increment---------------------------
   ans(nf(1,no))=val*al(j)
!-----------------------equation solution---------------------------------
   CALL spabac_gauss(kv,ans,kdiag)
   loads=loads+ans
   loads(0)=zero
   at=zero
   DO iel=1,nels
     at=at+pt5*ell(iel)*abs(loads(nf(2,iel))+loads(nf(2,iel+1)))
     a0=a0+ell(iel)*SUM(al(1:j))
   END DO
   uav=(a0-at)/a0
   uavs=loads(nf(1,1))/settl
   IF(j==ntime)press(:)=loads(nf(2,:))
   IF(j/npri*npri==j)WRITE(11,'(5E12.4)')time,uav,uavs,loads(nf(1,1)),    &
     loads(nf(2,nres))
 END DO time_steps
 WRITE(11,'(/A,E10.4,A)')"    Depth     Pressure (time=",ntime*dtim,")"
 WRITE(11,'(2E12.4)')zero,zero
 WRITE(11,'(2E12.4)')(SUM(ell(1:i)),press(i+1),i=1,nels)

END SUBROUTINE p93


  subroutine gauss2grid(gfld,glon,glat,grad,glat2,rfld,rlon,rlat)

    use mod_param
    use m_const, only: undef
    implicit none

    integer,              intent(in)  :: glon,glat,rlon,rlat,glat2
    real(kind=kind_evod), intent(in)  :: gfld(glon,glat),grad(glat)
    real(kind=kind_evod), intent(out) :: rfld(rlon,rlat)
    real(kind=kind_evod), allocatable :: lat2(:),dphi(:),dlam(:),lons(:),lats(:)
    real(kind=kind_evod)              :: pi,dl,dp,snp,ssp,lon,lat
    integer                           :: loc
    integer                           :: i,j,k

    pi = atan(1.0)*4.0         !constant

    ! create lats array with pole points

    allocate(lat2(glat+2))
    allocate(dphi(glat+2))
    allocate(dlam(glon))

    lat2(1) = -90.0
    do j=2,glat2+1
      lat2(glat2+3-j)= -grad(j-1)*180.0/pi
      lat2(j+glat2)  =  grad(j-1)*180.0/pi
    enddo
    lat2(glat+2) = 90.0

    ! compute dlam and dphi array
    dl = 2.0*pi/glon
    dlam(:) = dl

    do j=1,glat+1
      dphi(j) = ( lat2(j+1)-lat2(j) )*pi/180.0
    enddo
    dphi(glat+2) = undef

    ! create pole values
    rfld = 0.
    snp=0.
    ssp=0.
    do i=1,glon
      snp=snp+gfld(i,glat)
      ssp=ssp+gfld(i,1)
    enddo
    snp = snp/glon
    ssp = ssp/glon
    do i=1,rlon
     rfld(i,rlat) = snp
     rfld(i,1)    = ssp
    enddo

    ! create output lons and lats and interpolate

    dl = 2*pi/rlon
    dp = pi/(rlat-1)
    allocate(lons(rlon*rlat))
    allocate(lats(rlon*rlat))

    loc =0
    do j=1,rlat
      do i=1,rlon
        loc=loc+1
        lon = -pi + (i-1)*dl
        lons(loc) = lon
      enddo
    enddo

    loc =0
    do j=1,rlat
      lat = -pi/2.0 + (j-1)*dp
      do i=1,rlon
        loc=loc+1
        lats(loc) = lat
      enddo
    enddo

    call interp_h(gfld,glon,glat,1,dlam,dphi,0.0,90.0,0.0,&
                  rfld,rlon*rlat,lons,lats,1,3,.false.,undef)

    deallocate(lons,lats)
    deallocate(lat2,dphi,dlam)

  end subroutine gauss2grid


Program Ejemplo03

implicit none

!Ilustra la no asociatividad de Punto Flotante

real ::  u, v, x, y, z, uu, vv

x =  1.0e+30
y = -1.0e+30
z =  1.0

u = (x + y ) + z
uu = x + y + z

v = x + ( y + z )
vv = z + y + x

print *," Variables: "
print *, 'x	= ', x
print *, 'y	= ', y
print *, 'z = ', z
print *,''

write (*,*)
write (*,*) "u = (x + y) + z) = ", u
write (*,*) "uu = x + y + z = ", uu

write (*,*) "v =  x + (y + z) = ", v
write (*,*) "vv = z + y + x = ", vv

end Program Ejemplo03