PROGRAM STEP
C
C     WHERE -
C         JD,KD,LD = MAX ALLOWED GRID DIMENSIONS W/O RECOMPILE.
C         MD = MAX GRID SIZE IN ANY ONE DIRECTION.
C            = MAX (JD,KD,LD).
      DATA JD/30/,KD/30/,LD/15/,MD/30/
      DATA JEM1/28/,KEM1/28/,LEM1/13/
      COMMON/BASE/NMAX,JMAX,KMAX,LMAX,JM,KM,LM,DT,GAMMA,GAMI
     *  ,HDX,HDY,HDZ,SMUIM
      COMMON/VARS/Q(30,30,15,6)
      COMMON/VAR3/ XX(30,30,15),XY(30,30,15),XZ(30,30,15),
     *             YX(30,30,15),YY(30,30,15),YZ(30,30,15),
     *             ZX(30,30,15),ZY(30,30,15),ZZ(30,30,15)
      COMMON/VAR0/S(30,30,15,5),VARDT(30,30,15)

      IMARK=IMARK
C MARK COMMAND 0
      JM=29
      KM=29
      LM=14
      JMAX=30
      KMAX=30
      LMAX=15

C
C  SCALE RHS BY VARIABLE DT
C MARK COMMAND 20
      DO 15 K = 1,KMAX
      DO 15 L = 1,LMAX
C MARK COMMAND 3
C MARK COMMAND 21
C MARK COMMAND 20
      DO 151 J = 1,JMAX	
C MARK COMMAND 21
C change J to inside 5/14/91
      S(J,K,L,1) = S(J,K,L,1)*VARDT(J,K,L)
      S(J,K,L,2) = S(J,K,L,2)*VARDT(J,K,L)
      S(J,K,L,3) = S(J,K,L,3)*VARDT(J,K,L)
      S(J,K,L,4) = S(J,K,L,4)*VARDT(J,K,L)
      S(J,K,L,5) = S(J,K,L,5)*VARDT(J,K,L)
151    CONTINUE
C MARK COMMAND 29
15    CONTINUE
C MARK COMMAND 29
C MARK COMMAND 4
      IMARK=IMARK
C
C  S MUST BE ZERO ON B.C.
C
      IMARK=IMARK
C MARK COMMAND 20
      DO 20 K = 2,29
      DO 20 L = 2,14
C MARK COMMAND 3
C MARK COMMAND 21
        CALL BTRIX(2,29,L,K)
   20 CONTINUE
C MARK COMMAND 29
C MARK COMMAND 4

C MARK COMMAND 20
      DO 30 J = 2,29
      DO 30 L = 2,14
C MARK COMMAND 3
C MARK COMMAND 21
        CALL BTRIY(2,29,J,L)
   30 CONTINUE
C MARK COMMAND 29
C MARK COMMAND 4

C MARK COMMAND 20
      DO 40 K = 2,29
      DO 40 J = 2,29
C MARK COMMAND 3
C MARK COMMAND 21
        CALL BTRIZ(2,14,J,K)
   40 CONTINUE
C MARK COMMAND 29
C MARK COMMAND 4
      IMARK=IMARK  
C
C     CORRECTIONS ARE IN THE S ARRAY.
C
C     MOVE KM,LM and JM (Global variables) OUT Side of Loop
      KMLOCAL = KM
      LMLOCAL = LM
      JMLOCAL = JM
      IMARK=IMARK
C MARK COMMAND 20
C Modified 3-20-94 by Sunil Kim
C      DO 50 K = 2,KM
C      DO 50 L = 2,LM
      DO 50 K = 2,KMLOCAL
      DO 50 L = 2,LMLOCAL
C MARK COMMAND 3
C MARK COMMAND 21
C MARK COMMAND 20
      IMARK=IMARK
C
C Modified 3-20-94 by Sunil Kim
C      DO 51 J = 2,JM
      DO 51 J = 2,JMLOCAL
C MARK COMMAND 21
C change J to inside 5/14/91
      Q(J,K,L,1) = Q(J,K,L,1) + S(J,K,L,1)
      Q(J,K,L,2) = Q(J,K,L,2) + S(J,K,L,2)
      Q(J,K,L,3) = Q(J,K,L,3) + S(J,K,L,3)
      Q(J,K,L,4) = Q(J,K,L,4) + S(J,K,L,4)
      Q(J,K,L,5) = Q(J,K,L,5) + S(J,K,L,5)
   51 CONTINUE
C MARK COMMAND 29
   50 CONTINUE
C MARK COMMAND 29
C MARK COMMAND 4
C MARK COMMAND 5      

      STOP
      END

      SUBROUTINE BTRIX(JS,JE,L,K)
C
C     WHERE -
C         JD,KD,LD = MAX ALLOWED GRID DIMENSIONS W/O RECOMPILE.
C         MD = MAX GRID SIZE IN ANY ONE DIRECTION.
C            = MAX (JD,KD,LD).
      COMMON/BASE/NMAX,JMAX,KMAX,LMAX,JM,KM,LM,DT,GAMMA,GAMI
     *  ,HDX,HDY,HDZ,SMUIM
      COMMON/VARS/Q(30,30,15,6)
      COMMON/VAR3/ XX(30,30,15),XY(30,30,15),XZ(30,30,15),
     *             YX(30,30,15),YY(30,30,15),YZ(30,30,15),
     *             ZX(30,30,15),ZY(30,30,15),ZZ(30,30,15)
      COMMON/VAR0/S(30,30,15,5),VARDT(30,30,15)
C
      DIMENSION A(5,5,60),B(5,5,60),C(5,5,60),D(5,5)
      REAL         U12 ,U13 ,U14 ,U15 ,U23 ,
     *             U24 ,U25 ,U34 ,U35 ,U45
C
      REAL         L11 ,L21 ,L31 ,L41 ,L51 ,
     *             L22 ,L32 ,L42 ,L52 ,L33 ,
     *             L43 ,L53 ,L44 ,L54 ,L55
C
C     PULLIAM/STEGER IMPLICIT SMOOTHING
C
      GAM2       = 2.0 - GAMMA
      SMUIM1        = SMUIM*DT
      B1         =  2.0*SMUIM1
      R4         = 0.0

C MARK COMMAND 20      
      DO 10 J = 1,30
C MARK COMMAND 21      
      IF ( J.EQ.1 .OR. J.EQ.30   ) GO TO 13
C No Prefetch because of No global Read
      DO 12 M = 1,5
      DO 12 N = 1,5
      SMUIMF        = 0.0
      IF ( M.EQ.N ) SMUIMF = B1
      B(M,N,J) = SMUIMF
   12 CONTINUE

   13 CONTINUE
      R1         = XX(J,K,L)*HDX
      R2         = XY(J,K,L)*HDX
      R3         = XZ(J,K,L)*HDX
      D(1,2)   = R1
      D(4,5)   = R3*GAMI
      D(1,3)   = R2
      D(2,5)   = R1*GAMI
      D(1,4)   = R3
      D(3,5)   = R2*GAMI
      D(1,1)   = R4
      R          = 1./Q(J,K,L,1)
      U          = Q(J,K,L,2)*R
      V          = Q(J,K,L,3)*R
      W          = Q(J,K,L,4)*R
      C2         = GAMMA*Q(J,K,L,5)*R
      UU         = (R1*U) +(R2*V) +(R3*W)
      UT         = U*U +V*V +W*W
      C1         = (0.5*GAMI)*UT
      D(1,5)   = 0.0
      D(2,2)   = (R4 +UU) +(R1*U)*GAM2
      D(3,3)   = (R4 +UU) +(R2*V)*GAM2
      D(4,4)   = (R4 +UU) +(R3*W)*GAM2
      D(2,3)   = -R1*(GAMI*V) +(R2*U)
      D(2,4)   = -R1*(GAMI*W) +(R3*U)
      D(3,2)   = R1*V -R2*(GAMI*U)
      D(3,4)   = -R2*(GAMI*W) +(R3*V)
      D(4,2)   = R1*W -R3*(GAMI*U)
      D(4,3)   = R2*W -R3*(GAMI*V)
      D(5,2)   = R1*(C2 -C1) -(GAMI*U)*UU
      D(5,3)   = R2*(C2 -C1) -(GAMI*V)*UU
      D(5,4)   = R3*(C2 -C1) -(GAMI*W)*UU
      D(2,1)   = R1*C1 -U*UU
      D(3,1)   = R2*C1 -V*UU
      D(4,1)   = R3*C1 -W*UU
      D(5,1)   = (-C2 +2.0*C1)*UU
      D(5,5)   = R4 +GAMMA*UU
   14 CONTINUE
