cGxrstm.for c c c

C
      SUBROUTINE GXRSTM
C-----------------------------------------------------------------------
C     SUBROUTINE GXRSTM is called from groups 1, 8, 9, 13 and 19 of
C     GREX3 by setting RSTM=T in the Q1 file.
C-----------------------------------------------------------------------
      INCLUDE '/phoenics/d_includ/grdear'
      COMMON/NAMFN/NAMFUN,NAMSUB
      CHARACTER*6 NAMFUN,NAMSUB
      NAMSUB='GXRSTM'
C
      IF(IGR.EQ.1) THEN
        IF(ISC.EQ.2) THEN
          CALL UST12
        ELSEIF(ISC.EQ.3) THEN
C.... Group 1 section 3,    Preliminary.
          CALL UPRELM('RSTMGR OF 110310 VISITED                ')
        ENDIF
      ELSEIF(IGR.EQ.8) THEN
        IF(ISC.EQ.10) THEN
C.... Group 8 section 10,   Convection neighbours   UCONNE=GRND
          CALL UCNMOD
        ELSEIF(ISC.EQ.9) THEN
C.... Group 8 section 9,    Diffusion coefficients  UDIFF=GRND
          CALL UDFMOD
        ELSEIF(ISC.EQ.12) THEN
C.... Group 8 section 12,   Linearised sources      USOURC=GRND
          CALL UTURSO
        ENDIF
      ELSEIF(IGR.EQ.9) THEN
C.... Group 9 section 12,   Phase-1 length scale    EL1=GRND
        IF(ISC.EQ.12) THEN
          CALL URSLEN
C.... Group 9 section 5,    Turbulent viscosity     ENUT=GRND
        ELSEIF(ISC.EQ.5) THEN
          CALL URSVIS
        ENDIF
      ELSEIF(IGR.EQ.13) THEN
        IF(ISC.EQ.2) THEN
C.... Group 13 section 2,   Boundary conditions     CO=GRND1
          CALL UCOGND
        ELSEIF(ISC.EQ.13) THEN
C.... Group 13 section 13,  Boundary conditions     VAL=GRND1
          CALL UVLGND
        ENDIF
      ELSEIF(IGR.EQ.19) THEN
        IF(ISC.EQ.3) THEN
C.... Group 19 section 3,   Start of iz slab.
          CALL UST193
        ELSEIF(ISC.EQ.4) THEN
C.... Group 19 section 4,   Start of iterations.
          CALL UST194
        ELSEIF(ISC.EQ.9) THEN
C.... Group 19 section 9,   Start of solution sequence for a variable
          CALL UST199
        ENDIF
      ENDIF
      NAMSUB='gxrstm'
      END
C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C.... UPRELM is called from Gr.1 Sec.3 to provide necessary memory
C     allocation and RSTM constants setting.
C
      SUBROUTINE UPRELM(STRNG)
      include '/phoenics/d_includ/farray'
      INCLUDE '/phoenics/d_includ/satear'
      INCLUDE '/phoenics/d_includ/grdear'
      INCLUDE '/phoenics/d_includ/satgrd'
      INCLUDE '/phoenics/d_includ/grdloc'
      INCLUDE '/phoenics/d_includ/grdbfc'
      INCLUDE '/phoenics/d_includ/rsmcmn'
      COMMON/GENI/  IGNF1(42),NFTOT,IGNF2(17)
C#### MRM 12.04.16 Introduce  facility to store 2nd-phase velocity gradients 
     1      /LBDFDL/IDUDX,IDUDY,IDUDZ,IDVDX,IDVDY,IDVDZ,IDWDX,IDWDY,
     1              IDWDZ,IDSDX,IDSDY,IDSDZ,IDU2X,IDU2Y,IDU2Z,IDV2X,
     1              IDV2Y,IDV2Z,IDW2X,IDW2Y,IDW2Z
     1      /LRNTM3/L0UTAU,NMWALL,L0WALL,L0DSKN,IVPRST
     1      /LRSTM/ LSTU1,LSTV1,LSTW1,LSTKE,LSTREP,LSTRHO
     1      /JRSTM/ JPK,JEPDK,JDZ,JAH,JPU2,JPV2,JPW2,JPUV,JPUW,JPVW,
     1              JDU2,JDV2,JDW2,JDUV,JDUW,JDVW,JFWAL,JU2DK,JV2DK,
     1              JW2DK,JUVDK,JUWDK,JVWDK,JPUS1,JPVS1,JPWS1,JPUS2,
     1              JPVS2,JPWS2,JBU2,JBV2,JBW2,JBUV,JBUW,JBVW,JSU2,
     1              JSV2,JSW2,JSUV,JSUW,JSVW,JOU2,JOV2,JOW2,JOUV,
     1              JOUW,JOVW
     1      /RSTMCM/L0GTRS,L0PRTR
     1      /RSTTNC/L0TURB,L0NORM,L0CROS
      COMMON/INDAUX/L0ISL,L0IST,L0SL,L0ST,NSTO,NSOL,IFL(14)
      LOGICAL GRN,LSTU1,LSTV1,LSTW1,LSTKE,LSTREP,LSTRHO
      CHARACTER STRNG*40,NM12*2,NM23*2
      CHARACTER*6 NAMFUN,NAMSUB
C
      NAMSUB='UPRELM'
