c
C.... FILE NAME GXEVAP.FTN--------------------------------121124
SUBROUTINE GXEVAP
include 'farray'
INCLUDE 'satear'
INCLUDE 'grdloc'
INCLUDE 'satgrd'
INCLUDE 'grdear'
INCLUDE 'grdbfc'
INCLUDE 'parear'
LOGICAL INPARDOM, SLD , BLKSLD, LSOLID
COMMON/GENI/NXNY,IGFIL1(8),NFM,IGF(21),IPRL,IBTAU,ILTLS,IGFIL(15),
1 ITEM1,ITEM2,ISPH1,ISPH2,ICON1,ICON2,IPRPS,IRADX,IRADY,IRADZ,IVFOL
COMMON/DRHODP/ITEMP,IDEN/DVMOD/IDVCGR
COMMON/HBASE/IH01,IH02,KH01,KH01H,KH01L,KH02,KH02H,KH02L,L0H012
COMMON /GEODMN0/ I3DAEX,I3DANY,I3DAHZ,I3DVOL,I3DDXG,I3DDYG,
1 I3DDZG,I3DDX,I3DDY,I3DDZ,I2DAWB,I2DASB,I2DALB
COMMON /VOFI1/ L0SURT0
LOGICAL LPAR
SAVE LPAR
SAVE L0WORK9,ISURN,ISURT,IMEVA,IFRN2
SAVE RHOL,RHOV,CPGAS,CPLIQ,CPDIF
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX USER SECTION STARTS:
C
C 1 Set dimensions of data-for-GROUND arrays here. WARNING: the
C corresponding arrays in the MAIN program of the satellite
C and EARTH must have the same dimensions.
PARAMETER (NLG=100, NIG=200, NRG=200, NCG=100)
C
COMMON/LGRND/LG(NLG)/IGRND/IG(NIG)/RGRND/RG(NRG)/CGRND/CG(NCG)
LOGICAL LG, DBSURFT
CHARACTER*4 CG
C
c***********************************************************************
c
IXL=IABS(IXL)
C*****************************************************************
C
C--- GROUP 1. Run title and other preliminaries
C
IF(IGR==1) THEN
C * -----------GROUP 1 SECTION 3 ---------------------------
C---- Use this group to create storage via GXMAKE0 which it is not
C necessary to dump to PHI (or PHIDA) for restarts
C
IF(ISC==3) THEN
IF(.NOT.NULLPR.AND.IDVCGR.EQ.0)
1 CALL WRYT40('GROUND file is GXEVAP.F of: 041124 ')
CALL GXMAKE0(L0WORK9,NXNY*NZ,'WOK9')
ISURN=LBNAME('SURN')
IMEVA=LBNAME('MEVA')
ISURT=LBNAME('SURT')
IFRN2 = LBNAME('FRN2')
RHOL=F(INDPRTB(IPRPSA,0)+1)
RHOV=F(INDPRTB(IPRPSB,0)+1)
CPLIQ= F(INDPRTB(IPRPSA,0)+3)
CPGAS= F(INDPRTB(IPRPSB,0)+3)
CPDIF=(CPLIQ-CPGAS)
LPAR=MIMD.AND.NPROC>1
ENDIF
ELSEIF(IGR==8) THEN
IF(ISC==7) THEN
C * ------------------- SECTION 7 ---- Volumetric source for gala
ACOEF=(1.0/RHOL-1.0/RHOV)
CALL FN53(LSU,IMEVA,VOL,ACOEF) ! VAL=val + ACOEF*IMEVP*VOL
ENDIF
ELSEIF(IGR==13) THEN
IF(ISC==16) THEN
C------------------- SECTION 16 ------------------- value = GRND4
IF(NPATCH=='EVAPO') THEN
IF(INDVAR==ISURN.OR.INDVAR==IFRN2) THEN
IF(NONCON)THEN
ACOEFS=1.0/(RHOL*RHOV)
CALL FN21(VAL,IMEVA,DEN1,0.0,ACOEFS) ! VAL=0.0+ACOEFS*MEVA*DEN1
ELSE
ACOEFS=1.0/RHOL
CALL FN2(VAL,IMEVA,0.0,ACOEFS) ! VAL=0.0+ACOEFS*MEVA
ENDIF
ELSEIF(INDVAR==ITEM1) THEN
CALL FN2(VAL,IMEVA,0.0,LATH) ! VAL=0.0+SLATH*MEVA
ACOEF=-CPDIF
CALL FN53(VAL,IMEVA,ITEM1,ACOEF) !val=val+Acoef*IMEVA*ITEM1
ENDIF
ENDIF
ENDIF
ELSEIF(IGR==19) THEN
IF(ISC==2) THEN
C * ------------------- SECTION 2 ---- Start of sweep.
!!! If IEVAP ==1 then Lee method elseif IEVAP==2 Lee based on rho*Cp and latent heat
!!**** Evaporation rate
!!! Fill the property MEVA
IF(IEVAP==1) THEN ! Lee method
DO IZZ=1,NZ
L0TEM1=L0F(ANYZ(ITEM1,IZZ))
L0SURN=L0F(ANYZ(ISURN,IZZ))
L0MEVA=L0F(ANYZ(IMEVA,IZZ))
DO I=1,NXNY
F(L0MEVA+I)=0.0
COEFSURN=F(L0SURN+I)
TEMPIN=F(L0TEM1+I) + TEMP0
COEFVAP=0.0
IF(TEMPIN>TSAT)THEN
COEFVAP=-EVAPCO*RHOL*COEFSURN
ELSEIF(TEMPIN0) THEN
L0SURT=L0F(ANYZ(ISURT,IZZ))
ELSE
L0SURT=L0SURT0+(IZZ-1)*NXNY
ENDIF
DO I=1,NXNY
TEMPIN=F(L0TEM1+I) + TEMP0
RCPMIX=RHOL*CPLIQ*F(L0SURT+I)+RHOV*CPGAS*
1 (1.0-F(L0SURT+I))
IF(TEMPIN>TSAT.AND.F(L0SURT+I)>0.0)THEN
COEFVAP=RCPMIX/DT/LATH
ELSEIF(TEMPIN0.0)THEN
RATIO=SUM1/SUM2
ELSE
RATIO=1.0
ENDIF
DO IZZ=1,NZ
L0MEVA=L0F(ANYZ(IMEVA,IZZ))
DO I=1,NXNY
F(L0MEVA+I)=F(L0MEVA+I)*RATIO
ENDDO
ENDDO
ELSEIF(ISC==7) THEN
C * ------------------- SECTION 7 ---- Finish of sweep.
ENDIF
ENDIF
END
C***************************************************************
SUBROUTINE NORMD(FDOUT,F1Y,F2Y,F3Y,F4Y,F5Y,F6Y,F7Y,F8Y,F9Y,
& DYGM,DYGP,A1,A2L,A2H,A3)
FD1M=(F2Y-F1Y)/DYGM
FD2M=(F5Y-F4Y)/DYGM
FD3M=(F8Y-F7Y)/DYGM
FD1P=(F3Y-F2Y)/DYGP
FD1P=(F6Y-F5Y)/DYGP
FD1P=(F9Y-F8Y)/DYGP
FC1L=A2L*FD1M+A1*FD2M
FC1H=A3*FD2M+A2H*FD3M
FC2L=A2L*FD1P+A1*FD2P
FC2H=A3*FD2P+A2H*FD3P
FDOUT=0.25*(FC1L+FC1H+FC2L+FC2H)
RETURN
END
C***************************************************************
SUBROUTINE NORMDP(F1Y,F2Y,F3Y,F4Y,F5Y,F6Y,F7Y,F8Y,F9Y,
& DYGM,DYGP,A1,A2L,A2H,A3,FC1L,FC1H,FC2L,FC2H)
FD1M=(F2Y-F1Y)/DYGM
FD2M=(F5Y-F4Y)/DYGM
FD3M=(F8Y-F7Y)/DYGM
FD1P=(F3Y-F2Y)/DYGP
FD1P=(F6Y-F5Y)/DYGP
FD1P=(F9Y-F8Y)/DYGP
FC1L=A2L*FD1M+A1*FD2M
FC1H=A3*FD2M+A2H*FD3M
FC2L=A2L*FD1P+A1*FD2P
FC2H=A3*FD2P+A2H*FD3P
RETURN
END
C***************************************************************
c