C
      IF ( J.GT.28   ) GO TO 17
C MARK COMMAND 32      
C MARK COMMAND 20      
      DO 15 N = 1,5
C MARK COMMAND 21      
      A(1,N,J+1) = -D(1,N)
      A(2,N,J+1) = -D(2,N)
      A(3,N,J+1) = -D(3,N)
      A(4,N,J+1) = -D(4,N)
      A(5,N,J+1) = -D(5,N)
   15 CONTINUE
C MARK COMMAND 29      
      A(1,1,J+1) = A(1,1,J+1) -(SMUIM1*(Q(J,K,L,6)/Q(J+1,K,L,6)))
      A(2,2,J+1) = A(2,2,J+1) -(SMUIM1*(Q(J,K,L,6)/Q(J+1,K,L,6)))
      A(3,3,J+1) = A(3,3,J+1) -(SMUIM1*(Q(J,K,L,6)/Q(J+1,K,L,6)))
      A(4,4,J+1) = A(4,4,J+1) -(SMUIM1*(Q(J,K,L,6)/Q(J+1,K,L,6)))
      A(5,5,J+1) = A(5,5,J+1) -(SMUIM1*(Q(J,K,L,6)/Q(J+1,K,L,6)))
   16 CONTINUE
C MARK COMMAND 39      
      IMARK=IMARK 
   17 CONTINUE
      IMARK=IMARK 
C MARK COMMAND 99      
      IF ( J.LT.3 ) GO TO 10
C MARK COMMAND 32      
C MARK COMMAND 20      
      DO 18 N = 1,5
C MARK COMMAND 21      
      C(1,N,J-1) = D(1,N)
      C(2,N,J-1) = D(2,N)
      C(3,N,J-1) = D(3,N)
      C(4,N,J-1) = D(4,N)
      C(5,N,J-1) = D(5,N)
   18 CONTINUE
C MARK COMMAND 29      
      C(1,1,J-1) = C(1,1,J-1) -(SMUIM1*(Q(J,K,L,6)/Q(J-1,K,L,6)))
      C(2,2,J-1) = C(2,2,J-1) -(SMUIM1*(Q(J,K,L,6)/Q(J-1,K,L,6)))
      C(3,3,J-1) = C(3,3,J-1) -(SMUIM1*(Q(J,K,L,6)/Q(J-1,K,L,6)))
      C(4,4,J-1) = C(4,4,J-1) -(SMUIM1*(Q(J,K,L,6)/Q(J-1,K,L,6)))
      C(5,5,J-1) = C(5,5,J-1) -(SMUIM1*(Q(J,K,L,6)/Q(J-1,K,L,6)))
   19 CONTINUE
C MARK COMMAND 39      
      IMARK=IMARK
   10 CONTINUE
C MARK COMMAND 29      
      IMARK=IMARK 
C
C   ADD IN VARIABLE DT
C
      IMARK=IMARK 
C MARK COMMAND 20      
        DO 29 M = 1,5
C MARK COMMAND 21      
C MARK COMMAND 20      
         DO 32 J = 1,30
C MARK COMMAND 21      
          A(M,1,J)   = A(M,1,J)*VARDT(J,K,L)
          B(M,1,J)   = B(M,1,J)*VARDT(J,K,L)
          C(M,1,J)   = C(M,1,J)*VARDT(J,K,L)
          A(M,2,J)   = A(M,2,J)*VARDT(J,K,L)
          B(M,2,J)   = B(M,2,J)*VARDT(J,K,L)
          C(M,2,J)   = C(M,2,J)*VARDT(J,K,L)
          A(M,3,J)   = A(M,3,J)*VARDT(J,K,L)
          B(M,3,J)   = B(M,3,J)*VARDT(J,K,L)
          C(M,3,J)   = C(M,3,J)*VARDT(J,K,L)
          A(M,4,J)   = A(M,4,J)*VARDT(J,K,L)
          B(M,4,J)   = B(M,4,J)*VARDT(J,K,L)
          C(M,4,J)   = C(M,4,J)*VARDT(J,K,L)
          A(M,5,J)   = A(M,5,J)*VARDT(J,K,L)
          B(M,5,J)   = B(M,5,J)*VARDT(J,K,L)
          C(M,5,J)   = C(M,5,J)*VARDT(J,K,L)
          B(M,M,J) = B(M,M,J) + 1.0
32       CONTINUE
C MARK COMMAND 29      
29    CONTINUE
C MARK COMMAND 29      
      IMARK=IMARK 

C
C     THE ORIGINAL BTRIX BEGINS HERE...
C
C     VECTORIZED BLOCK TRI-DIAGONAL SOLVER IN THE J DIRECTION
C          FOR K = CONSTANT PLANES
C
C     WHERE -
C         JD,KD,LD = MAX ALLOWED GRID DIMENSIONS W/O RECOMPILE.
C         MD = MAX GRID SIZE IN ANY ONE DIRECTION.
C            = MAX (JD,KD,LD).
C
C
C     PART 1.  FORWARD BLOCK SWEEP
C
C
      I1= 0
      I2= 0
      I3= 0
      I4= 0
C
C**********   STEP 1.  CONSTRUCT L(I) IN B    **************************
C
C MARK COMMAND 20      
      DO 100 J   = JS,JE
C MARK COMMAND 21      
      IF (J.EQ.JS) GO TO 4
C MARK COMMAND 32      
C MARK COMMAND 20      
      DO 3 M = 1,5
C MARK COMMAND 21      
      B(M,1,J)  = (((((B(M,1,J) -A(M,1,J)*B(1,1,J-1))
     *            -A(M,2,J)*B(2,1,J-1)) -A(M,3,J)*B(3,1,J-1))
     *            -A(M,4,J)*B(4,1,J-1)) -A(M,5,J)*B(5,1,J-1))
      B(M,2,J)  = (((((B(M,2,J) -A(M,1,J)*B(1,2,J-1))
     *            -A(M,2,J)*B(2,2,J-1)) -A(M,3,J)*B(3,2,J-1))
     *            -A(M,4,J)*B(4,2,J-1)) -A(M,5,J+I1)*B(5,2,J-1))
      B(M,3,J)  = (((((B(M,3,J) -A(M,1,J)*B(1,3,J-1))
     *            -A(M,2,J)*B(2,3,J-1)) -A(M,3,J)*B(3,3,J-1))
     *            -A(M,4,J)*B(4,3,J-1)) -A(M,5,J+I2)*B(5,3,J-1))
      B(M,4,J)  = (((((B(M,4,J) -A(M,1,J)*B(1,4,J-1))
     *            -A(M,2,J)*B(2,4,J-1)) -A(M,3,J)*B(3,4,J-1))
     *            -A(M,4,J)*B(4,4,J-1)) -A(M,5,J+I3)*B(5,4,J-1))
      B(M,5,J)  = (((((B(M,5,J) -A(M,1,J)*B(1,5,J-1))
     *            -A(M,2,J)*B(2,5,J-1)) -A(M,3,J)*B(3,5,J-1))
     *            -A(M,4,J)*B(4,5,J-1)) -A(M,5,J+I4)*B(5,5,J-1))
    3 CONTINUE
C MARK COMMAND 29      
C MARK COMMAND 39      
      IMARK=IMARK 
    4 CONTINUE
