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 '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 'farray'
INCLUDE 'satear'
INCLUDE 'grdear'
INCLUDE 'satgrd'
INCLUDE 'grdloc'
INCLUDE 'grdbfc'
INCLUDE 'rsmcmn'
COMMON/GENI/ IGNF1(42),NFTOT,IGNF2(17)
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 'farray'
INCLUDE 'satear'
INCLUDE 'satgrd'
INCLUDE 'grdloc'
INCLUDE '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 'farray'
INCLUDE 'satear'
INCLUDE 'grdear'
INCLUDE 'satgrd'
INCLUDE 'grdloc'
INCLUDE 'grdbfc'
INCLUDE 'rsmcmn'
COMMON/LGRND/ LG(20)/IGRND/IG(20)/RGRND/RG(100)/CGRND/CG(10)
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 'farray'
INCLUDE 'satear'
INCLUDE 'grdear'
INCLUDE 'satgrd'
INCLUDE 'grdloc'
INCLUDE 'grdbfc'
INCLUDE '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 'farray'
INCLUDE 'satear'
INCLUDE 'grdear'
INCLUDE 'satgrd'
INCLUDE 'grdloc'
INCLUDE 'grdbfc'
INCLUDE '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 'farray'
INCLUDE 'satear'
INCLUDE 'grdear'
INCLUDE 'satgrd'
INCLUDE 'grdloc'
INCLUDE '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 'farray'
INCLUDE 'satear'
INCLUDE 'grdear'
INCLUDE 'satgrd'
INCLUDE 'grdloc'
INCLUDE '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 'farray'
INCLUDE 'satear'
INCLUDE 'grdear'
INCLUDE 'satgrd'
INCLUDE 'grdloc'
INCLUDE '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 'farray'
INCLUDE 'satear'
INCLUDE 'grdear'
INCLUDE 'satgrd'
INCLUDE 'grdloc'
INCLUDE '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 'farray'
COMMON/RSTTNC/L0TURB,L0NORM,L0CROS
GTURB= NINT(F(L0TURB+ ISL(MPH))).EQ.1
END
C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C
LOGICAL FUNCTION GNORM(MPH)
include 'farray'
COMMON/RSTTNC/L0TURB,L0NORM,L0CROS
GNORM= NINT(F(L0NORM+ ISL(MPH))).EQ.1
END
C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C
LOGICAL FUNCTION GCROS(MPH)
include 'farray'
COMMON/RSTTNC/L0TURB,L0NORM,L0CROS
GCROS= NINT(F(L0CROS+ ISL(MPH))).EQ.1
END
c