SUBROUTINE EVP(NPNTS,PRECIP,TEVP,CCA,RHO,DELQ,DELPKM1,EVAP, 8EVP2A.24
& BEVAP,IPHASE,AREA_FAC) EVP2A.25
C EVP2A.26
IMPLICIT NONE EVP2A.27
C EVP2A.28
C----------------------------------------------------------------------- EVP2A.29
C MODEL CONSTANTS USED IN THIS SUBROUTINE EVP2A.30
C----------------------------------------------------------------------- EVP2A.31
C EVP2A.32
*CALL C_G 
EVP2A.33
*CALL DDEVAP EVP2A.34
*CALL DDEVPLQ EVP2A.35
*CALL DDEVPICE EVP2A.36
C EVP2A.37
C----------------------------------------------------------------------- EVP2A.38
C VECTOR LENGTHS AND LOOP COUNTERS EVP2A.39
C----------------------------------------------------------------------- EVP2A.40
C EVP2A.41
INTEGER I ! LOOP COUNTER EVP2A.42
C EVP2A.43
INTEGER NPNTS ! IN VECTOR LENGTH EVP2A.44
C EVP2A.45
C----------------------------------------------------------------------- EVP2A.46
C VARIABLES WHICH ARE INPUT EVP2A.47
C----------------------------------------------------------------------- EVP2A.48
C EVP2A.49
C EVP2A.50
REAL DELQ(NPNTS) ! IN CHANGE IN HUMIDITY MIXING EVP2A.51
! RATIO ACROSS LAYER K (KG/KG) EVP2A.52
C EVP2A.53
REAL TEVP(NPNTS) ! IN TEMPERATURE OF LAYER K (K) EVP2A.54
C EVP2A.55
LOGICAL BEVAP(NPNTS) ! IN MASK FOR POINTS WHERE EVAPORATION EVP2A.56
! TAKES PLACE EVP2A.57
C EVP2A.58
REAL PRECIP(NPNTS) ! IN AMOUNT OF PRECIPITATION(KG/M**2/S) EVP2A.59
C EVP2A.60
REAL DELPKM1(NPNTS) ! IN CHANGE IN PRESSURE ACROSS EVP2A.61
! LAYER K-1 EVP2A.62
C EVP2A.63
REAL CCA(NPNTS) ! IN CONVECTIVE CLOUD AMOUNT EVP2A.64
C EVP2A.65
REAL RHO(NPNTS) ! IN DENSITY OF AIR EVP2A.66
C EVP2A.67
INTEGER IPHASE ! IN INDICATION FOR RAIN (1), OR EVP2A.68
! SNOW (2) EVP2A.69
C EVP2A.70
C----------------------------------------------------------------------- EVP2A.71
C VARIABLES WHICH ARE OUTPUT EVP2A.72
C----------------------------------------------------------------------- EVP2A.73
C EVP2A.74
REAL EVAP(NPNTS) ! OUT EVAPORATION EVP2A.75
C EVP2A.76
C----------------------------------------------------------------------- EVP2A.77
C EXTERNAL ROUTINES EVP2A.78
C----------------------------------------------------------------------- EVP2A.79
C EVP2A.80
C EVP2A.85
C----------------------------------------------------------------------- EVP2A.86
C VARIABLES WHICH ARE LOCALLY DEFINED EVP2A.87
C----------------------------------------------------------------------- EVP2A.88
C EVP2A.89
REAL ECON ! QUADRATIC TERM EVP2A.90
C EVP2A.91
REAL C1 ! CONSTANT EVP2A.92
C EVP2A.93
REAL C2 ! CONSTANT EVP2A.94
C EVP2A.95
REAL SR_RHO ! SQUARE ROOT OF DENSITY EVP2A.96
C EVP2A.97
REAL LRATE ! LOCAL RATE OF PRECIPITATION EVP2A.98
C EVP2A.99
REAL CA ! LOCAL CLOUD AREA EVP2A.100
C EVP2A.101
REAL AREA_FAC ! FRACTION OF CONVECTIVE CLOUD AMOUNT TO GIVE EVP2A.102
! LOCAL CLOUD AREA EVP2A.103
real work1(npnts),work2(npnts),work3(npnts), GSS1F403.314
1 r_work1(npnts),r_work2(npnts), GSS1F403.315
1 r_rho(npnts) GSS1F403.316
integer kk GSS1F403.317
real tl1,ti1 GSS1F403.318
C EVP2A.104
C----------------------------------------------------------------------- EVP2A.105
C START OF ROUTINE EVP2A.106
C----------------------------------------------------------------------- EVP2A.107
C EVP2A.108
tl1=0.5*P_LQ1 GSS1F403.319
ti1=0.5*P_ICE1 GSS1F403.320
GSS1F403.321
kk=0 GSS1F403.322
do i=1,npnts GSS1F403.323
IF (BEVAP(I).AND.PRECIP(I) .GT. 0.0)THEN GSS1F403.324
kk=kk+1 GSS1F403.325
CA = AREA_FAC*CCA(I) GSS1F403.326
LRATE = PRECIP(I)/CA GSS1F403.327
work1(kk)=LRATE*LRATE*RHO(I) GSS1F403.328
work2(kk)=LRATE GSS1F403.329
work3(kk)=RHO(I) GSS1F403.330
ENDIF GSS1F403.331
enddo GSS1F403.332
GSS1F403.333
IF (IPHASE.EQ.1) THEN ! RAIN EVP2A.109
C EVP2A.110
*IF DEF,VECTLIB PXVECTLB.4
call powr_v(kk,work1,tl1,r_work1) GSS1F403.335
call powr_v(kk,work2,P_LQ2,r_work2) GSS1F403.336
call powr_v(kk,work3,RHO_LQP2,r_rho) GSS1F403.337
*ELSE GSS1F403.338
do i=1,kk GSS1F403.339
r_work1(i)=work1(i)**tl1 GSS1F403.340
r_work2(i)=work2(i)**P_LQ2 GSS1F403.341
r_rho (i)=work3(i)**RHO_LQP2 GSS1F403.342
end do GSS1F403.343
*ENDIF GSS1F403.344
kk=0 GSS1F403.345
DO I=1,NPNTS EVP2A.111
IF (BEVAP(I)) THEN EVP2A.112
IF (PRECIP(I) .GT. 0.0) THEN EVP2A.113
kk=kk+1 GSS1F403.346
ECON = ((LQ_A*TEVP(I)+LQ_B)*TEVP(I)+LQ_C) EVP2A.114
CA = AREA_FAC*CCA(I) EVP2A.115
LRATE = PRECIP(I)/CA EVP2A.116
C1 = RHO_LQA*CA*r_work1(kk) GSS1F403.347
C2 = RHO_LQB*CA*r_work2(kk)*r_rho(kk) GSS1F403.348
EVAP(I) = MIN(ECON*(C1+C2)*DELQ(I)*DELPKM1(I)/G,LRATE) EVP2A.127
ELSE EVP2A.128
EVAP(I) = 0.0 EVP2A.129
END IF EVP2A.130
END IF EVP2A.131
END DO EVP2A.132
C EVP2A.133
ELSE IF (IPHASE.EQ.2) THEN ! SNOW EVP2A.134
C EVP2A.135
*IF DEF,VECTLIB PXVECTLB.5
call powr_v(kk,work1,ti1,r_work1) GSS1F403.350
call powr_v(kk,work2,P_ICE2,r_work2) GSS1F403.351
call powr_v(kk,work3,RHO_ICP2,r_rho) GSS1F403.352
*ELSE GSS1F403.353
do i=1,kk GSS1F403.354
r_work1(i)=work1(i)**ti1 GSS1F403.355
r_work2(i)=work2(i)**P_ICE2 GSS1F403.356
r_rho (i)=work3(i)**RHO_ICP2 GSS1F403.357
end do GSS1F403.358
*ENDIF GSS1F403.359
C GSS1F403.360
kk=0 GSS1F403.361
DO I=1,NPNTS EVP2A.136
IF (BEVAP(I)) THEN EVP2A.137
IF (PRECIP(I) .GT. 0.0) THEN EVP2A.138
kk=kk+1 GSS1F403.362
ECON = ((ICE_A*TEVP(I)+ICE_B)*TEVP(I)+ICE_C) EVP2A.139
CA = AREA_FAC*CCA(I) EVP2A.140
LRATE = PRECIP(I)/CA EVP2A.141
C1 = RHO_ICEA*CA*r_work1(kk) GSS1F403.363
C2 = RHO_ICEB*CA*r_work2(kk)*r_rho(kk) GSS1F403.364
EVAP(I) = MIN(ECON*(C1+C2)*DELQ(I)*DELPKM1(I)/G,LRATE) EVP2A.152
ELSE EVP2A.153
EVAP(I) = 0.0 EVP2A.154
END IF EVP2A.155
END IF EVP2A.156
END DO EVP2A.157
C EVP2A.158
ENDIF EVP2A.159
C EVP2A.160
RETURN EVP2A.161
END EVP2A.162
C EVP2A.163
*ENDIF EVP2A.164