C
C**********    STEP 2.  COMPUTE L INVERSE    ***************************
C
C
C        A.  DECOMPOSE L(I) INTO L AND U
C
      L11     = 1.E0/B(1,1,J)
      U12     = B(1,2,J)*L11
      U13     = B(1,3,J)*L11
      U14     = B(1,4,J)*L11
      U15     = B(1,5,J)*L11
      L21     = B(2,1,J)
      L22     = 1.E0/( (B(2,2,J) -L21*U12) )
      U23     = ( (B(2,3,J) -L21*U13) )*L22
      U24     = ( (B(2,4,J) -L21*U14) )*L22
      U25     = ( (B(2,5,J) -L21*U15) )*L22
      L31     = B(3,1,J)
      L32     = B(3,2,J) -L31*U12
      L33     = 1.E0/( ((B(3,3,J) -L31*U13)
     *                  -L32*U23))
      U34     = (((B(3,4,J)-L31*U14)-L32*U24))*L33
      U35     = (((B(3,5,J)-L31*U15)-L32*U25))*L33
      L41     = B(4,1,J)
      L42     = B(4,2,J) -L41*U12
      L43     = ((B(4,3,J) -L41*U13) -L42*U23)
      L44     = 1.E0/( ((B(4,4,J) -L41*U14) -L42*U24)
     *             -L43*U34 )
      U45     = ( ((B(4,5,J) -L41*U15) -L42*U25)
     *             -L43*U35 )*L44
      L51     = B(5,1,J)
      L52     = (B(5,2,J) -L51*U12)
      L53     = (B(5,3,J) -L51*U13) -L52*U23
      L54     = ((B(5,4,J) -L51*U14) -L52*U24)
     *             -L53*U34
      L55     = 1.E0/((((B(5,5,J) -L51*U15) -L52*U25)
     *             -L53*U35) -L54*U45 )
   20 CONTINUE
C
C**********    STEP 3.  SOLVE FOR INTERMEDIATE VECTOR    ***************
C
C         A.  CONSTRUCT RHS
C
      IF (J.EQ.JS) GO TO 34
C MARK COMMAND 32      
      S(J,K,L,1) = ((((S(J,K,L,1) -A(1,1,J)*S(J-1,K,L,1))
     *            -A(1,2,J)*S(J-1,K,L,2)) -A(1,3,J)*S(J-1,K,L,3))
     *            -A(1,4,J)*S(J-1,K,L,4)) -A(1,5,J)*S(J-1,K,L,5)
      S(J,K,L,2) = ((((S(J,K,L,2) -A(2,1,J)*S(J-1,K,L,1))
     *            -A(2,2,J)*S(J-1,K,L,2)) -A(2,3,J)*S(J-1,K,L,3))
     *            -A(2,4,J)*S(J-1,K,L,4)) -A(2,5,J)*S(J-1,K+I1,L,5)
      S(J,K,L,3) = ((((S(J,K,L,3) -A(3,1,J)*S(J-1,K,L,1))
     *            -A(3,2,J)*S(J-1,K,L,2)) -A(3,3,J)*S(J-1,K,L,3))
     *            -A(3,4,J)*S(J-1,K,L,4)) -A(3,5,J)*S(J-1,K+I2,L,5)
      S(J,K,L,4) = ((((S(J,K,L,4) -A(4,1,J)*S(J-1,K,L,1))
     *            -A(4,2,J)*S(J-1,K,L,2)) -A(4,3,J)*S(J-1,K,L,3))
     *            -A(4,4,J)*S(J-1,K,L,4)) -A(4,5,J)*S(J-1,K+I3,L,5)
      S(J,K,L,5) = ((((S(J,K,L,5) -A(5,1,J)*S(J-1,K,L,1))
     *            -A(5,2,J)*S(J-1,K,L,2)) -A(5,3,J)*S(J-1,K,L,3))
     *            -A(5,4,J)*S(J-1,K,L,4)) -A(5,5,J)*S(J-1,K+I4,L,5)
   33 CONTINUE
C
C         B. INTERMEDIATE VECTOR
C
      IMARK=IMARK 
C MARK COMMAND 39      
      IMARK=IMARK 
   34 CONTINUE
C
C         FWD SUBSTITUTION
C
      D1         = S(J,K,L,1)*L11
      D2         = ( S(J,K,L,2) -L21*D1 )*L22
      D3         = ( (S(J,K,L,3) -L31*D1) -L32*D2 )*L33
      D4         = ( ((S(J,K,L,4) -L41*D1) -L42*D2) -L43*D3 )
     *              *L44
      D5         = ( (((S(J,K,L,5) -L51*D1) -L52*D2) -L53*D3)
     *              -L54*D4 )*L55
C
C         BWD SUBSTITUTION
C
      S(J,K,L,5)  = D5
      S(J,K,L,4)  = D4 -U45*D5
      S(J,K,L,3)  = (D3 -U34 *S(J,K,L,4)) -U35*D5
      S(J,K,L,2)  = ((D2 -U23*S(J,K,L,3)) -U24*S(J,K,L,4))
     *                -U25*D5
      S(J,K,L,1)  = (((D1 -U12*S(J,K,L,2)) -U13*S(J,K,L,3))
     *              -U14*S(J,K,L,4)) -U15*D5
   35 CONTINUE
C
C**********    STEP 4.  CONSTRUCT U(I) = L(I)**(-1)*C(I+1)    **********
C**********             BY COLUMNS AND STORE IN B            **********
C
      IF (J.EQ.JE) GO TO 100
C MARK COMMAND 32      
C MARK COMMAND 20      
      DO 40 N = 1,5
C MARK COMMAND 21      
      IMARK=IMARK 
C
C         FWD SUBSTITUTION
C
      C1         = C(1,N,J)*L11
      C2         = (C(2,N,J) -L21*C1)*L22
      C3         = ((C(3,N,J) -L31*C1) -L32*C2)*L33
      C4         = (((C(4,N,J) -L41*C1) -L42*C2)
     *             -L43*C3)*L44
      C5         = ((((C(5,N,J) -L51*C1) -L52*C2) -L53*C3)
     *              -L54*C4)*L55
C
C         BWD SUBSTITUTION
C
      B(5,N,J)  = C5
      B(4,N,J)  = C4 -U45*C5
      B(3,N,J)  = (C3 -U34*B(4,N,J)) -U35*C5
      B(2,N,J)  = ((C2 -U23*B(3,N,J)) -U24*B(4,N,J))
     *             -U25*C5
      B(1,N,J)  = (((C1 -U12*B(2,N,J)) -U13*B(3,N,J))
     *              -U14*B(4,N,J)) -U15*C5
   40 CONTINUE
C MARK COMMAND 29      
      IMARK=IMARK 
C MARK COMMAND 39      
      IMARK=IMARK 
  100 CONTINUE
C MARK COMMAND 29      
      IMARK=IMARK 
C
C     PART 2.  BACKWARD BLOCK SWEEP
C
      IMARK=IMARK 
C MARK COMMAND 20      
      DO 200 JXX = JS  ,28
C MARK COMMAND 21      
      J = 28+JS-JXX
      S(J,K,L,1) = ((((S(J,K,L,1) -B(1,1,J)*S(J+1,K,L,1))
     *             -B(1,2,J)*S(J+1,K,L,2)) -B(1,3,J)*S(J+1,K,L,3))
     *             -B(1,4,J)*S(J+1,K,L,4)) -B(1,5,J)*S(J+1,K,L,5)
      S(J,K,L,2) = ((((S(J,K,L,2) -B(2,1,J)*S(J+1,K,L,1))
     *             -B(2,2,J)*S(J+1,K,L,2)) -B(2,3,J)*S(J+1,K,L,3))
     *             -B(2,4,J)*S(J+1,K,L,4)) -B(2,5,J)*S(J+1,K+I1,L,5)
      S(J,K,L,3) = ((((S(J,K,L,3) -B(3,1,J)*S(J+1,K,L,1))
     *             -B(3,2,J)*S(J+1,K,L,2)) -B(3,3,J)*S(J+1,K,L,3))
     *             -B(3,4,J)*S(J+1,K,L,4)) -B(3,5,J)*S(J+1,K+I2,L,5)
      S(J,K,L,4) = ((((S(J,K,L,4) -B(4,1,J)*S(J+1,K,L,1))
     *             -B(4,2,J)*S(J+1,K,L,2)) -B(4,3,J)*S(J+1,K,L,3))
     *             -B(4,4,J)*S(J+1,K,L,4)) -B(4,5,J)*S(J+1,K+I3,L,5)
      S(J,K,L,5) = ((((S(J,K,L,5) -B(5,1,J)*S(J+1,K,L,1))
     *             -B(5,2,J)*S(J+1,K,L,2)) -B(5,3,J)*S(J+1,K,L,3))
     *             -B(5,4,J)*S(J+1,K,L,4)) -B(5,5,J)*S(J+1,K+I4,L,5)
  200 CONTINUE