C.... Preliminaries (MAKE's below work as precaution only)
      NXNY= NX*NY
      NXM1NY= NXNY-NY
      CALL WRYT40(STRNG)
      CALL MAKE(LVOL)
      CALL MAKE(LXYXU)
      CALL MAKE(LXYXG)
      CALL MAKE(LXYDX)
      CALL MAKE(LXYDXG)
      CALL MAKE(LXYYV)
      CALL MAKE(LXYYG)
      CALL MAKE(LXYDY)
      CALL MAKE(LXYDYG)
      CALL MAKE(LXYDZ)
      IF(.NOT.CARTES) CALL MAKE(LXYR)
      IF(.NOT.CARTES) CALL MAKE(LXYRV)
      IF(NX.NE.1) CALL MAKE(LAEX)
      IF(NY.NE.1) CALL MAKE(LANY)
      IF(NZ.NE.1 .AND. .NOT.PARAB) CALL MAKE(LAHZ)
      IF(USOURC) CALL GXMAKE(L0GTRS,NSOL,'GTOTRS')
      CALL GXMAKE(L0PRTR,NSOL,'GPRTRS')
      CALL GXMAKE(L0GCRT,NSOL,'GCSRAT')
      CALL GXMAKE(L0GCRS,NSOL,'GC1RS')
      CALL GXMAKE(L0TURB,NSOL,'GTURB')
      CALL GXMAKE(L0NORM,NSOL,'GNORM')
      CALL GXMAKE(L0CROS,NSOL,'GCROS')
C.... Set auxiliary logicals:
      CALL SUB3L( LSTU1,STORE(U1), LSTV1, STORE(V1), LSTW1, STORE(W1) )
      CALL SUB3L( LSTKE,STORE(KE), LSTREP,STORE(EP), LSTRHO,GRN(RHO1) )
      CALL SUB3( J0U1,0, J0V1,0, J0W1,0 )
      CALL SUB2( J0KE,0, J0EP,0)
C.... Find LB-indices of stored variables:
      CALL SUB2( JU2RS,LBNAME('U2RS'), JV2RS,LBNAME('V2RS') )
      CALL SUB2( JW2RS,LBNAME('W2RS'), JUVRS,LBNAME('UVRS') )
      CALL SUB2( JUWRS,LBNAME('UWRS'), JVWRS,LBNAME('VWRS') )
      CALL SUB4( J0U2RS,0, J0V2RS,0, J0W2RS,0, J0DFRS,0)
      CALL SUB3( J0UVRS,0, J0UWRS,0, J0VWRS,0)
C.... Set RSTM constants and provide additional memory:
      JTURML= 0
      IF(LSTREP) JTURML= 1
      IF(JVWRS.NE.0 .OR. JUVRS.NE.0 .OR. JUWRS.NE.0) JTURML= 2
      IF(JTURML.EQ.2 .AND. .NOT.SOLVE(EP)) JTURML= 3
      TAUDKE= 0.3
      IF(JTURML.EQ.2) THEN
        TAUDKE= 0.255
        IF(IRSMSM.EQ.0 .AND. NMWALL.EQ.0) TAUDKE= 0.339
      ENDIF
      IF(IRSMHM.EQ.3) TAUDKE= 0.332
      CALL SUB3R( CMUCD,TAUDKE*TAUDKE, CD,TAUDKE**1.5, C1E,1.44 )
      CALL SUB4R( CMU,CMUCD/CD, C2E,1.92, AK,0.41, EWAL,8.6 )
      CALL SUB3R( GA1,0.5, GA2,0.5,  GA3,1.0  )
      IF(IRSMHM.EQ.0) THEN
        CALL WRIT40('RSTM: IPM Pressure-Strain model         ')
        CALL SUB3R(GCS ,0.22, GC1 , 1.8,  GC2    ,0.6  )
        CALL SUB3R(GCE1,1.45, GCE2, 1.9,  PRT(EP),1.22 )
        CALL SUB3R(GC1W,0.5 , GC2W, 0.3,  GALF   ,0.6  )
        CALL SUB4R(GCST,0.15, GC1T, 3.0,  GC2T   ,0.5, GC1TW, 0.5)
      ELSEIF(IRSMHM.EQ.1) THEN
        CALL WRIT40('RSTM: IPY Pressure-Strain model         ')
        CALL SUB3R(GCS ,0.22, GC1 , 3.0 , GC2    , 0.3   )
        CALL SUB3R(GCE1,1.4 , GCE2, 1.8 , PRT(EP), 1.47  )
        CALL SUB3R(GC1W,0.75, GC2W, 0.5 , GALF   , 0.3   )
        CALL SUB4R(GCST,0.15, GC1T, 2.85, GC2T   , 0.55, GC1TW, 1.2)
      ELSEIF(IRSMHM.EQ.2) THEN
        CALL WRIT40('RSTM: QIM Pressure-Strain model         ')
        CALL SUB3R(GCS ,0.21, GC1 , 1.5 , GC2    , 0.4             )
        CALL SUB3R(GCE1,1.44, GCE2, 1.9 , PRT(EP), 1.4             )
        CALL SUB3R(GC1W,0.5 , GC2W, 0.06, GALF   , (GC2+8.)/11.    )
        CALL SUB2R(GBET,(8.*GC2-2.)/11. , GGAM   , (30.*GC2-2.)/55.)
        CALL SUB4R(GCST,0.11, GC1T,2.45 , GC2T   ,  0.66, GC1TW,0.8)
      ELSEIF(IRSMHM.EQ.3) THEN
        CALL WRIT40('RSTM: SSG Pressure-Strain model         ')
        CALL SUB4R(GCS  ,0.22, GC1 , 3.4,  GC2    ,4.2 , GC3ST,1.30)
        CALL SUB4R(GCE1 ,1.44, GCE2, 1.83, PRT(EP),1.22, GALF, 4.2 )
        CALL SUB4R(GC1ST,1.80, GC3 , 0.8,  GC4    ,1.25, GC5,  0.4 )
        CALL SUB3R(GCST, 0.15, GC1T, 3.62, GC2T   ,0.05)
C.... The following values recover the IPM & QIM models without wall
C     dumping:
C        CALL SUB4R(GC1ST,0.0, GC3ST,0.0, GC2,0.0, GALF,0.0)
C.... IPM model:
C        CALL SUB3R(GCE1,1.45, GCE2,1.9, PRT(EP),1.22 )
C        CALL SUB4R(GC1, 3.6,  GC3, 0.8, GC4,    1.2, GC5,1.2)
C.... QIM model:
C        CALL SUB3R(GCE1,1.44, GCE2,1.9, PRT(EP),1.4)
C        CALL SUB3R(GC1, 3.0,  GC3, 0.8, GC4,    1.75)
C        CALL SUB2R(GC5, 1.31, GCS, 0.21)
      ENDIF
      IF(IRSMSM.EQ.1) GCST= 0.3
      RTTDKE= CMUCD**0.25
      IF(JTURML.EQ.1) GCS= 0.09
      JSTO= NSTO
      DO 10 I=1,NSOL
        MPH=MSL(I)
        F(L0GCRT+ I)= 1.0
        F(L0GCRS+ I)= GC1
        IF(IRSMHM.EQ.3) F(L0GCRS+ I)= 0.5*GC1
        F(L0PRTR+ I)= PRT(MPH)
  10  CONTINUE
      CALL SUB3( JUMPX,NY, JUMPY,1, JUMPZ,JSTO*NXNY )
      CALL GXMAKE(J0NXY ,NXNY,'NXY ')
      CALL GXMAKE(J0NXY2,NXNY,'NXY2')
      CALL GXMAKE(J0NXY3,NXNY,'NXY3')
C.... Find LB's for stored variables:
      CALL SUB2( JPK,  LBNAME('PK  '), JEPDK,LBNAME('EPDK') )
      CALL SUB2( JDZ,  LBNAME('DZ  '), JAH,  LBNAME('AH  ') )
      CALL SUB2( JPU2, LBNAME('PU2 '), JPV2, LBNAME('PV2 ') )
      CALL SUB2( JPW2, LBNAME('PW2 '), JPUV, LBNAME('PUV ') )
      CALL SUB2( JPUW, LBNAME('PUW '), JPVW, LBNAME('PVW ') )
      CALL SUB2( JDU2, LBNAME('DU2 '), JDV2, LBNAME('DV2 ') )
      CALL SUB2( JDW2, LBNAME('DW2 '), JDUV, LBNAME('DUV ') )
      CALL SUB2( JDUW, LBNAME('DUW '), JDVW, LBNAME('DVW ') )
      CALL SUB2( JFWAL,LBNAME('FWAL'), JU2DK,LBNAME('U2DK') )
      CALL SUB2( JV2DK,LBNAME('V2DK'), JW2DK,LBNAME('W2DK') )
      CALL SUB2( JUVDK,LBNAME('UVDK'), JUWDK,LBNAME('UWDK') )
      JVWDK= LBNAME('VWDK')
C.... LB's for SSG pressure-strain model:
      CALL SUB2( JBU2,LBNAME('BU2 '), JBV2,LBNAME('BV2 ') )
      CALL SUB2( JBW2,LBNAME('BW2 '), JBUV,LBNAME('BUV ') )
      CALL SUB2( JBUW,LBNAME('BUW '), JBVW,LBNAME('BVW ') )
      CALL SUB2( JSU2,LBNAME('SU2 '), JSV2,LBNAME('SV2 ') )
      CALL SUB2( JSW2,LBNAME('SW2 '), JSUV,LBNAME('SUV ') )
      CALL SUB2( JSUW,LBNAME('SUW '), JSVW,LBNAME('SVW ') )
      CALL SUB2( JOU2,LBNAME('OU2 '), JOV2,LBNAME('OV2 ') )
      CALL SUB2( JOW2,LBNAME('OW2 '), JOUV,LBNAME('OUV ') )
      CALL SUB2( JOUW,LBNAME('OUW '), JOVW,LBNAME('OVW ') )
      IF(JTURML.NE.0) THEN
C.... Provide slab-wise storage if there is no 3D-storage:
C.... Note! LB-indices IDUDX,...,IDWDZ are defined in EARTH
        IF(IDUDX.EQ.0) CALL GXMAKE(J0DUDX,NXNY,'DUDX')
        IF(IDUDY.EQ.0) CALL GXMAKE(J0DUDY,NXNY,'DUDY')
        IF(IDUDZ.EQ.0) CALL GXMAKE(J0DUDZ,NXNY,'DUDZ')
        IF(IDVDX.EQ.0) CALL GXMAKE(J0DVDX,NXNY,'DVDX')
        IF(IDVDY.EQ.0) CALL GXMAKE(J0DVDY,NXNY,'DVDY')
        IF(IDVDZ.EQ.0) CALL GXMAKE(J0DVDZ,NXNY,'DVDZ')
        IF(IDWDX.EQ.0) CALL GXMAKE(J0DWDX,NXNY,'DWDX')
        IF(IDWDY.EQ.0) CALL GXMAKE(J0DWDY,NXNY,'DWDY')
        IF(IDWDZ.EQ.0) CALL GXMAKE(J0DWDZ,NXNY,'DWDZ')
        IF(JPK  .EQ.0) CALL GXMAKE(J0PK  ,NXNY,'PK  ')
        IF(JEPDK.EQ.0) CALL GXMAKE(J0EPDK,NXNY,'EPDK')
        IF(JDZ  .EQ.0) CALL GXMAKE(J0DZ  ,NXNY,'DZ  ')
        IF(PARAB .AND. JAH.EQ.0) CALL GXMAKE(J0AH  ,NXNY,'AH  ')
        IF(.NOT.LSTRHO) CALL GXMAKE(J0DEN1,NXNY,'DEN1')
        IF(JTURML.GT.1) THEN
          IF(JPU2 .EQ.0) CALL GXMAKE(J0PU2 ,NXNY,'PU2 ')
          IF(JPV2 .EQ.0) CALL GXMAKE(J0PV2 ,NXNY,'PV2 ')
          IF(JPW2 .EQ.0) CALL GXMAKE(J0PW2 ,NXNY,'PW2 ')
          IF(JPUV .EQ.0) CALL GXMAKE(J0PUV ,NXNY,'PUV ')
          IF(JPUW .EQ.0) CALL GXMAKE(J0PUW ,NXNY,'PUW ')
          IF(JPVW .EQ.0) CALL GXMAKE(J0PVW ,NXNY,'PVW ')
          IF(JDU2 .EQ.0) CALL GXMAKE(J0DU2 ,NXNY,'DU2 ')
          IF(JDV2 .EQ.0) CALL GXMAKE(J0DV2 ,NXNY,'DV2 ')
          IF(JDW2 .EQ.0) CALL GXMAKE(J0DW2 ,NXNY,'DW2 ')
          IF(JDUV .EQ.0) CALL GXMAKE(J0DUV ,NXNY,'DUV ')
          IF(JDUW .EQ.0) CALL GXMAKE(J0DUW ,NXNY,'DUW ')
          IF(JDVW .EQ.0) CALL GXMAKE(J0DVW ,NXNY,'DVW ')
          IF(JFWAL.EQ.0) CALL GXMAKE(J0WDPC,NXNY,'WDPC')
          IF(JU2DK.EQ.0) CALL GXMAKE(J0U2DK,NXNY,'U2DK')
          IF(JV2DK.EQ.0) CALL GXMAKE(J0V2DK,NXNY,'V2DK')
          IF(JW2DK.EQ.0) CALL GXMAKE(J0W2DK,NXNY,'W2DK')
          IF(JUVDK.EQ.0) CALL GXMAKE(J0UVDK,NXNY,'UVDK')
          IF(JUWDK.EQ.0) CALL GXMAKE(J0UWDK,NXNY,'UWDK')
          IF(JVWDK.EQ.0) CALL GXMAKE(J0VWDK,NXNY,'VWDK')
C.... Memory allocation for SSG pressure-strain model
          IF(IRSMHM.EQ.3) THEN
            IF(JBU2.EQ.0) CALL GXMAKE(J0BU2 ,NXNY,'BU2 ')
            IF(JBV2.EQ.0) CALL GXMAKE(J0BV2 ,NXNY,'BV2 ')
            IF(JBW2.EQ.0) CALL GXMAKE(J0BW2 ,NXNY,'BW2 ')
            IF(JBUV.EQ.0) CALL GXMAKE(J0BUV ,NXNY,'BUV ')
            IF(JBUW.EQ.0) CALL GXMAKE(J0BUW ,NXNY,'BUW ')
            IF(JBVW.EQ.0) CALL GXMAKE(J0BVW ,NXNY,'BVW ')
            IF(JSU2.EQ.0) CALL GXMAKE(J0SU2 ,NXNY,'SU2 ')
            IF(JSV2.EQ.0) CALL GXMAKE(J0SV2 ,NXNY,'SV2 ')
            IF(JSW2.EQ.0) CALL GXMAKE(J0SW2 ,NXNY,'SW2 ')
            IF(JSUV.EQ.0) CALL GXMAKE(J0SUV ,NXNY,'SUV ')
            IF(JSUW.EQ.0) CALL GXMAKE(J0SUW ,NXNY,'SUW ')
            IF(JSVW.EQ.0) CALL GXMAKE(J0SVW ,NXNY,'SVW ')
            IF(JOU2.EQ.0) CALL GXMAKE(J0OU2 ,NXNY,'OU2 ')
            IF(JOV2.EQ.0) CALL GXMAKE(J0OV2 ,NXNY,'OV2 ')
            IF(JOW2.EQ.0) CALL GXMAKE(J0OW2 ,NXNY,'OW2 ')
            IF(JOUV.EQ.0) CALL GXMAKE(J0OUV ,NXNY,'OUV ')
            IF(JOUW.EQ.0) CALL GXMAKE(J0OUW ,NXNY,'OUW ')
            IF(JOVW.EQ.0) CALL GXMAKE(J0OVW ,NXNY,'OVW ')
            CALL GXMAKE(J0R3U2 ,NXNY,'R3U2')
            CALL GXMAKE(J0R3V2 ,NXNY,'R3V2')
            CALL GXMAKE(J0R3W2 ,NXNY,'R3W2')
            CALL GXMAKE(J0R3UV ,NXNY,'R3UV')
            CALL GXMAKE(J0R3UW ,NXNY,'R3UW')
            CALL GXMAKE(J0R3VW ,NXNY,'R3VW')
            CALL GXMAKE(J0R4U2 ,NXNY,'R4U2')
            CALL GXMAKE(J0R4V2 ,NXNY,'R4V2')
            CALL GXMAKE(J0R4W2 ,NXNY,'R4W2')
            CALL GXMAKE(J0R4UV ,NXNY,'R4UV')
            CALL GXMAKE(J0R4UW ,NXNY,'R4UW')
            CALL GXMAKE(J0R4VW ,NXNY,'R4VW')
            CALL GXMAKE(J0R5U2 ,NXNY,'R5U2')
            CALL GXMAKE(J0R5V2 ,NXNY,'R5V2')
            CALL GXMAKE(J0R5W2 ,NXNY,'R5W2')
            CALL GXMAKE(J0R5UV ,NXNY,'R5UV')
            CALL GXMAKE(J0R5UW ,NXNY,'R5UW')
            CALL GXMAKE(J0R5VW ,NXNY,'R5VW')
          ENDIF
        ENDIF
      ENDIF
      DO 22 I= 1,NSOL
        F(L0TURB+ I)= 0.
        F(L0NORM+ I)= 0.
        F(L0CROS+ I)= 0.
   22 CONTINUE
crj
      IF(SOLVE(KE)) THEN
        F(L0TURB+ ISL(KE))= 1.
        F(L0NORM+ ISL(KE))= 1.
      ENDIF
crj
      IF(SOLVE(EP)) F(L0TURB+ ISL(EP))= 1.
      IF(JTURML.GT.1) THEN
        IF(JU2RS.NE.0) F(L0TURB+ ISL(JU2RS))= 1.
        IF(JU2RS.NE.0) F(L0NORM+ ISL(JU2RS))= 1.
        IF(JV2RS.NE.0) F(L0TURB+ ISL(JV2RS))= 1.
        IF(JV2RS.NE.0) F(L0NORM+ ISL(JV2RS))= 1.
        IF(JW2RS.NE.0) F(L0TURB+ ISL(JW2RS))= 1.
        IF(JW2RS.NE.0) F(L0NORM+ ISL(JW2RS))= 1.
        IF(JDFRS.NE.0) F(L0TURB+ ISL(JDFRS))= 1.
        IF(JDFRS.NE.0) F(L0NORM+ ISL(JDFRS))= 1.
        IF(JUVRS.NE.0) F(L0TURB+ ISL(JUVRS))= 1.
        IF(JUVRS.NE.0) F(L0CROS+ ISL(JUVRS))= 1.
        IF(JUWRS.NE.0) F(L0TURB+ ISL(JUWRS))= 1.
        IF(JUWRS.NE.0) F(L0CROS+ ISL(JUWRS))= 1.
        IF(JVWRS.NE.0) F(L0TURB+ ISL(JVWRS))= 1.
        IF(JVWRS.NE.0) F(L0CROS+ ISL(JVWRS))= 1.
      ENDIF
      IF(JTURML.GT.1) THEN
        PRT(U1)= 1.E10
        PRT(V1)= 1.E10
        PRT(W1)= 1.E10
        PRNDTL(EP)= 1.E10
        VARMIN(EP)= 1.E-10
        PRNDTL(JU2RS)= 1.E10
        VARMIN(JU2RS)= 1.E-10
        PRNDTL(JV2RS)= 1.E10
        VARMIN(JV2RS)= 1.E-10
        PRNDTL(JW2RS)= 1.E10
        VARMIN(JW2RS)= 1.E-10
        IF(JUVRS.NE.0) PRNDTL(JUVRS)= 1.E10
        IF(JUWRS.NE.0) PRNDTL(JUWRS)= 1.E10
        IF(JVWRS.NE.0) PRNDTL(JVWRS)= 1.E10
      ENDIF
      NUMSCM=0
      DO 23 I=1,NSOL
        MPH=MSL(I)
        IF(MPH.GE.14) THEN
          NM12=NAME(MPH)(1:2)
          NM23=NAME(MPH)(2:3)
          IF(MPH.EQ.H1.OR.NAME(MPH).EQ.'TEM1'.OR.NM12.EQ.'SC') THEN
            NUMSCM=NUMSCM+1
            F(L0GCRT+ I)=CMUCD/GCS
          ELSEIF(NM23.EQ.'SC'.OR.NM23.EQ.'TR') THEN
CRJ          IF(SOLVE(MPH)) THEN
            F(L0TURB+ I)=1.
            F(L0GCRT+ I)=GCST/GCS
            F(L0GCRS+ I)=GC1T
            PRNDTL(MPH)=1.E10
CRJ          ENDIF
          ENDIF
        ENDIF
   23 CONTINUE
C.... JSCAML=0 - no heat/mass transfer
C     JSCAML=1 - simple gradient model for turbulent fluxes
C           =2 - generalised gradient model for fluxes
C           =3 - full transport model for fluxes
      JSCAML=0
      IF(NUMSCM.GT.0) JSCAML=IRSMSM+1
C.... Find LB's for stored variables:
      JTEM1= LBNAME('TEM1')
      CALL SUB2( JUTRS,LBNAME('UTRS'), JVTRS,LBNAME('VTRS') )
      CALL SUB2( JWTRS,LBNAME('WTRS'), IDSDX,LBNAME('DSDX') )
      CALL SUB2( IDSDY,LBNAME('DSDY'), IDSDZ,LBNAME('DSDZ') )
      CALL SUB2( JPUS1,LBNAME('PUS1'), JPVS1,LBNAME('PVS1') )
      CALL SUB2( JPWS1,LBNAME('PWS1'), JPUS2,LBNAME('PUS2') )
      CALL SUB2( JPVS2,LBNAME('PVS2'), JPWS2,LBNAME('PWS2') )
      IF(JSCAML.GT.1) THEN
C.... Create slab-wise storage for scalar gradient:
        IF(IDSDX.EQ.0) CALL GXMAKE(J0DSDX,NXNY,'DSDX')
        IF(IDSDY.EQ.0) CALL GXMAKE(J0DSDY,NXNY,'DSDY')
        IF(IDSDZ.EQ.0) CALL GXMAKE(J0DSDZ,NXNY,'DSDZ')
        DO 24 I=H1,NPHI
          IF(STORE(I)) THEN
            NM12=NAME(I)(1:2)
            IF(I.EQ.H1.OR.NAME(I).EQ.'TEM1'.OR.NM12.EQ.'SC')
     1         PRT(I)=1.E10
          ENDIF
   24   CONTINUE
      ENDIF
      IF(JSCAML.EQ.3) THEN
        IF(JPUS1.EQ.0) CALL GXMAKE(J0PUS1,NXNY,'PUS1')
        IF(JPVS1.EQ.0) CALL GXMAKE(J0PVS1,NXNY,'PVS1')
        IF(JPWS1.EQ.0) CALL GXMAKE(J0PWS1,NXNY,'PWS1')
        IF(JPUS2.EQ.0) CALL GXMAKE(J0PUS2,NXNY,'PUS2')
        IF(JPVS2.EQ.0) CALL GXMAKE(J0PVS2,NXNY,'PVS2')
        IF(JPWS2.EQ.0) CALL GXMAKE(J0PWS2,NXNY,'PWS2')
      ENDIF
      NAMSUB= 'uprelm'
      END
C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C
      SUBROUTINE UST12
C-----------------------------------------------------------------------
C     SUBROUTINE UST12 is called from section 2, group 1 of GXRSTM
C     to define
C-----------------------------------------------------------------------
      include '/phoenics/d_includ/farray'
      INCLUDE '/phoenics/d_includ/satear'
      INCLUDE '/phoenics/d_includ/satgrd'
      INCLUDE '/phoenics/d_includ/grdloc'
      INCLUDE '/phoenics/d_includ/rsmcmn'
      COMMON /NAMFN/NAMFUN,NAMSUB
      CHARACTER*6 NAMFUN,NAMSUB
C
      NAMSUB = 'UST12'
      CALL SUB2(J0DX,L0F(LXYDX), J0DY,L0F(LXYDY))
      IF(NX.NE.1) THEN
        CALL SUB3(J0DXG,L0F(LXYDXG), J0XG,L0F(LXYXG), J0XU,L0F(LXYXU))
        J0AE= L0F(LAEX)
      ENDIF
      IF(NY.NE.1) THEN
        CALL SUB3(J0DYG,L0F(LXYDYG), J0YG,L0F(LXYYG), J0YV,L0F(LXYYV))
        J0AN= L0F(LANY)
      ENDIF
      IF(.NOT.CARTES) CALL SUB2(J0R,L0F(LXYR), J0RV,L0F(LXYRV))
      IF(NZ.NE.1 .AND. .NOT.PARAB) J0AH= L0F(LAHZ)
      J0VOL= L0F(LVOL)
      NAMSUB = 'ust12'
      END
C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C.... UST193 is called from Gr.19 Sec.3 to set addresses for a slab.
C
      SUBROUTINE UST193
      include '/phoenics/d_includ/farray'
      INCLUDE '/phoenics/d_includ/satear'
      INCLUDE '/phoenics/d_includ/grdear'
      INCLUDE '/phoenics/d_includ/satgrd'
      INCLUDE '/phoenics/d_includ/grdloc'
      INCLUDE '/phoenics/d_includ/grdbfc'
      INCLUDE '/phoenics/d_includ/rsmcmn'
      COMMON/LGRND/ LG(20)/IGRND/IG(20)/RGRND/RG(100)/CGRND/CG(10)
C#### MRM 12.04.16 Introduce  facility to store 2nd-phase velocity gradients 
     1      /LBDFDL/IDUDX,IDUDY,IDUDZ,IDVDX,IDVDY,IDVDZ,IDWDX,IDWDY,
     1              IDWDZ,IDSDX,IDSDY,IDSDZ,IDU2X,IDU2Y,IDU2Z,IDV2X,
     1              IDV2Y,IDV2Z,IDW2X,IDW2Y,IDW2Z
     1      /GENI/  IGSP1(42),NFTOT,IGSP44(17) /NAMFN/NAMFUN,NAMSUB
     1      /LRSTM/ LSTU1,LSTV1,LSTW1,LSTKE,LSTREP,LSTRHO
     1      /JRSTM/ JPK,JEPDK,JDZ,JAH,JPU2,JPV2,JPW2,JPUV,JPUW,JPVW,
     1              JDU2,JDV2,JDW2,JDUV,JDUW,JDVW,JFWAL,JU2DK,JV2DK,
     1              JW2DK,JUVDK,JUWDK,JVWDK,JPUS1,JPVS1,JPWS1,JPUS2,
     1              JPVS2,JPWS2,JBU2,JBV2,JBW2,JBUV,JBUW,JBVW,JSU2,
     1              JSV2,JSW2,JSUV,JSUW,JSVW,JOU2,JOV2,JOW2,JOUV,
     1              JOUW,JOVW
      LOGICAL LG,LSTU1,LSTV1,LSTW1,LSTKE,LSTREP,LSTRHO
      CHARACTER CG*4,NAMFUN*6,NAMSUB*6
C
      NAMSUB= 'UST193'
      IF(LSTU1) J0U1= L0F(U1)
      IF(LSTV1) J0V1= L0F(V1)
      IF(LSTW1) J0W1= L0F(W1)
      IF(LSTRHO) J0DEN1= L0F(DEN1)
      IF(JTURML.NE.0) THEN
        IF(LSTKE)  J0KE= L0F(KE)
        IF(LSTREP) J0EP= L0F(EP)
        IF(JU2RS.NE.0) J0U2RS= L0F(JU2RS)
        IF(JV2RS.NE.0) J0V2RS= L0F(JV2RS)
        IF(JW2RS.NE.0) J0W2RS= L0F(JW2RS)
        IF(JUVRS.NE.0) J0UVRS= L0F(JUVRS)
        IF(JUWRS.NE.0) J0UWRS= L0F(JUWRS)
        IF(JVWRS.NE.0) J0VWRS= L0F(JVWRS)
        IF(JDFRS.NE.0) J0DFRS= L0F(JDFRS)
        IF(JUTRS.NE.0) J0UTRS= L0F(JUTRS)
        IF(JVTRS.NE.0) J0VTRS= L0F(JVTRS)
        IF(JWTRS.NE.0) J0WTRS= L0F(JWTRS)
        IF(IDUDX.NE.0) J0DUDX= L0F(IDUDX)
        IF(IDUDY.NE.0) J0DUDY= L0F(IDUDY)
        IF(IDUDZ.NE.0) J0DUDZ= L0F(IDUDZ)
        IF(IDVDX.NE.0) J0DVDX= L0F(IDVDX)
        IF(IDVDY.NE.0) J0DVDY= L0F(IDVDY)
        IF(IDVDZ.NE.0) J0DVDZ= L0F(IDVDZ)
        IF(IDWDX.NE.0) J0DWDX= L0F(IDWDX)
        IF(IDWDY.NE.0) J0DWDY= L0F(IDWDY)
        IF(IDWDZ.NE.0) J0DWDZ= L0F(IDWDZ)
        IF(JPK  .NE.0) J0PK  = L0F(JPK)
        IF(JEPDK.NE.0) J0EPDK= L0F(JEPDK)
        IF(JDZ  .NE.0) J0DZ  = L0F(JDZ)
        IF(JAH  .NE.0) J0AH  = L0F(JAH)
        IF(JFWAL.NE.0) J0WDPC= L0F(JFWAL)
        IF(JU2DK.NE.0) J0U2DK= L0F(JU2DK)
        IF(JV2DK.NE.0) J0V2DK= L0F(JV2DK)
        IF(JW2DK.NE.0) J0W2DK= L0F(JW2DK)
        IF(JUVDK.NE.0) J0UVDK= L0F(JUVDK)
        IF(JUWDK.NE.0) J0UWDK= L0F(JUWDK)
        IF(JVWDK.NE.0) J0VWDK= L0F(JVWDK)
        DO 10 I= 1,NXNY
  10      F(J0DZ+I)= DZ
        IF(PARAB) THEN
          DO 20 I= 1,NXNY
  20        F(J0AH+I)= F(J0VOL+I)/F(J0DZ+I)
        ENDIF
C.... Zeroise storage for velocity gradients at first sweep:
        IF(ISWEEP.EQ.FSWEEP) THEN
          CALL ZERNM3(J0DUDX,J0DUDY,J0DUDZ,NXNY)
          CALL ZERNM3(J0DVDX,J0DVDY,J0DVDZ,NXNY)
          CALL ZERNM3(J0DWDX,J0DWDY,J0DWDZ,NXNY)
        ENDIF
      ENDIF
      IF(JTURML.GT.1) THEN
        IF(JPU2.NE.0) J0PU2= L0F(JPU2)
        IF(JPV2.NE.0) J0PV2= L0F(JPV2)
        IF(JPW2.NE.0) J0PW2= L0F(JPW2)
        IF(JPUV.NE.0) J0PUV= L0F(JPUV)
        IF(JPUW.NE.0) J0PUW= L0F(JPUW)
        IF(JPVW.NE.0) J0PVW= L0F(JPVW)
        IF(JDU2.NE.0) J0DU2= L0F(JDU2)
        IF(JDV2.NE.0) J0DV2= L0F(JDV2)
        IF(JDW2.NE.0) J0DW2= L0F(JDW2)
        IF(JDUV.NE.0) J0DUV= L0F(JDUV)
        IF(JDUW.NE.0) J0DUW= L0F(JDUW)
        IF(JDVW.NE.0) J0DVW= L0F(JDVW)
        IF(IRSMHM.EQ.3) THEN
          IF(JBU2.NE.0) J0BU2= L0F(JBU2)
          IF(JBV2.NE.0) J0BV2= L0F(JBV2)
          IF(JBW2.NE.0) J0BW2= L0F(JBW2)
          IF(JBUV.NE.0) J0BUV= L0F(JBUV)
          IF(JBUW.NE.0) J0BUW= L0F(JBUW)
          IF(JBVW.NE.0) J0BVW= L0F(JBVW)
          IF(JSU2.NE.0) J0SU2= L0F(JSU2)
          IF(JSV2.NE.0) J0SV2= L0F(JSV2)
          IF(JSW2.NE.0) J0SW2= L0F(JSW2)
          IF(JSUV.NE.0) J0SUV= L0F(JSUV)
          IF(JSUW.NE.0) J0SUW= L0F(JSUW)
          IF(JSVW.NE.0) J0SVW= L0F(JSVW)
          IF(JOU2.NE.0) J0OU2= L0F(JOU2)
          IF(JOV2.NE.0) J0OV2= L0F(JOV2)
          IF(JOW2.NE.0) J0OW2= L0F(JOW2)
          IF(JOUV.NE.0) J0OUV= L0F(JOUV)
          IF(JOUW.NE.0) J0OUW= L0F(JOUW)
          IF(JOVW.NE.0) J0OVW= L0F(JOVW)
        ENDIF
      ENDIF
      IF(JSCAML.GT.1) THEN
        IF(IDSDX.NE.0) J0DSDX= L0F(IDSDX)
        IF(IDSDY.NE.0) J0DSDY= L0F(IDSDY)
        IF(IDSDZ.NE.0) J0DSDZ= L0F(IDSDZ)
      ENDIF
      IF(JSCAML.EQ.3) THEN
        IF(JPUS1.NE.0) J0PUS1= L0F(LBNAME('PUS1'))
        IF(JPVS1.NE.0) J0PVS1= L0F(LBNAME('PVS1'))
        IF(JPWS1.NE.0) J0PWS1= L0F(LBNAME('PWS1'))
        IF(JPUS2.NE.0) J0PUS2= L0F(LBNAME('PUS2'))
        IF(JPVS2.NE.0) J0PVS2= L0F(LBNAME('PVS2'))
        IF(JPWS2.NE.0) J0PWS2= L0F(LBNAME('PWS2'))
      ENDIF
      NAMSUB= 'ust193'
      END
C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C.... UST194 is called from Gr.19 Sec.4
C
      SUBROUTINE UST194
      include '/phoenics/d_includ/farray'
      INCLUDE '/phoenics/d_includ/satear'
      INCLUDE '/phoenics/d_includ/grdear'
      INCLUDE '/phoenics/d_includ/satgrd'
      INCLUDE '/phoenics/d_includ/grdloc'
      INCLUDE '/phoenics/d_includ/grdbfc'
      INCLUDE '/phoenics/d_includ/rsmcmn'
      COMMON/LGRND/LG(20)/IGRND/IG(20)/RGRND/RG(100)/CGRND/CG(10)
     1      /GENI/IGSP1(42),NFTOT,IGSP44(17) /NAMFN/NAMFUN,NAMSUB
     1      /LRSTM/ LSTU1,LSTV1,LSTW1,LSTKE,LSTREP,LSTRHO
      LOGICAL LG,NEZ,LSTU1,LSTV1,LSTW1,LSTKE,LSTREP,LSTRHO
      CHARACTER CG*4,NAMFUN*6,NAMSUB*6
C
      NAMSUB= 'UST194'
      IF(JTURML.EQ.0) RETURN
      IF(.NOT.LSTRHO) THEN
        DO 10 I= 1,NXNY
  10      F(J0DEN1+I)= RHO1
      ENDIF
C.... Note! Velocity derivatives had been already calculated in GXGENF
C     subroutine and put into J0DUDX, etc.
      IF(JTURML.EQ.1) THEN
        CALL UPRODK
          DO 20 I= 1,NXNY
  20      F(J0EPDK+I)= F(J0EP+I)/F(J0KE+I)
      ELSE
        IF(.NOT.(SOLVE(JU2RS).OR.SOLVE(JV2RS).OR.SOLVE(JW2RS))) THEN
          DO 30 I= 1,NXNY
            F(J0U2RS+I)= GA1*F(J0KE+I)
            F(J0V2RS+I)= GA2*F(J0KE+I)
            F(J0W2RS+I)= GA3*F(J0KE+I)
  30      CONTINUE
        ELSEIF(JDFRS.NE.0) THEN
          DO 40 I= 1,NXNY
            TERM= F(J0KE+I) - 0.5*(F(J0W2RS+I)-F(J0DFRS+I))
            F(J0V2RS+I)= TERM
            F(J0U2RS+I)= TERM
  40      CONTINUE
        ELSEIF(.NOT.SOLVE(KE)) THEN
          DO 50 I=1,NXNY
            F(J0U2RS+I)= AMAX1(F(J0U2RS+I),1.E-10)
            F(J0V2RS+I)= AMAX1(F(J0V2RS+I),1.E-10)
            F(J0W2RS+I)= AMAX1(F(J0W2RS+I),1.E-10)
            F(J0KE+I)= 0.5*(F(J0U2RS+I)+F(J0V2RS+I)+F(J0W2RS+I))
            F(J0EP+I)= AMAX1(F(J0EP+I),1.E-10)
  50      CONTINUE
        ENDIF
        CALL UPRDCT
        IF(NEZ(GBET)) CALL UPROD2
        CALL UREDIS
        IF(.NOT.SOLVE(EP)) THEN
          DO 60 I= 1,NXNY
  60        F(J0EP+I)= AMAX1(TINY,F(J0PK+I))
        ENDIF
        DO 70 I= 1,NXNY
          RGFKEI= 1.0/F(J0KE+I)
          F(J0U2DK+I)= F(J0U2RS+I)*RGFKEI
          F(J0V2DK+I)= F(J0V2RS+I)*RGFKEI
          F(J0W2DK+I)= F(J0W2RS+I)*RGFKEI
          F(J0UWDK+I)= F(J0UWRS+I)*RGFKEI
          F(J0UVDK+I)= F(J0UVRS+I)*RGFKEI
          F(J0VWDK+I)= F(J0VWRS+I)*RGFKEI
          F(J0EPDK+I)= F(J0EP+I)*RGFKEI
  70    CONTINUE
      ENDIF
      NAMSUB='ust194'
      END
C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C.... UST199 is called from Gr.19 Sec.9 of GXRSTM
C
      SUBROUTINE UST199
      include '/phoenics/d_includ/farray'
      INCLUDE '/phoenics/d_includ/satear'
      INCLUDE '/phoenics/d_includ/grdear'
      INCLUDE '/phoenics/d_includ/satgrd'
      INCLUDE '/phoenics/d_includ/grdloc'
      INCLUDE '/phoenics/d_includ/grdbfc'
      INCLUDE '/phoenics/d_includ/rsmcmn'
      COMMON /GENI/IGFIL1(49),ITEM1,IGFIL2(10) /NAMFN/NAMFUN,NAMSUB
      LOGICAL GTURB
      CHARACTER*4 NMPH,NMSC,NM11*1,NM23*2,NM24*3,NAMFUN*6,NAMSUB*6
C
      IF(JSCAML.LE.1) RETURN
      NAMSUB= 'UST199'
      IF(JSCAML.EQ.2 .AND. INDVAR.GE.H1.AND. .NOT.GTURB(INDVAR)) THEN
C.... Generalised gradient-diffusion model for the scalar fluxes
        J0SC= L0F(INDVAR)
C.... Compute scalar gradients
        IF(NX.NE.1) THEN
          CALL FNDFDX(J0SC,J0DSDX,IZ,INDVAR.EQ.ITEM1)
        ELSE
          CALL ZERNUM(J0DSDX,NXNY)
        ENDIF
        IF(NY.NE.1) THEN
          CALL FNDFDY(J0SC,J0DSDY,IZ,INDVAR.EQ.ITEM1)
        ELSE
          CALL ZERNUM(J0DSDY,NXNY)
        ENDIF
        IF(NZ.EQ.1 .OR. PARAB) THEN
          CALL ZERNUM(J0DSDZ,NXNY)
        ELSE
          CALL FNDFDZ(J0SC,J0DSDZ,IZ,INDVAR.EQ.ITEM1)
        ENDIF
C
        IF(NX.GT.1) THEN
          J0USCR= J0SCRS(INDVAR,J0UTRS,'U')
          CALL FN0(-J0NXY,-J0USCR)
          DO 10 I= 1,NXNY
  10        F(J0USCR+I)= -F(J0U2RS+I)*F(J0DSDX+I)
          IF(NY.GT.1) THEN
            DO 11 I= 1,NXNY
  11          F(J0USCR+I)= F(J0USCR+I) - F(J0UVRS+I)*F(J0DSDY+I)
          ENDIF
          IF(NZ.GT.1) THEN
            DO 12 I= 1,NXNY
  12          F(J0USCR+I)= F(J0USCR+I) - F(J0UWRS+I)*F(J0DSDZ+I)
          ENDIF
          RELFAC= RELSCR(INDVAR,JUTRS,'U')
            DO 13 I= 1,NXNY
              F(J0USCR+I)= GCST*F(J0USCR+I)/F(J0EPDK+I)
              F(J0USCR+I)= RELFAC*F(J0USCR+I) + (1.-RELFAC)*F(J0NXY+I)
  13        CONTINUE
        ENDIF
C
        IF(NY.GT.1) THEN
          J0VSCR= J0SCRS(INDVAR,J0VTRS,'V')
          CALL FN0(-J0NXY,-J0VSCR)
          DO 20 I= 1,NXNY
  20        F(J0VSCR+I)= -F(J0V2RS+I)*F(J0DSDY+I)
          IF(NX.GT.1) THEN
            DO 21 I= 1,NXNY
  21          F(J0VSCR+I)= F(J0VSCR+I) - F(J0UVRS+I)*F(J0DSDX+I)
          ENDIF
          IF(NZ.GT.1) THEN
            DO 22 I= 1,NXNY
  22          F(J0VSCR+I)= F(J0VSCR+I) - F(J0VWRS+I)*F(J0DSDZ+I)
          ENDIF
          RELFAC= RELSCR(INDVAR,JVTRS,'V')
            DO 23 I= 1,NXNY
              F(J0VSCR+I)= GCST*F(J0VSCR+I)/F(J0EPDK+I)
              F(J0VSCR+I)= RELFAC*F(J0VSCR+I) + (1.-RELFAC)*F(J0NXY+I)
  23        CONTINUE
        ENDIF
C
        IF(NZ.GT.1) THEN
          J0WSCR= J0SCRS(INDVAR,J0WTRS,'W')
          CALL FN0(-J0NXY,-J0WSCR)
          DO 30 I= 1,NXNY
  30        F(J0WSCR+I)= -F(J0W2RS+I)*F(J0DSDZ+I)
          IF(NX.GT.1) THEN
            DO 31 I= 1,NXNY
  31          F(J0WSCR+I)=F(J0WSCR+I)-F(J0UWRS+I)*F(J0DSDX+I)
          ENDIF
          IF(NY.GT.1) THEN
            DO 32 I= 1,NXNY
  32          F(J0WSCR+I)=F(J0WSCR+I)-F(J0VWRS+I)*F(J0DSDY+I)
          ENDIF
          RELFAC= RELSCR(INDVAR,JWTRS,'W')
            DO 33 I= 1,NXNY
              F(J0WSCR+I)= GCST*F(J0WSCR+I)/F(J0EPDK+I)
              F(J0WSCR+I)= RELFAC*F(J0WSCR+I) + (1.-RELFAC)*F(J0NXY+I)
  33        CONTINUE
        ENDIF
C
      ELSEIF(JSCAML.EQ.3 .AND. GTURB(INDVAR)) THEN
C.... Full transport model for the turbulent scalar fluxes
        NMPH= NAME(INDVAR)
        NM11= NAME(INDVAR)(1:1)
        NM23= NAME(INDVAR)(2:3)
        NM24= NAME(INDVAR)(2:4)
        IF(NM23.EQ.'SC') THEN
          NMSC= NM23//NAME(INDVAR)(4:4)
          J0SC= L0F(LBNAME(NMSC))
        ELSEIF(NM24.EQ.'TRS') THEN
          JSCAL= ITWO(H1,ITEM1,SOLVE(H1))
          J0SC = L0F(JSCAL)
        ENDIF
        IF(NM23.EQ.'SC' .OR. NM24.EQ.'TRS') THEN
C.... Compute scalar gradients
          IF(NX.NE.1) THEN
            CALL FNDFDX(J0SC,J0DSDX,IZ,INDVAR.EQ.ITEM1)
          ELSE
            CALL ZERNUM(J0DSDX,NXNY)
          ENDIF
          IF(NY.NE.1) THEN
            CALL FNDFDY(J0SC,J0DSDY,IZ,INDVAR.EQ.ITEM1)
          ELSE
            CALL ZERNUM(J0DSDY,NXNY)
          ENDIF
          IF(NZ.EQ.1 .OR. PARAB) THEN
            CALL ZERNUM(J0DSDZ,NXNY)
          ELSE
            CALL FNDFDZ(J0SC,J0DSDZ,IZ,INDVAR.EQ.ITEM1)
          ENDIF
          IF(NM11.EQ.'U') THEN
C.... Compute Prod,1 & Prod2
            J0USCR= L0F(INDVAR)
            DO 40 I= 1,NXNY
              F(J0PUS1+I)= -F(J0U2RS+I)*F(J0DSDX+I)
              F(J0PUS2+I)= -F(J0USCR+I)*F(J0DUDX+I)
  40        CONTINUE
            IF(NY.GT.1) THEN
              J0VSCR= L0F(LBNAME('V'//NM24))
              DO 41 I= 1,NXNY
                F(J0PUS1+I)= F(J0PUS1+I) - F(J0UVRS+I)*F(J0DSDY+I)
                F(J0PUS2+I)= F(J0PUS2+I) - F(J0VSCR+I)*F(J0DUDY+I)
  41          CONTINUE
            ENDIF
            IF(NZ.GT.1) THEN
              J0WSCR= L0F(LBNAME('W'//NM24))
              DO 42 I= 1,NXNY
                F(J0PUS1+I)= F(J0PUS1+I) - F(J0UWRS+I)*F(J0DSDZ+I)
                F(J0PUS2+I)= F(J0PUS2+I) - F(J0WSCR+I)*F(J0DUDZ+I)
  42          CONTINUE
            ENDIF
          ELSEIF(NM11.EQ.'V') THEN
C.... Compute Prod,1 & Prod,2
            J0VSCR= L0F(INDVAR)
            DO 50 I= 1,NXNY
              F(J0PVS1+I)= -F(J0V2RS+I)*F(J0DSDY+I)
              F(J0PVS2+I)= -F(J0VSCR+I)*F(J0DVDY+I)
  50        CONTINUE
            IF(NX.GT.1 .OR. J0UVRS.NE.0) THEN
              J0USCR= L0F(LBNAME('U'//NM24))
              DO 51 I= 1,NXNY
                F(J0PVS1+I)= F(J0PVS1+I) - F(J0UVRS+I)*F(J0DSDX+I)
                F(J0PVS2+I)= F(J0PVS2+I) - F(J0USCR+I)*F(J0DVDX+I)
  51          CONTINUE
            ENDIF
            IF(NZ.GT.1) THEN
              J0WSCR= L0F(LBNAME('W'//NM24))
              DO 52 I= 1,NXNY
                F(J0PVS1+I)= F(J0PVS1+I) - F(J0VWRS+I)*F(J0DSDZ+I)
                F(J0PVS2+I)= F(J0PVS2+I) - F(J0WSCR+I)*F(J0DVDZ+I)
  52          CONTINUE
            ENDIF
          ELSEIF(NM11.EQ.'W') THEN
C... Compute Prod,1 & Prod,2
            J0WSCR= L0F(INDVAR)
            DO 60 I= 1,NXNY
              F(J0PWS1+I)= -F(J0W2RS+I)*F(J0DSDZ+I)
              F(J0PWS2+I)= -F(J0WSCR+I)*F(J0DWDZ+I)
  60        CONTINUE
            IF(NX.GT.1) THEN
              J0USCR= L0F(LBNAME('U'//NM24))
              DO 61 I= 1,NXNY
                F(J0PWS1+I)= F(J0PWS1+I) - F(J0UWRS+I)*F(J0DSDX+I)
                F(J0PWS2+I)= F(J0PWS2+I) - F(J0USCR+I)*F(J0DWDX+I)
  61          CONTINUE
            ENDIF
            IF(NY.GT.1) THEN
              J0VSCR= L0F(LBNAME('V'//NM24))
                F(J0PWS1+I)= F(J0PWS1+I) - F(J0VWRS+I)*F(J0DSDY+I)
                F(J0PWS2+I)= F(J0PWS2+I) - F(J0VSCR+I)*F(J0DWDY+I)
  62          CONTINUE
            ENDIF
          ENDIF
        ENDIF
      ENDIF
      NAMSUB= 'ust199'
      END
C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C.... UPRODK is called from UST194
C
      SUBROUTINE UPRODK
      include '/phoenics/d_includ/farray'
      INCLUDE '/phoenics/d_includ/satear'
      INCLUDE '/phoenics/d_includ/grdear'
      INCLUDE '/phoenics/d_includ/satgrd'
      INCLUDE '/phoenics/d_includ/grdloc'
      INCLUDE '/phoenics/d_includ/rsmcmn'
      COMMON/NAMFN/NAMFUN,NAMSUB
      CHARACTER*6 NAMFUN,NAMSUB
      NAMSUB='UPRODK'
      J0VT=L0F(VIST)
      DO 1 I=1,NXNY
        F(J0PK+I)=F(J0VT+I)*
     1    (  2.*(F(J0DUDX+I)**2+F(J0DVDY+I)**2+F(J0DWDZ+I)**2)
     1                +(F(J0DUDY+I)+F(J0DVDX+I))**2
     1                +(F(J0DUDZ+I)+F(J0DWDX+I))**2
     1                +(F(J0DWDY+I)+F(J0DVDZ+I))**2            )
    1 CONTINUE
      NAMSUB = 'uprodk'
      END
C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C.... UPRDCT is called by UST194
C
      SUBROUTINE UPRDCT
      include '/phoenics/d_includ/farray'
      INCLUDE '/phoenics/d_includ/satear'
      INCLUDE '/phoenics/d_includ/grdear'
      INCLUDE '/phoenics/d_includ/satgrd'
      INCLUDE '/phoenics/d_includ/grdloc'
      INCLUDE '/phoenics/d_includ/rsmcmn'
      COMMON /LRSTM/LSTU1,LSTV1,LSTW1,LSTKE,LSTREP,LSTRHO
     1       /NAMFN/NAMFUN,NAMSUB
      LOGICAL LSTU1,LSTV1,LSTW1,LSTKE,LSTREP,LSTRHO
      CHARACTER*6 NAMFUN,NAMSUB
C
      NAMSUB= 'UPRDCT'
      DO 10 I= 1,NXNY
        F(J0PU2+I)= -2.*F(J0U2RS+I)*F(J0DUDX+I)
        F(J0PV2+I)= -2.*F(J0V2RS+I)*F(J0DVDY+I)
        F(J0PW2+I)= -2.*F(J0W2RS+I)*F(J0DWDZ+I)
  10  CONTINUE
      IF(IRSMHM.EQ.3) THEN
        ONETRD= 1./3.
        DO 11 I= 1,NXNY
          F(J0BU2+I)= 0.5*F(J0U2RS+I)/F(J0KE+I)-ONETRD
          F(J0BV2+I)= 0.5*F(J0V2RS+I)/F(J0KE+I)-ONETRD
          F(J0BW2+I)= 0.5*F(J0W2RS+I)/F(J0KE+I)-ONETRD
C.... Buv= 0.5*uvrs/k
          F(J0BUV+I)= 0.0
C.... Buw= 0.5*uwrs/k
          F(J0BUW+I)= 0.0
C.... Bvw= 0.5*vwrs/k
          F(J0BVW+I)= 0.0
          F(J0SU2+I)= F(J0DUDX+I)
          F(J0SV2+I)= F(J0DVDY+I)
          F(J0SW2+I)= F(J0DWDZ+I)
C.... Suv= 0.5*(du/dy+dv/dx)
          F(J0SUV+I)= 0.0
C.... Svw= 0.5*(dv/dz+dw/dy)
          F(J0SVW+I)= 0.0
C.... Suw= 0.5*(du/dz+dw/dx)
          F(J0SUW+I)= 0.0
          F(J0OU2+I)= 0.0
          F(J0OV2+I)= 0.0
          F(J0OW2+I)= 0.0
C.... Ouv= 0.5*(du/dy-dv/dx)
          F(J0OUV+I)= 0.0
C.... Ovw= 0.5*(dv/dz-dw/dy)
          F(J0OVW+I)= 0.0
C.... Ouw= 0.5*(du/dz-dw/dx)
          F(J0OUW+I)= 0.0
  11    CONTINUE
      ENDIF
      IF(J0UVRS.NE.0) THEN
        DO 20 I= 1,NXNY
          F(J0PU2+I)= F(J0PU2+I) - 2.*F(J0UVRS+I)*F(J0DUDY+I)
          F(J0PV2+I)= F(J0PV2+I) - 2.*F(J0UVRS+I)*F(J0DVDX+I)
          F(J0PUV+I)=-F(J0U2RS+I)*F(J0DVDX+I) - F(J0V2RS+I)*F(J0DUDY+I)
     1               +F(J0UVRS+I)*F(J0DWDZ+I)
  20    CONTINUE
        IF(IRSMHM.EQ.3) THEN
          DO 21 I= 1,NXNY
            F(J0BUV+I)= 0.5*F(J0UVRS+I)/F(J0KE+I)
            F(J0SUV+I)= 0.5*(F(J0DUDY+I) + F(J0DVDX+I))
            F(J0OUV+I)= 0.5*(F(J0DUDY+I) - F(J0DVDX+I))
  21      CONTINUE
        ENDIF
        IF(LSTW1) THEN
          DO 30 I= 1,NXNY
            F(J0PUV+I)= F(J0PUV+I) - F(J0UWRS+I)*F(J0DVDZ+I)
     1                             - F(J0VWRS+I)*F(J0DUDZ+I)
  30      CONTINUE
        ENDIF
      ENDIF
      IF(J0UWRS.NE.0) THEN
        DO 40 I= 1,NXNY
          F(J0PU2+I)= F(J0PU2+I) - 2.*F(J0UWRS+I)*F(J0DUDZ+I)
          F(J0PW2+I)= F(J0PW2+I) - 2.*F(J0UWRS+I)*F(J0DWDX+I)
          F(J0PUW+I)=-F(J0U2RS+I)*F(J0DWDX+I) - F(J0W2RS+I)*F(J0DUDZ+I)
     1               +F(J0UWRS+I)*F(J0DVDY+I)
  40    CONTINUE
        IF(IRSMHM.EQ.3) THEN
          DO 41 I= 1,NXNY
            F(J0BUW+I)= 0.5*F(J0UWRS+I)/F(J0KE+I)
            F(J0SUW+I)= 0.5*(F(J0DUDZ+I) + F(J0DWDX+I))
            F(J0OUW+I)= 0.5*(F(J0DUDZ+I) - F(J0DWDX+I))
  41      CONTINUE
        ENDIF
        IF(LSTV1) THEN
          DO 50 I= 1,NXNY
            F(J0PUW+I)= F(J0PUW+I) - F(J0UVRS+I)*F(J0DWDY+I)
     1                             - F(J0VWRS+I)*F(J0DUDY+I)
  50      CONTINUE
        ENDIF
      ENDIF
      IF(J0VWRS.NE.0) THEN
        DO 60 I= 1,NXNY
          F(J0PV2+I)= F(J0PV2+I) - 2.*F(J0VWRS+I)*F(J0DVDZ+I)
          F(J0PW2+I)= F(J0PW2+I) - 2.*F(J0VWRS+I)*F(J0DWDY+I)
          F(J0PVW+I)=-F(J0V2RS+I)*F(J0DWDY+I) - F(J0W2RS+I)*F(J0DVDZ+I)
     1               +F(J0VWRS+I)*F(J0DUDX+I)
  60    CONTINUE
        IF(IRSMHM.EQ.3) THEN
          DO 61 I= 1,NXNY
            F(J0BVW+I)= 0.5*F(J0VWRS+I)/F(J0KE+I)
            F(J0SVW+I)= 0.5*(F(J0DVDZ+I) + F(J0DWDY+I))
            F(J0OVW+I)= 0.5*(F(J0DVDZ+I) - F(J0DWDY+I))
  61      CONTINUE
        ENDIF
        IF(LSTU1) THEN
          DO 70 I= 1,NXNY
            F(J0PVW+I)= F(J0PVW+I) - F(J0UVRS+I)*F(J0DWDX+I)
     1                             - F(J0UWRS+I)*F(J0DVDX+I)
  70      CONTINUE
        ENDIF
      ENDIF
      DO 80 I= 1,NXNY
        GGPK= 0.5*(F(J0PU2+I) + F(J0PV2+I) + F(J0PW2+I))
        F(J0PK+I)= AMAX1(GGPK,0.0)
  80  CONTINUE
      NAMSUB= 'uprdct'
      END
C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C.... UPROD2 is called from UST194
C
      SUBROUTINE UPROD2
      include '/phoenics/d_includ/farray'
      INCLUDE '/phoenics/d_includ/satear'
      INCLUDE '/phoenics/d_includ/grdear'
      INCLUDE '/phoenics/d_includ/satgrd'
      INCLUDE '/phoenics/d_includ/grdloc'
      INCLUDE '/phoenics/d_includ/rsmcmn'
      COMMON /LRSTM/LSTU1,LSTV1,LSTW1,LSTKE,LSTREP,LSTRHO
     1       /NAMFN/NAMFUN,NAMSUB
      LOGICAL LSTU1,LSTV1,LSTW1,LSTKE,LSTREP,LSTRHO
      CHARACTER*6 NAMFUN,NAMSUB
C
      NAMSUB= 'UPROD2'
      DO 10 I= 1,NXNY
        F(J0DU2+I)= -2.*F(J0U2RS+I)*F(J0DUDX+I)
        F(J0DV2+I)= -2.*F(J0V2RS+I)*F(J0DVDY+I)
        F(J0DW2+I)= -2.*F(J0W2RS+I)*F(J0DWDZ+I)
  10  CONTINUE
      IF(J0UVRS.NE.0) THEN
        DO 20 I= 1,NXNY
          F(J0DU2+I)= F(J0DU2+I) - 2.*F(J0UVRS+I)*F(J0DVDX+I)
          F(J0DV2+I)= F(J0DV2+I) - 2.*F(J0UVRS+I)*F(J0DUDY+I)
          F(J0DUV+I)=-F(J0U2RS+I)*F(J0DUDY+I) - F(J0V2RS+I)*F(J0DVDX+I)
     1               +F(J0UVRS+I)*F(J0DWDZ+I)
  20    CONTINUE
        IF(LSTW1) THEN
          DO 30 I= 1,NXNY
            F(J0DUV+I)= F(J0DUV+I) - F(J0UWRS+I)*F(J0DWDY+I)
     1                             - F(J0VWRS+I)*F(J0DWDX+I)
  30      CONTINUE
        ENDIF
      ENDIF
      IF(J0UWRS.NE.0) THEN
        DO 40 I= 1,NXNY
          F(J0DU2+I)= F(J0DU2+I) - 2.*F(J0UWRS+I)*F(J0DWDX+I)
          F(J0DW2+I)= F(J0DW2+I) - 2.*F(J0UWRS+I)*F(J0DUDZ+I)
          F(J0DUW+I)=-F(J0U2RS+I)*F(J0DUDZ+I) - F(J0W2RS+I)*F(J0DWDX+I)
     1               +F(J0UWRS+I)*F(J0DVDY+I)
  40    CONTINUE
        IF(LSTV1) THEN
          DO 50 I= 1,NXNY
            F(J0DUW+I)= F(J0DUW+I) - F(J0UVRS+I)*F(J0DVDZ+I)
     1                             - F(J0VWRS+I)*F(J0DVDX+I)
  50      CONTINUE
        ENDIF
      ENDIF
      IF(J0VWRS.NE.0) THEN
        DO 60 I= 1,NXNY
          F(J0DV2+I)= F(J0DV2+I) - 2.*F(J0VWRS+I)*F(J0DWDY+I)
          F(J0DW2+I)= F(J0DW2+I) - 2.*F(J0VWRS+I)*F(J0DVDZ+I)
          F(J0DVW+I)=-F(J0V2RS+I)*F(J0DVDZ+I) - F(J0W2RS+I)*F(J0DWDY+I)
     1               +F(J0VWRS+I)*F(J0DUDX+I)
  60    CONTINUE
        IF(LSTU1) THEN

          DO 70 I= 1,NXNY
            F(J0DVW+I)= F(J0DVW+I) - F(J0UVRS+I)*F(J0DUDZ+I)
     1                             - F(J0UWRS+I)*F(J0DUDY+I)
  70      CONTINUE
        ENDIF
      ENDIF
      NAMSUB= 'uprod2'
      END
C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C.... UREDIS called from UST194.
C
      SUBROUTINE UREDIS
      include '/phoenics/d_includ/farray'
      INCLUDE '/phoenics/d_includ/satear'
      INCLUDE '/phoenics/d_includ/grdear'
      INCLUDE '/phoenics/d_includ/satgrd'
      INCLUDE '/phoenics/d_includ/grdloc'
      INCLUDE '/phoenics/d_includ/rsmcmn'
      COMMON/NAMFN/NAMFUN,NAMSUB
      LOGICAL EQZ
      CHARACTER*6 NAMFUN,NAMSUB
      DATA G2D3/0.66666667/
C
      NAMSUB= 'UREDIS'
C.... SSG pressure-strain MODEL
      IF(IRSMHM.EQ.3) THEN
        CALL SUB2R( ONETHD,1./3., TWOTHD,2./3. )

        DO 10 I= 1,NXNY
          GBU2 = F(J0BU2+I)
          GBV2 = F(J0BV2+I)
          GBW2 = F(J0BW2+I)
          GBUV = F(J0BUV+I)
          GBUW = F(J0BUW+I)
          GBVW = F(J0BVW+I)
          GC2TE= GC2*F(J0EP+I)
          GBU2S= GBU2*GBU2
          GBV2S= GBV2*GBV2
          GBW2S= GBW2*GBW2
          GBUVS= GBUV*GBUV
          GBUWS= GBUW*GBUW
          GBVWS= GBVW*GBVW
          GBMNS= GBU2S + GBV2S + GBW2S + 2.*( GBUVS + GBUWS + GBVWS )
          GBMN = SQRT(GBMNS)
          OTGBMN= ONETHD*GBMNS
C
          F(J0R2U2+I)= GC2TE*(GBU2S + GBUVS + GBUWS - OTGBMN)
          F(J0R2V2+I)= GC2TE*(GBUVS + GBV2S + GBVWS - OTGBMN)
          F(J0R2W2+I)= GC2TE*(GBUWS + GBVWS + GBW2S - OTGBMN)
          F(J0R2UV+I)= GC2TE*(GBU2*GBUV + GBUV*GBV2 + GBUW*GBVW)
          F(J0R2UW+I)= GC2TE*(GBU2*GBUW + GBUV*GBVW + GBUW*GBW2)
          F(J0R2VW+I)= GC2TE*(GBUV*GBUW + GBV2*GBVW + GBVW*GBW2)
C
          GSU2 = F(J0SU2+I)
          GSV2 = F(J0SV2+I)
          GSW2 = F(J0SW2+I)
          GSUV = F(J0SUV+I)
          GSUW = F(J0SUW+I)
          GSVW = F(J0SVW+I)
          GKET3= F(J0KE+I)*(GC3 - GC3ST*GBMN)
          F(J0R3U2+I)= GKET3*GSU2
          F(J0R3V2+I)= GKET3*GSV2
          F(J0R3W2+I)= GKET3*GSW2
          F(J0R3UV+I)= GKET3*GSUV
          F(J0R3UW+I)= GKET3*GSUW
          F(J0R3VW+I)= GKET3*GSVW
C
          GC4KE = GC4*F(J0KE+I)
          TTBMSM= TWOTHD*(GBU2*GSU2 + GBUV*GSUV + GBUW*GSUW +
     1                    GBUV*GSUV + GBV2*GSV2 + GBVW*GSVW +
     1                    GBUW*GSUW + GBVW*GSVW + GBW2*GSW2  )
          F(J0R4U2+I)= GC4KE*(GBU2*GSU2+GBUV*GSUV+GBUW*GSUW +
     1                        GBU2*GSU2+GBUV*GSUV+GBUW*GSUW - TTBMSM)
          F(J0R4V2+I)= GC4KE*(GBUV*GSUV+GBV2*GSV2+GBVW*GSVW +
     1                        GBUV*GSUV+GBV2*GSV2+GBVW*GSVW - TTBMSM)
          F(J0R4W2+I)= GC4KE*(GBUW*GSUW+GBVW*GSVW+GBW2*GSW2 +
     1                        GBUW*GSUW+GBVW*GSVW+GBW2*GSW2 - TTBMSM)
          F(J0R4UV+I)= GC4KE*(GBU2*GSUV+GBUV*GSV2+GBUW*GSVW +
     1                        GBUV*GSU2+GBV2*GSUV+GBVW*GSUW )
          F(J0R4UW+I)= GC4KE*(GBU2*GSUW+GBUV*GSVW+GBUW*GSW2 +
     1                        GBUW*GSU2+GBVW*GSUV+GBW2*GSUW )
          F(J0R4VW+I)= GC4KE*(GBUV*GSUW+GBV2*GSVW+GBVW*GSW2 +
     1                        GBUW*GSUV+GBVW*GSV2+GBW2*GSVW )
C
          GOU2 = F(J0OU2+I)
          GOV2 = F(J0OV2+I)
          GOW2 = F(J0OW2+I)
          GOUV = F(J0OUV+I)
          GOUW = F(J0OUW+I)
          GOVW = F(J0OVW+I)
          GOVU = - GOUV
          GOWU = - GOUW
          GOWV = - GOVW
          GC5KE= GC5*F(J0KE+I)
          F(J0R5U2+I)= GC5KE*(GBU2*GOU2 + GBUV*GOUV + GBUW*GOUW +
     1                        GBU2*GOU2 + GBUV*GOUV + GBUW*GOUW )
          F(J0R5V2+I)= GC5KE*(GBUV*GOVU + GBV2*GOV2 + GBVW*GOVW +
     1                        GBUV*GOVU + GBV2*GOV2 + GBVW*GOVW )
          F(J0R5W2+I)= GC5KE*(GBUW*GOWU + GBVW*GOWV + GBW2*GOW2 +
     1                        GBUW*GOWU + GBVW*GOWV + GBW2*GOW2 )
          F(J0R5UV+I)= GC5KE*(GBU2*GOVU + GBUV*GOV2 + GBUW*GOVW +
     1                        GBUV*GOU2 + GBV2*GOUV + GBVW*GOUW )
          F(J0R5UW+I)= GC5KE*(GBU2*GOWU + GBUV*GOWV + GBUW*GOW2 +
     1                        GBUW*GOU2 + GBVW*GOUV + GBW2*GOUW )
          F(J0R5VW+I)= GC5KE*(GBUV*GOWU + GBV2*GOWV + GBVW*GOW2 +
     1                        GBUW*GOVU + GBVW*GOV2 + GBW2*GOVW )
  10    CONTINUE
      ENDIF
      IF(EQZ(GBET)) THEN

        DO 20 I= 1,NXNY
          G2D3PK= G2D3*F(J0PK+I)
          GPU2  = F(J0PU2+I)
          GPV2  = F(J0PV2+I)
          GPW2  = F(J0PW2+I)
          GPUV  = F(J0PUV+I)
          GPUW  = F(J0PUW+I)
          GPVW  = F(J0PVW+I)
          F(J0R2U2+I)= -GALF*(GPU2 - G2D3PK)
          F(J0R2V2+I)= -GALF*(GPV2 - G2D3PK)
          F(J0R2W2+I)= -GALF*(GPW2 - G2D3PK)
          F(J0R2UV+I)= -GALF*GPUV
          F(J0R2UW+I)= -GALF*GPUW
          F(J0R2VW+I)= -GALF*GPVW
  20    CONTINUE
      ELSE

        DO 30 I= 1,NXNY
          GKE   = F(J0KE+I)
          G2D3PK= G2D3*F(J0PK+I)
          GPU2= F(J0PU2+I)
          GPV2= F(J0PV2+I)
          GPW2= F(J0PW2+I)
          GPUV= F(J0PUV+I)
          GPUW= F(J0PUW+I)
          GPVW= F(J0PVW+I)
          GDU2= F(J0DU2+I)
          GDV2= F(J0DV2+I)
          GDW2= F(J0DW2+I)
          GDUV= F(J0DUV+I)
          GDUW= F(J0DUW+I)
          GDVW= F(J0DVW+I)
          F(J0R2U2+I)= -GALF*(GPU2-G2D3PK)
     1                 -GBET*(GDU2-G2D3PK) - GGAM*GKE*2.*F(J0DUDX+I)
          F(J0R2V2+I)= -GALF*(GPV2-G2D3PK)
     1                 -GBET*(GDV2-G2D3PK) - GGAM*GKE*2.*F(J0DVDY+I)
          F(J0R2W2+I)= -GALF*(GPW2-G2D3PK)
     1                 -GBET*(GDW2-G2D3PK) - GGAM*GKE*2.*F(J0DWDZ+I)
          F(J0R2UV+I)= -GALF*GPUV
     1                 -GBET*GDUV - GGAM*GKE*(F(J0DUDY+I)+F(J0DVDX+I))
          F(J0R2UW+I)= -GALF*GPUW
     1                 -GBET*GDUW - GGAM*GKE*(F(J0DUDZ+I)+F(J0DWDX+I))
          F(J0R2VW+I)= -GALF*GPVW
     1                 -GBET*GDVW - GGAM*GKE*(F(J0DVDZ+I)+F(J0DWDY+I))
  30    CONTINUE
      ENDIF
      NAMSUB = 'uredis'
      END
C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C
C
      INTEGER FUNCTION J0SCRS(INDVAR,J0TRS,CH1)
      COMMON /GENI/IGFIL1(49),ITEM1,IGFIL2(10) /HDA1/NAME(150)
      CHARACTER*4 NAME,CH1*1
      IF(INDVAR.EQ.14 .OR. INDVAR.EQ.ITEM1) THEN
        J0SCRS= J0TRS
      ELSEIF(NAME(INDVAR)(1:2).EQ.'SC') THEN
        LBSCRS= LBNAME(CH1//NAME(INDVAR)(1:3))
        J0SCRS= L0F(LBSCRS)
      ENDIF
      END
C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C
C
      FUNCTION RELSCR(INDVAR,JTRS,CH1)
      COMMON /GENI/IGFIL1(49),ITEM1,IGFIL2(10)
     1       /RDA1/DTFALS(150) /HDA1/NAME(150)
      CHARACTER*4 NAME,CH1*1
      IF(INDVAR.EQ.14 .OR. INDVAR.EQ.ITEM1) THEN
        RELSCR= ABS(DTFALS(JTRS))
      ELSEIF(NAME(INDVAR)(1:2).EQ.'SC') THEN
        LBSCRS= LBNAME(CH1//NAME(INDVAR)(1:3))
        RELSCR= ABS(DTFALS(LBSCRS))
      ENDIF
      END
C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C
      LOGICAL FUNCTION GTURB(MPH)
      include '/phoenics/d_includ/farray'
      COMMON/RSTTNC/L0TURB,L0NORM,L0CROS
      GTURB= NINT(F(L0TURB+ ISL(MPH))).EQ.1
      END
C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C
      LOGICAL FUNCTION GNORM(MPH)
      include '/phoenics/d_includ/farray'
      COMMON/RSTTNC/L0TURB,L0NORM,L0CROS
      GNORM= NINT(F(L0NORM+ ISL(MPH))).EQ.1
      END
C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C
      LOGICAL FUNCTION GCROS(MPH)
      include '/phoenics/d_includ/farray'
      COMMON/RSTTNC/L0TURB,L0NORM,L0CROS
      GCROS= NINT(F(L0CROS+ ISL(MPH))).EQ.1
      END
c