C MARK COMMAND 29      
      IMARK=IMARK 
      RETURN
      END


      SUBROUTINE BTRIY(KS,KE,J,L)
C
C     WHERE -
C         JD,KD,LD = MAX ALLOWED GRID DIMENSIONS W/O RECOMPILE.
C         MD = MAX GRID SIZE IN ANY ONE DIRECTION.
C            = MAX (JD,KD,LD).

      COMMON/BASE/NMAX,JMAX,KMAX,LMAX,JM,KM,LM,DT,GAMMA,GAMI
     *  ,HDX,HDY,HDZ,SMUIM
      COMMON/VARS/Q(30,30,15,6)
      COMMON/VAR3/ XX(30,30,15),XY(30,30,15),XZ(30,30,15),
     *             YX(30,30,15),YY(30,30,15),YZ(30,30,15),
     *             ZX(30,30,15),ZY(30,30,15),ZZ(30,30,15)
      COMMON/VAR0/S(30,30,15,5),VARDT(30,30,15)
C
      DIMENSION    A(5,5,60),B(5,5,60),C(5,5,60),D(5,5)
      REAL         U12 ,U13 ,U14 ,U15 ,U23 ,
     *             U24 ,U25 ,U34 ,U35 ,U45
C
      REAL         L11 ,L21 ,L31 ,L41 ,L51 ,
     *             L22 ,L32 ,L42 ,L52 ,L33 ,
     *             L43 ,L53 ,L44 ,L54 ,L55
C
C     PULLIAM/STEGER IMPLICIT SMOOTHING
C
      R4         = 0.0
      GAM2       = 2.0 -GAMMA
      SMUIM1        = SMUIM*DT
      B1         = 2.0*SMUIM1
C
C MARK COMMAND 20
      DO 10 K = 1,30
C MARK COMMAND 21
      IF ( K.EQ.1 .OR. K.EQ.30   ) GO TO 13
C No Prefetch because of No global Read
      DO 12 M = 1,5
      DO 12 N = 1,5
      SMUIMF        = 0.0
      IF ( M.EQ.N ) SMUIMF = B1
      B(M,N,K) = SMUIMF
   12 CONTINUE

   13 CONTINUE
      R1         = YX(J,K,L)*HDY
      R2         = YY(J,K,L)*HDY
      R3         = YZ(J,K,L)*HDY
      D(1,3)   = R2
      D(2,5)   = R1*GAMI
      D(1,4)   = R3
      D(3,5)   = R2*GAMI
      D(1,1)   = R4
      D(4,5)   = R3*GAMI
      D(1,2)   = R1
      R          = 1./Q(J,K,L,1)
      U          = Q(J,K,L,2)*R
      V          = Q(J,K,L,3)*R
      W          = Q(J,K,L,4)*R
      C2         = GAMMA*Q(J,K,L,5)*R
      UT         = U*U +V*V +W*W
      C1         = (0.5*GAMI)*UT
      UU         = (R1*U) +(R2*V) +(R3*W)
      D(1,5)   = 0.0
      D(2,2)   = (R4 +UU) +(R1*U)*GAM2
      D(3,3)   = (R4 +UU) +(R2*V)*GAM2
      D(4,4)   = (R4 +UU) +(R3*W)*GAM2
      D(2,3)   =-R1*(GAMI*V) +R2*U
      D(2,4)   =-R1*(GAMI*W) +R3*U
      D(3,2)   = R1*V -R2*(GAMI*U)
      D(3,4)   = -R2*(GAMI*W) +R3*V
      D(4,2)   = R1*W -R3*(GAMI*U)
      D(4,3)   = R2*W -R3*(GAMI*V)
      D(5,2)   = R1*(C2 -C1) -(GAMI*U)*UU
      D(5,3)   = R2*(C2 -C1) -(GAMI*V)*UU
      D(5,4)   = R3*(C2 -C1) -(GAMI*W)*UU
      D(2,1)   = R1*C1 -U*UU
      D(3,1)   = R2*C1 -V*UU
      D(4,1)   = R3*C1 -W*UU
      D(5,1)   = (-C2 +2.0*C1)*UU
      D(5,5)   = R4 +GAMMA*UU
C
      IF ( K.GT.28   ) GO TO 17
C MARK COMMAND 32
C MARK COMMAND 20
      DO 15 N = 1,5
C MARK COMMAND 21
      A(1,N,K+1) = -D(1,N)
      A(2,N,K+1) = -D(2,N)
      A(3,N,K+1) = -D(3,N)
      A(4,N,K+1) = -D(4,N)
      A(5,N,K+1) = -D(5,N)
   15 CONTINUE
C MARK COMMAND 29
      A(1,1,K+1) = A(1,1,K+1) -SMUIM1*(Q(J,K,L,6)/Q(J,K+1,L,6))
      A(2,2,K+1) = A(2,2,K+1) -SMUIM1*(Q(J,K,L,6)/Q(J,K+1,L,6))
      A(3,3,K+1) = A(3,3,K+1) -SMUIM1*(Q(J,K,L,6)/Q(J,K+1,L,6))
      A(4,4,K+1) = A(4,4,K+1) -SMUIM1*(Q(J,K,L,6)/Q(J,K+1,L,6))
      A(5,5,K+1) = A(5,5,K+1) -SMUIM1*(Q(J,K,L,6)/Q(J,K+1,L,6))
   16 CONTINUE
C MARK COMMAND 39
      IMARK=IMARK 
   17 CONTINUE
      IMARK=IMARK 
C MARK COMMAND 99
      IF ( K.LT.3 ) GO TO 10
C MARK COMMAND 32
C MARK COMMAND 20
      DO 18 N = 1,5
C MARK COMMAND 21
      C(1,N,K-1) = D(1,N)
      C(2,N,K-1) = D(2,N)
      C(3,N,K-1) = D(3,N)
      C(4,N,K-1) = D(4,N)
      C(5,N,K-1) = D(5,N)
   18 CONTINUE
C MARK COMMAND 29
      C(1,1,K-1) = C(1,1,K-1) -SMUIM1*(Q(J,K,L,6)/Q(J,K-1,L,6))
      C(2,2,K-1) = C(2,2,K-1) -SMUIM1*(Q(J,K,L,6)/Q(J,K-1,L,6))
      C(3,3,K-1) = C(3,3,K-1) -SMUIM1*(Q(J,K,L,6)/Q(J,K-1,L,6))
      C(4,4,K-1) = C(4,4,K-1) -SMUIM1*(Q(J,K,L,6)/Q(J,K-1,L,6))
      C(5,5,K-1) = C(5,5,K-1) -SMUIM1*(Q(J,K,L,6)/Q(J,K-1,L,6))
C MARK COMMAND 39
      IMARK=IMARK
   10 CONTINUE
C MARK COMMAND 29
      IMARK=IMARK
C
C
C   ADD IN VARIABLE DT
C
      IMARK=IMARK 
C MARK COMMAND 20
      DO 29 K = 1,30
C MARK COMMAND 21
C MARK COMMAND 20
        DO 30 M = 1,5
C MARK COMMAND 21
          A(M,1,K)   = A(M,1,K)*VARDT(J,K,L)
          B(M,1,K)   = B(M,1,K)*VARDT(J,K,L)
          C(M,1,K)   = C(M,1,K)*VARDT(J,K,L)
          A(M,2,K)   = A(M,2,K)*VARDT(J,K,L)
          B(M,2,K)   = B(M,2,K)*VARDT(J,K,L)
          C(M,2,K)   = C(M,2,K)*VARDT(J,K,L)
          A(M,3,K)   = A(M,3,K)*VARDT(J,K,L)
          B(M,3,K)   = B(M,3,K)*VARDT(J,K,L)
          C(M,3,K)   = C(M,3,K)*VARDT(J,K,L)
          A(M,4,K)   = A(M,4,K)*VARDT(J,K,L)
          B(M,4,K)   = B(M,4,K)*VARDT(J,K,L)
          C(M,4,K)   = C(M,4,K)*VARDT(J,K,L)
          A(M,5,K)   = A(M,5,K)*VARDT(J,K,L)
          B(M,5,K)   = B(M,5,K)*VARDT(J,K,L)
          C(M,5,K)   = C(M,5,K)*VARDT(J,K,L)
          B(M,M,K) = B(M,M,K) + 1.0
 30    CONTINUE
C MARK COMMAND 29
 29   CONTINUE
C MARK COMMAND 29
      IMARK=IMARK 
C
C     VECTORIZED BLOCK TRI-DIAGONAL SOLVER IN THE K DIRECTION
C          FOR L = CONSTANT PLANES
C
C     WHERE -
C         JD,KD,LD = MAX ALLOWED GRID DIMENSIONS W/O RECOMPILE.
C         MD = MAX GRID SIZE IN ANY ONE DIRECTION.
C            = MAX (JD,KD,LD).
C
C
C     PART 1.  FORWARD BLOCK SWEEP
C
C
      I1= 0
      I2= 0
      I3= 0
      I4= 0
C
C**********   STEP 1.  CONSTRUCT L(I) IN B    **************************
C
C MARK COMMAND 20
      DO 100 K   = KS,KE
C MARK COMMAND 21
      IF (K.EQ.KS) GO TO 4
C MARK COMMAND 32
C MARK COMMAND 20
      DO 3 M = 1,5
C MARK COMMAND 21
      B(M,1,K)  = (((((B(M,1,K) -A(M,1,K)*B(1,1,K-1))
     *          -A(M,2,K)*B(2,1,K-1)) -A(M,3,K)*B(3,1,K-1))
     *          -A(M,4,K)*B(4,1,K-1)) -A(M,5,K)*B(5,1,K-1))
      B(M,2,K)  = (((((B(M,2,K) -A(M,1,K)*B(1,2,K-1))
     *          -A(M,2,K)*B(2,2,K-1)) -A(M,3,K)*B(3,2,K-1))
     *          -A(M,4,K)*B(4,2,K-1)) -A(M,5,K+I1)*B(5,2,K-1))
      B(M,3,K)  = (((((B(M,3,K) -A(M,1,K)*B(1,3,K-1))
     *          -A(M,2,K)*B(2,3,K-1)) -A(M,3,K)*B(3,3,K-1))
     *          -A(M,4,K)*B(4,3,K-1)) -A(M,5,K+I2)*B(5,3,K-1))
      B(M,4,K)  = (((((B(M,4,K) -A(M,1,K)*B(1,4,K-1))
     *          -A(M,2,K)*B(2,4,K-1)) -A(M,3,K)*B(3,4,K-1))
     *          -A(M,4,K)*B(4,4,K-1)) -A(M,5,K+I3)*B(5,4,K-1))
      B(M,5,K)  = (((((B(M,5,K) -A(M,1,K)*B(1,5,K-1))
     *          -A(M,2,K)*B(2,5,K-1)) -A(M,3,K)*B(3,5,K-1))
     *          -A(M,4,K)*B(4,5,K-1)) -A(M,5,K+I4)*B(5,5,K-1))
    3 CONTINUE
C MARK COMMAND 29
C MARK COMMAND 39
      IMARK=IMARK 
    4 CONTINUE
C
C**********    STEP 2.  COMPUTE L INVERSE    ***************************
C
C
C        A.  DECOMPOSE L(I) INTO L AND U
C
      L11     = 1.E0/B(1,1,K)
      U12     = B(1,2,K)*L11
      U13     = B(1,3,K)*L11
      U14     = B(1,4,K)*L11
      U15     = B(1,5,K)*L11
      L21     = B(2,1,K)
      L22     = 1.E0/( (B(2,2,K) -L21*U12) )
      U23     = ( (B(2,3,K) -L21*U13) )*L22
      U24     = ( (B(2,4,K) -L21*U14) )*L22
      U25     = ( (B(2,5,K) -L21*U15) )*L22
      L31     = B(3,1,K)
      L32     = B(3,2,K) -L31*U12
      L33     = 1.E0/( ((B(3,3,K) -L31*U13)
     *                  -L32*U23))
      U34     = ( ((B(3,4,K) -L31*U14) -L32*U24) )*
     *             L33
      U35     = ( ((B(3,5,K) -L31*U15) -L32*U25) )*
     *             L33
      L41     = B(4,1,K)
      L42     = B(4,2,K) -L41*U12
      L43     = ((B(4,3,K) -L41*U13) -L42*U23)
      L44     = 1.E0/( ((B(4,4,K) -L41*U14) -L42*U24)
     *             -L43*U34 )
      U45     = ( ((B(4,5,K) -L41*U15) -L42*U25)
     *             -L43*U35 )*L44
      L51     = B(5,1,K)
      L52     = (B(5,2,K) -L51*U12)
      L53     = (B(5,3,K) -L51*U13) -L52*U23
      L54     = ((B(5,4,K) -L51*U14) -L52*U24)
     *             -L53*U34
      L55     = 1.E0/((((B(5,5,K) -L51*U15) -L52*U25)
     *             -L53*U35) -L54*U45 )
   20 CONTINUE
C
C**********    STEP 3.  SOLVE FOR INTERMEDIATE VECTOR    ***************
C
C         A.  CONSTRUCT RHS
C
      IF (K.EQ.KS) GO TO 34
C MARK COMMAND 32
      S(J,K,L,1) = ((((S(J,K,L,1) -A(1,1,K)*S(J,K-1,L,1))
     *            -A(1,2,K)*S(J,K-1,L,2)) -A(1,3,K)*S(J,K-1,L,3))
     *            -A(1,4,K)*S(J,K-1,L,4)) -A(1,5,K)*S(J,K-1,L,5)
      S(J,K,L,2) = ((((S(J,K,L,2) -A(2,1,K)*S(J,K-1,L,1))
     *            -A(2,2,K)*S(J,K-1,L,2)) -A(2,3,K)*S(J,K-1,L,3))
     *            -A(2,4,K)*S(J,K-1,L,4)) -A(2,5,K)*S(J,K-1,L+I1,5)
      S(J,K,L,3) = ((((S(J,K,L,3) -A(3,1,K)*S(J,K-1,L,1))
     *            -A(3,2,K)*S(J,K-1,L,2)) -A(3,3,K)*S(J,K-1,L,3))
     *            -A(3,4,K)*S(J,K-1,L,4)) -A(3,5,K)*S(J,K-1,L+I2,5)
      S(J,K,L,4) = ((((S(J,K,L,4) -A(4,1,K)*S(J,K-1,L,1))
     *            -A(4,2,K)*S(J,K-1,L,2)) -A(4,3,K)*S(J,K-1,L,3))
     *            -A(4,4,K)*S(J,K-1,L,4)) -A(4,5,K)*S(J,K-1,L+I3,5)
      S(J,K,L,5) = ((((S(J,K,L,5) -A(5,1,K)*S(J,K-1,L,1))
     *            -A(5,2,K)*S(J,K-1,L,2)) -A(5,3,K)*S(J,K-1,L,3))
     *            -A(5,4,K)*S(J,K-1,L,4)) -A(5,5,K)*S(J,K-1,L+I4,5)
   33 CONTINUE
C
C         B. INTERMEDIATE VECTOR
C
      IMARK=IMARK 
C MARK COMMAND 39
      IMARK=IMARK 
   34 CONTINUE
C
C         FWD SUBSTITUTION
C
      D1         = S(J,K,L,1)*L11
      D2         = ( S(J,K,L,2) -L21*D1 )*L22
      D3         = ( (S(J,K,L,3) -L31*D1) -L32*D2 )*L33
      D4         = ( ((S(J,K,L,4) -L41*D1) -L42*D2) -L43*D3 )
     *              *L44
      D5         = ( (((S(J,K,L,5) -L51*D1) -L52*D2) -L53*D3)
     *              -L54*D4 )*L55
C
C         BWD SUBSTITUTION
C
      S(J,K,L,5)  = D5
      S(J,K,L,4)  = D4 -U45*D5
      S(J,K,L,3)  = (D3 -U34 *S(J,K,L,4)) -U35*D5
      S(J,K,L,2)  = ((D2 -U23*S(J,K,L,3)) -U24*S(J,K,L,4))
     *                -U25*D5
      S(J,K,L,1)  = (((D1 -U12*S(J,K,L,2)) -U13*S(J,K,L,3))
     *              -U14*S(J,K,L,4)) -U15*D5
   35 CONTINUE
C
C**********    STEP 4.  CONSTRUCT U(I) = L(I)**(-1)*C(I+1)    **********
C**********             BY COLUMNS AND STORE IN B            **********
C
      IF (K.EQ.KE) GO TO 100
C MARK COMMAND 32
C MARK COMMAND 20
      DO 40 N = 1,5
C MARK COMMAND 21
      IMARK=IMARK 
C
C         FWD SUBSTITUTION
C
      C1         = C(1,N,K)*L11
      C2         = (C(2,N,K) -L21*C1)*L22
      C3         = ((C(3,N,K) -L31*C1) -L32*C2)*L33
      C4         = (((C(4,N,K) -L41*C1) -L42*C2)
     *             -L43*C3)*L44
      C5         = ((((C(5,N,K) -L51*C1) -L52*C2) -L53*C3)
     *              -L54*C4)*L55
C
C         BWD SUBSTITUTION
C
      B(5,N,K)  = C5
      B(4,N,K)  = C4 -U45*C5
      B(3,N,K)  = (C3 -U34*B(4,N,K)) -U35*C5
      B(2,N,K)  = ((C2 -U23*B(3,N,K)) -U24*B(4,N,K))
     *             -U25*C5
      B(1,N,K)  = (((C1 -U12*B(2,N,K)) -U13*B(3,N,K))
     *              -U14*B(4,N,K)) -U15*C5
   40 CONTINUE
C MARK COMMAND 29
      IMARK=IMARK 
C MARK COMMAND 39
      IMARK=IMARK 
  100 CONTINUE
C MARK COMMAND 29
      IMARK=IMARK 
C
C     PART 2.  BACKWARD BLOCK SWEEP
C
      IMARK=IMARK 
C MARK COMMAND 20
      DO 200 KYY = KS,  28
C MARK COMMAND 21
      K = 28 + KS - KYY
      S(J,K,L,1) = ((((S(J,K,L,1) -B(1,1,K)*S(J,K+1,L,1))
     *             -B(1,2,K)*S(J,K+1,L,2)) -B(1,3,K)*S(J,K+1,L,3))
     *             -B(1,4,K)*S(J,K+1,L,4)) -B(1,5,K)*S(J,K+1,L,5)
      S(J,K,L,2) = ((((S(J,K,L,2) -B(2,1,K)*S(J,K+1,L,1))
     *             -B(2,2,K)*S(J,K+1,L,2)) -B(2,3,K)*S(J,K+1,L,3))
     *             -B(2,4,K)*S(J,K+1,L,4)) -B(2,5,K)*S(J,K+1,L+I1,5)
      S(J,K,L,3) = ((((S(J,K,L,3) -B(3,1,K)*S(J,K+1,L,1))
     *             -B(3,2,K)*S(J,K+1,L,2)) -B(3,3,K)*S(J,K+1,L,3))
     *             -B(3,4,K)*S(J,K+1,L,4)) -B(3,5,K)*S(J,K+1,L+I2,5)
      S(J,K,L,4) = ((((S(J,K,L,4) -B(4,1,K)*S(J,K+1,L,1))
     *             -B(4,2,K)*S(J,K+1,L,2)) -B(4,3,K)*S(J,K+1,L,3))
     *             -B(4,4,K)*S(J,K+1,L,4)) -B(4,5,K)*S(J,K+1,L+I3,5)
      S(J,K,L,5) = ((((S(J,K,L,5) -B(5,1,K)*S(J,K+1,L,1))
     *             -B(5,2,K)*S(J,K+1,L,2)) -B(5,3,K)*S(J,K+1,L,3))
     *             -B(5,4,K)*S(J,K+1,L,4)) -B(5,5,K)*S(J,K+1,L+I4,5)
  200 CONTINUE
C MARK COMMAND 29
      IMARK=IMARK 
      RETURN
      END

      SUBROUTINE BTRIZ(LS,LE,J,K)
C
C     WHERE -
C         JD,KD,LD = MAX ALLOWED GRID DIMENSIONS W/O RECOMPILE.
C         MD = MAX GRID SIZE IN ANY ONE DIRECTION.
C            = MAX (JD,KD,LD).
      COMMON/BASE/NMAX,JMAX,KMAX,LMAX,JM,KM,LM,DT,GAMMA,GAMI
     *  ,HDX,HDY,HDZ,SMUIM
      COMMON/VARS/Q(30,30,15,6)
      COMMON/VAR3/ XX(30,30,15),XY(30,30,15),XZ(30,30,15),
     *             YX(30,30,15),YY(30,30,15),YZ(30,30,15),
     *             ZX(30,30,15),ZY(30,30,15),ZZ(30,30,15)
      COMMON/VAR0/S(30,30,15,5),VARDT(30,30,15)
C
      DIMENSION    A(5,5,60),B(5,5,60),C(5,5,60),D(5,5)
      REAL         U12 ,U13 ,U14 ,U15 ,U23 ,
     *             U24 ,U25 ,U34 ,U35 ,U45
C
      REAL         L11 ,L21 ,L31 ,L41 ,L51 ,
     *             L22 ,L32 ,L42 ,L52 ,L33 ,
     *             L43 ,L53 ,L44 ,L54 ,L55
C
C     PULLIAM/STEGER IMPLICIT SMOOTHING
C
C
      R4         = 0.0
      GAM2       = 2.0 -GAMMA
      SMUIM1        = SMUIM*DT
      B1         = 2.0*SMUIM1

C MARK COMMAND 20      
      DO 10 L = 1,15
C MARK COMMAND 21      
      IF ( L.EQ.1 .OR. L.EQ.15   ) GO TO 13
C No Prefetch because of No global Read
      DO 12 M = 1,5
      DO 12 N = 1,5
      SMUIMF        = 0.0
      IF ( M.EQ.N ) SMUIMF = B1
      B(M,N,L) = SMUIMF
   12 CONTINUE
   13 CONTINUE

      R1         = ZX(J,K,L)*HDZ
      R2         = ZY(J,K,L)*HDZ
      R3         = ZZ(J,K,L)*HDZ
      D(1,3)   = R2
      D(2,5)   = R1*GAMI
      D(1,4)   = R3
      D(3,5)   = R2*GAMI
      D(1,1)   = R4
      D(4,5)   = R3*GAMI
      D(1,2)   = R1
      R          = 1./Q(J,K,L,1)
      U          = Q(J,K,L,2)*R
      V          = Q(J,K,L,3)*R
      W          = Q(J,K,L,4)*R
      C2         = GAMMA*Q(J,K,L,5)*R
      UT         = U*U +V*V +W*W
      C1         = (0.5*GAMI)*UT
      UU         = (R1*U) +(R2*V) +(R3*W)
      D(1,5)   = 0.0
      D(2,2)   = (R4 +UU) +(R1*U)*GAM2
      D(3,3)   = (R4 +UU) +(R2*V)*GAM2
      D(4,4)   = (R4 +UU) +(R3*W)*GAM2
      D(2,3)   =-R1*(GAMI*V) +(R2*U)
      D(2,4)   =-R1*(GAMI*W) +(R3*U)
      D(3,2)   = R1*V -R2*(GAMI*U)
      D(3,4)   = -R2*(GAMI*W) +(R3*V)
      D(4,2)   = R1*W -R3*(GAMI*U)
      D(4,3)   = R2*W -R3*(GAMI*V)
      D(5,2)   = R1*(C2 -C1) -(GAMI*U)*UU
      D(5,3)   = R2*(C2 -C1) -(GAMI*V)*UU
      D(5,4)   = R3*(C2 -C1) -(GAMI*W)*UU
      D(2,1)   = R1*C1 -U*UU
      D(3,1)   = R2*C1 -V*UU
      D(4,1)   = R3*C1 -W*UU
      D(5,1)   = (-C2 +2.0*C1)*UU
      D(5,5)   = R4 +GAMMA*UU
   14 CONTINUE
C
      IF ( L.GT.13   ) GO TO 17
C MARK COMMAND 32      
C MARK COMMAND 20      
      DO 15 N = 1,5
C MARK COMMAND 21      
      A(1,N,L+1) = -D(1,N)
      A(2,N,L+1) = -D(2,N)
      A(3,N,L+1) = -D(3,N)
      A(4,N,L+1) = -D(4,N)
      A(5,N,L+1) = -D(5,N)
   15 CONTINUE
C MARK COMMAND 29      
      A(1,1,L+1) = A(1,1,L+1) -SMUIM1*(Q(J,K,L,6)/Q(J,K,L+1,6))
      A(2,2,L+1) = A(2,2,L+1) -SMUIM1*(Q(J,K,L,6)/Q(J,K,L+1,6))
      A(3,3,L+1) = A(3,3,L+1) -SMUIM1*(Q(J,K,L,6)/Q(J,K,L+1,6))
      A(4,4,L+1) = A(4,4,L+1) -SMUIM1*(Q(J,K,L,6)/Q(J,K,L+1,6))
      A(5,5,L+1) = A(5,5,L+1) -SMUIM1*(Q(J,K,L,6)/Q(J,K,L+1,6))
   16 CONTINUE
C MARK COMMAND 39      
      IMARK=IMARK 
   17 CONTINUE
      IMARK=IMARK 
C MARK COMMAND 99      
      IF ( L.LT.3 ) GO TO 10
C MARK COMMAND 32      
C MARK COMMAND 20      
      DO 18 N = 1,5
C MARK COMMAND 21      
      C(1,N,L-1) = D(1,N)
      C(2,N,L-1) = D(2,N)
      C(3,N,L-1) = D(3,N)
      C(4,N,L-1) = D(4,N)
      C(5,N,L-1) = D(5,N)
   18 CONTINUE
C MARK COMMAND 29      
      C(1,1,L-1) = C(1,1,L-1) -SMUIM1*(Q(J,K,L,6)/Q(J,K,L-1,6))
      C(2,2,L-1) = C(2,2,L-1) -SMUIM1*(Q(J,K,L,6)/Q(J,K,L-1,6))
      C(3,3,L-1) = C(3,3,L-1) -SMUIM1*(Q(J,K,L,6)/Q(J,K,L-1,6))
      C(4,4,L-1) = C(4,4,L-1) -SMUIM1*(Q(J,K,L,6)/Q(J,K,L-1,6))
      C(5,5,L-1) = C(5,5,L-1) -SMUIM1*(Q(J,K,L,6)/Q(J,K,L-1,6))
   19 CONTINUE
C MARK COMMAND 39      
      IMARK=IMARK
   10 CONTINUE
C MARK COMMAND 29      
      IMARK=IMARK 
C
C   ADD VISCOUS IMPLICIT PART
C
C
C   ADD IN VARIABLE DT
C
      IMARK=IMARK 
C MARK COMMAND 20      
      DO 29 L = 1,15
C MARK COMMAND 21      
C MARK COMMAND 20      
        DO 30 M = 1,5
C MARK COMMAND 21      
          A(M,1,L)   = A(M,1,L)*VARDT(J,K,L)
          B(M,1,L)   = B(M,1,L)*VARDT(J,K,L)
          C(M,1,L)   = C(M,1,L)*VARDT(J,K,L)
          A(M,2,L)   = A(M,2,L)*VARDT(J,K,L)
          B(M,2,L)   = B(M,2,L)*VARDT(J,K,L)
          C(M,2,L)   = C(M,2,L)*VARDT(J,K,L)
          A(M,3,L)   = A(M,3,L)*VARDT(J,K,L)
          B(M,3,L)   = B(M,3,L)*VARDT(J,K,L)
          C(M,3,L)   = C(M,3,L)*VARDT(J,K,L)
          A(M,4,L)   = A(M,4,L)*VARDT(J,K,L)
          B(M,4,L)   = B(M,4,L)*VARDT(J,K,L)
          C(M,4,L)   = C(M,4,L)*VARDT(J,K,L)
          A(M,5,L)   = A(M,5,L)*VARDT(J,K,L)
          B(M,5,L)   = B(M,5,L)*VARDT(J,K,L)
          C(M,5,L)   = C(M,5,L)*VARDT(J,K,L)
          B(M,M,L) = B(M,M,L) + 1.0
30      CONTINUE
C MARK COMMAND 29      
29    CONTINUE
C MARK COMMAND 29      
      IMARK=IMARK 
C
C     VECTORIZED BLOCK TRI-DIAGONAL SOLVER IN THE L DIRECTION
C          FOR K = CONSTANT PLANES
C
C     WHERE -
C         JD,KD,LD = MAX ALLOWED GRID DIMENSIONS W/O RECOMPILE.
C         MD = MAX GRID SIZE IN ANY ONE DIRECTION.
C            = MAX (JD,KD,LD).
C
C     PART 1.  FORWARD BLOCK SWEEP
C
      I1= 0
      I2= 0
      I3= 0
      I4= 0
C
C**********   STEP 1.  CONSTRUCT L(I) IN B    **************************
C
C MARK COMMAND 20      
      DO 100 L   = LS,LE
C MARK COMMAND 21      
      IF (L.EQ.LS) GO TO 4
C MARK COMMAND 32      
C MARK COMMAND 20      
      DO 3 M = 1,5
C MARK COMMAND 21      
      B(M,1,L)  = (((((B(M,1,L) -A(M,1,L)*B(1,1,L-1))
     *          -A(M,2,L)*B(2,1,L-1)) -A(M,3,L)*B(3,1,L-1))
     *          -A(M,4,L)*B(4,1,L-1)) -A(M,5,L)*B(5,1,L-1))
      B(M,2,L)  = (((((B(M,2,L) -A(M,1,L)*B(1,2,L-1))
     *          -A(M,2,L)*B(2,2,L-1)) -A(M,3,L)*B(3,2,L-1))
     *          -A(M,4,L)*B(4,2,L-1)) -A(M,5,L+I1)*B(5,2,L-1))
      B(M,3,L)  = (((((B(M,3,L) -A(M,1,L)*B(1,3,L-1))
     *          -A(M,2,L)*B(2,3,L-1)) -A(M,3,L)*B(3,3,L-1))
     *          -A(M,4,L)*B(4,3,L-1)) -A(M,5,L+I2)*B(5,3,L-1))
      B(M,4,L)  = (((((B(M,4,L) -A(M,1,L)*B(1,4,L-1))
     *          -A(M,2,L)*B(2,4,L-1)) -A(M,3,L)*B(3,4,L-1))
     *          -A(M,4,L)*B(4,4,L-1)) -A(M,5,L+I3)*B(5,4,L-1))
      B(M,5,L)  = (((((B(M,5,L) -A(M,1,L)*B(1,5,L-1))
     *          -A(M,2,L)*B(2,5,L-1)) -A(M,3,L)*B(3,5,L-1))
     *          -A(M,4,L)*B(4,5,L-1)) -A(M,5,L+I4)*B(5,5,L-1))
    3 CONTINUE
C MARK COMMAND 29      
C MARK COMMAND 39      
      IMARK=IMARK 
    4 CONTINUE
C
C**********    STEP 2.  COMPUTE L INVERSE    ***************************
C
C
C        A.  DECOMPOSE L(I) INTO L AND U
C
      L11     = 1.E0/B(1,1,L)
      U12     = B(1,2,L)*L11
      U13     = B(1,3,L)*L11
      U14     = B(1,4,L)*L11
      U15     = B(1,5,L)*L11
      L21     = B(2,1,L)
      L22     = 1.E0/( (B(2,2,L) -L21*U12) )
      U23     = ( (B(2,3,L) -L21*U13) )*L22
      U24     = ( (B(2,4,L) -L21*U14) )*L22
      U25     = ( (B(2,5,L) -L21*U15) )*L22
      L31     = B(3,1,L)
      L32     = B(3,2,L) -L31*U12
      L33     = 1.E0/( ((B(3,3,L) -L31*U13)
     *                  -L32*U23))
      U34     = ( ((B(3,4,L) -L31*U14) -L32*U24) )*
     *             L33
      U35     = ( ((B(3,5,L) -L31*U15) -L32*U25) )*
     *             L33
      L41     = B(4,1,L)
      L42     = B(4,2,L) -L41*U12
      L43     = ((B(4,3,L) -L41*U13) -L42*U23)
      L44     = 1.E0/( ((B(4,4,L) -L41*U14) -L42*U24)
     *             -L43*U34 )
      U45     = ( ((B(4,5,L) -L41*U15) -L42*U25)
     *             -L43*U35 )*L44
      L51     = B(5,1,L)
      L52     = (B(5,2,L) -L51*U12)
      L53     = (B(5,3,L) -L51*U13) -L52*U23
      L54     = ((B(5,4,L) -L51*U14) -L52*U24)
     *             -L53*U34
      L55     = 1.E0/((((B(5,5,L) -L51*U15) -L52*U25)
     *             -L53*U35) -L54*U45 )
   20 CONTINUE
C
C**********    STEP 3.  SOLVE FOR INTERMEDIATE VECTOR    ***************
C
C         A.  CONSTRUCT RHS
C
      IF (L.EQ.LS) GO TO 34
C MARK COMMAND 32      
      S(J,K,L,1) = ((((S(J,K,L,1) -A(1,1,L)*S(J,K,L-1,1))
     *            -A(1,2,L)*S(J,K,L-1,2)) -A(1,3,L)*S(J,K,L-1,3))
     *            -A(1,4,L)*S(J,K,L-1,4)) -A(1,5,L)*S(J,K,L-1,5)
      S(J,K,L,2) = ((((S(J,K,L,2) -A(2,1,L)*S(J,K,L-1,1))
     *            -A(2,2,L)*S(J,K,L-1,2)) -A(2,3,L)*S(J,K,L-1,3))
     *            -A(2,4,L)*S(J,K,L-1,4)) -A(2,5,L)*S(J,K,L-1+I1,5)
      S(J,K,L,3) = ((((S(J,K,L,3) -A(3,1,L)*S(J,K,L-1,1))
     *            -A(3,2,L)*S(J,K,L-1,2)) -A(3,3,L)*S(J,K,L-1,3))
     *            -A(3,4,L)*S(J,K,L-1,4)) -A(3,5,L)*S(J,K,L-1+I2,5)
      S(J,K,L,4) = ((((S(J,K,L,4) -A(4,1,L)*S(J,K,L-1,1))
     *            -A(4,2,L)*S(J,K,L-1,2)) -A(4,3,L)*S(J,K,L-1,3))
     *            -A(4,4,L)*S(J,K,L-1,4)) -A(4,5,L)*S(J,K,L-1+I3,5)
      S(J,K,L,5) = ((((S(J,K,L,5) -A(5,1,L)*S(J,K,L-1,1))
     *            -A(5,2,L)*S(J,K,L-1,2)) -A(5,3,L)*S(J,K,L-1,3))
     *            -A(5,4,L)*S(J,K,L-1,4)) -A(5,5,L)*S(J,K,L-1+I4,5)
   33 CONTINUE
C
C         B. INTERMEDIATE VECTOR
C
      IMARK=IMARK 
C MARK COMMAND 39      
      IMARK=IMARK 
   34 CONTINUE
C
C         FWD SUBSTITUTION
C
      D1         = S(J,K,L,1)*L11
      D2         = ( S(J,K,L,2) -L21*D1 )*L22
      D3         = ( (S(J,K,L,3) -L31*D1) -L32*D2 )*L33
      D4         = ( ((S(J,K,L,4) -L41*D1) -L42*D2) -L43*D3 )
     *              *L44
      D5         = ( (((S(J,K,L,5) -L51*D1) -L52*D2) -L53*D3)
     *              -L54*D4 )*L55
C
C         BWD SUBSTITUTION
C
      S(J,K,L,5)  = D5
      S(J,K,L,4)  = D4 -U45*D5
      S(J,K,L,3)  = (D3 -U34 *S(J,K,L,4)) -U35*D5
      S(J,K,L,2)  = ((D2 -U23*S(J,K,L,3)) -U24*S(J,K,L,4))
     *                -U25*D5
      S(J,K,L,1)  = (((D1 -U12*S(J,K,L,2)) -U13*S(J,K,L,3))
     *              -U14*S(J,K,L,4)) -U15*D5
   35 CONTINUE
C
C**********    STEP 4.  CONSTRUCT U(I) = L(I)**(-1)*C(I+1)    **********
C**********             BY COLUMNS AND STORE IN B            **********
C
      IF (L.EQ.LE) GO TO 100
C MARK COMMAND 32      
C MARK COMMAND 20      
      DO 40 N = 1,5
C MARK COMMAND 21      
      IMARK=IMARK 
C
C         FWD SUBSTITUTION
C
      C1         = C(1,N,L)*L11
      C2         = (C(2,N,L) -L21*C1)*L22
      C3         = ((C(3,N,L) -L31*C1) -L32*C2)*L33
      C4         = (((C(4,N,L) -L41*C1) -L42*C2)
     *             -L43*C3)*L44
      C5         = ((((C(5,N,L) -L51*C1) -L52*C2) -L53*C3)
     *              -L54*C4)*L55
C
C         BWD SUBSTITUTION
C
      B(5,N,L)  = C5
      B(4,N,L)  = C4 -U45*C5
      B(3,N,L)  = (C3 -U34*B(4,N,L)) -U35*C5
      B(2,N,L)  = ((C2 -U23*B(3,N,L)) -U24*B(4,N,L))
     *             -U25*C5
      B(1,N,L)  = (((C1 -U12*B(2,N,L)) -U13*B(3,N,L))
     *              -U14*B(4,N,L)) -U15*C5
   40 CONTINUE
C MARK COMMAND 29      
      IMARK=IMARK 
C MARK COMMAND 39      
      IMARK=IMARK 
  100 CONTINUE
C MARK COMMAND 29      
C
C     PART 2.  BACKWARD BLOCK SWEEP
C
C     DEFINE LEM1 TO RUN PARAFRASE AND TRACE
      IMARK=IMARK 
C MARK COMMAND 20      
      DO 200 LZZ = LS,13
C MARK COMMAND 21      
      L = 13 + LS - LZZ
      S(J,K,L,1) = ((((S(J,K,L,1) -B(1,1,L)*S(J,K,L+1,1))
     *             -B(1,2,L)*S(J,K,L+1,2)) -B(1,3,L)*S(J,K,L+1,3))
     *             -B(1,4,L)*S(J,K,L+1,4)) -B(1,5,L)*S(J,K,L+1,5)
      S(J,K,L,2) = ((((S(J,K,L,2) -B(2,1,L)*S(J,K,L+1,1))
     *             -B(2,2,L)*S(J,K,L+1,2)) -B(2,3,L)*S(J,K,L+1,3))
     *             -B(2,4,L)*S(J,K,L+1,4)) -B(2,5,L)*S(J,K,L+1+I1,5)
      S(J,K,L,3) = ((((S(J,K,L,3) -B(3,1,L)*S(J,K,L+1,1))
     *             -B(3,2,L)*S(J,K,L+1,2)) -B(3,3,L)*S(J,K,L+1,3))
     *             -B(3,4,L)*S(J,K,L+1,4)) -B(3,5,L)*S(J,K,L+1+I2,5)
      S(J,K,L,4) = ((((S(J,K,L,4) -B(4,1,L)*S(J,K,L+1,1))
     *             -B(4,2,L)*S(J,K,L+1,2)) -B(4,3,L)*S(J,K,L+1,3))
     *             -B(4,4,L)*S(J,K,L+1,4)) -B(4,5,L)*S(J,K,L+1+I3,5)
      S(J,K,L,5) = ((((S(J,K,L,5) -B(5,1,L)*S(J,K,L+1,1))
     *             -B(5,2,L)*S(J,K,L+1,2)) -B(5,3,L)*S(J,K,L+1,3))
     *             -B(5,4,L)*S(J,K,L+1,4)) -B(5,5,L)*S(J,K,L+1+I4,5)
  200 CONTINUE
C MARK COMMAND 29      
      IMARK=IMARK 
      RETURN
      END