*IF DEF,A05_3B,OR,DEF,A05_3C AJX1F405.180
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.14742
C GTS2F400.14743
C Use, duplication or disclosure of this code is subject to the GTS2F400.14744
C restrictions as set forth in the contract. GTS2F400.14745
C GTS2F400.14746
C Meteorological Office GTS2F400.14747
C London Road GTS2F400.14748
C BRACKNELL GTS2F400.14749
C Berkshire UK GTS2F400.14750
C RG12 2SZ GTS2F400.14751
C GTS2F400.14752
C If no contract has been raised with this copy of the code, the use, GTS2F400.14753
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.14754
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.14755
C Modelling at the above address. GTS2F400.14756
C ******************************COPYRIGHT****************************** GTS2F400.14757
C GTS2F400.14758
CLL SUBROUTINE EVP---------------------------------------------------- EVP3A.3
CLL EVP3A.4
CLL PURPOSE : CALCULATES THE EVAPORATION OF PRECIPITATION EVP3A.5
CLL EVP3A.6
CLL SUITABLE FOR SINGLE COLUMN MODEL USE EVP3A.7
CLL EVP3A.8
CLL MODEL MODIFICATION HISTORY FROM MODEL VERSION 3.0: EVP3A.9
CLL VERSION DATE EVP3A.10
CLL 4.0 5/05/95 New deck at version 4.0 to include pressure EVP3A.11
CLL dependency into calculation of evaporation of EVP3A.12
CLL convective precipitation. EVP3A.13
CLL Pete Inness. EVP3A.14
CLL 4.2 Oct. 96 T3E migration: *DEF CRAY removed, HF functions GSS4F402.10
CLL replaced. GSS4F402.11
CLL S.J.Swarbrick GSS4F402.12
CLL 4.3 Feb. 97 T3E optimisation of powers & sqrt GSS1F403.365
CLL D.Salmond & S.J.Swarbrick GSS1F403.366
CLL EVP3A.15
CLL PROGRAMMING STANDARDS : UNIFIED MODEL DOCUMENTATION PAPER NO. 3 EVP3A.16
CLL VERSION NO. 4 DATED 23/7/92 EVP3A.17
CLL EVP3A.18
CLL LOGICAL COMPONENTS COVERED: EVP3A.19
CLL EVP3A.20
CLL SYSTEM TASK : P27 EVP3A.21
CLL EVP3A.22
CLL DOCUMENTATION : UNIFIED MODEL DOCUMENTATION PAPER P27 EVP3A.23
CLL EVP3A.24
CLLEND----------------------------------------------------------------- EVP3A.25
C EVP3A.26
C*L ARGUMENTS--------------------------------------------------------- EVP3A.27
C EVP3A.28
SUBROUTINE EVP(NPNTS,PRECIP,TEVP,CCA,RHO,DELQ,DELPKM1,EVAP, 8EVP3A.29
& BEVAP,IPHASE,AREA_FAC,PKM1) EVP3A.30
C EVP3A.31
IMPLICIT NONE EVP3A.32
C EVP3A.33
C----------------------------------------------------------------------- EVP3A.34
C MODEL CONSTANTS USED IN THIS SUBROUTINE EVP3A.35
C----------------------------------------------------------------------- EVP3A.36
C EVP3A.37
*CALL C_G 
EVP3A.38
*CALL DDEVAP EVP3A.39
*CALL DDEVPLQ EVP3A.40
*CALL DDEVPICE EVP3A.41
C EVP3A.42
C----------------------------------------------------------------------- EVP3A.43
C VECTOR LENGTHS AND LOOP COUNTERS EVP3A.44
C----------------------------------------------------------------------- EVP3A.45
C EVP3A.46
INTEGER I ! LOOP COUNTER EVP3A.47
C EVP3A.48
INTEGER NPNTS ! IN VECTOR LENGTH EVP3A.49
C EVP3A.50
C----------------------------------------------------------------------- EVP3A.51
C VARIABLES WHICH ARE INPUT EVP3A.52
C----------------------------------------------------------------------- EVP3A.53
C EVP3A.54
C EVP3A.55
REAL DELQ(NPNTS) ! IN CHANGE IN HUMIDITY MIXING EVP3A.56
! RATIO ACROSS LAYER K (KG/KG) EVP3A.57
C EVP3A.58
REAL TEVP(NPNTS) ! IN TEMPERATURE OF LAYER K (K) EVP3A.59
C EVP3A.60
LOGICAL BEVAP(NPNTS) ! IN MASK FOR POINTS WHERE EVAPORATION EVP3A.61
! TAKES PLACE EVP3A.62
C EVP3A.63
REAL PRECIP(NPNTS) ! IN AMOUNT OF PRECIPITATION(KG/M**2/S) EVP3A.64
C EVP3A.65
REAL DELPKM1(NPNTS) ! IN CHANGE IN PRESSURE ACROSS EVP3A.66
! LAYER K-1 EVP3A.67
C EVP3A.68
REAL CCA(NPNTS) ! IN CONVECTIVE CLOUD AMOUNT EVP3A.69
C EVP3A.70
REAL RHO(NPNTS) ! IN DENSITY OF AIR EVP3A.71
C EVP3A.72
INTEGER IPHASE ! IN INDICATION FOR RAIN (1), OR EVP3A.73
! SNOW (2) EVP3A.74
C EVP3A.75
REAL PKM1(NPNTS) ! IN PRESSURE AT LEVEL KM1 EVP3A.76
C EVP3A.77
C----------------------------------------------------------------------- EVP3A.78
C VARIABLES WHICH ARE OUTPUT EVP3A.79
C----------------------------------------------------------------------- EVP3A.80
C EVP3A.81
REAL EVAP(NPNTS) ! OUT EVAPORATION EVP3A.82
C EVP3A.83
C----------------------------------------------------------------------- EVP3A.84
C EXTERNAL ROUTINES EVP3A.85
C----------------------------------------------------------------------- EVP3A.86
C EVP3A.87
C EVP3A.92
C----------------------------------------------------------------------- EVP3A.93
C VARIABLES WHICH ARE LOCALLY DEFINED EVP3A.94
C----------------------------------------------------------------------- EVP3A.95
C EVP3A.96
REAL ECON ! QUADRATIC TERM EVP3A.97
C EVP3A.98
REAL C1 ! CONSTANT EVP3A.99
C EVP3A.100
REAL C2 ! CONSTANT EVP3A.101
C EVP3A.102
REAL SR_RHO ! SQUARE ROOT OF DENSITY EVP3A.103
C EVP3A.104
REAL LRATE ! LOCAL RATE OF PRECIPITATION EVP3A.105
C EVP3A.106
REAL CA ! LOCAL CLOUD AREA EVP3A.107
C EVP3A.108
REAL AREA_FAC ! FRACTION OF CONVECTIVE CLOUD AMOUNT TO GIVE EVP3A.109
! LOCAL CLOUD AREA EVP3A.110
real work1(npnts),work2(npnts),work3(npnts), GSS1F403.367
1 r_work1(npnts),r_work2(npnts), GSS1F403.368
1 r_rho(npnts) GSS1F403.369
integer kk GSS1F403.370
real tl1,ti1 GSS1F403.371
C EVP3A.111
C----------------------------------------------------------------------- EVP3A.112
C START OF ROUTINE EVP3A.113
C----------------------------------------------------------------------- EVP3A.114
C EVP3A.115
tl1=0.5*P_LQ1 GSS1F403.372
ti1=0.5*P_ICE1 GSS1F403.373
C GSS1F403.374
kk=0 GSS1F403.375
do i=1,npnts GSS1F403.376
IF (BEVAP(I).AND.PRECIP(I) .GT. 0.0)THEN GSS1F403.377
kk=kk+1 GSS1F403.378
CA = AREA_FAC*CCA(I) GSS1F403.379
LRATE = PRECIP(I)/CA GSS1F403.380
work1(kk)=LRATE*LRATE*RHO(I) GSS1F403.381
work2(kk)=LRATE GSS1F403.382
work3(kk)=RHO(I) GSS1F403.383
ENDIF GSS1F403.384
enddo GSS1F403.385
C GSS1F403.386
IF (IPHASE.EQ.1) THEN ! RAIN EVP3A.116
C EVP3A.117
*IF DEF,VECTLIB PXVECTLB.6
call powr_v(kk,work1,tl1,r_work1) GSS1F403.388
call powr_v(kk,work2,P_LQ2,r_work2) GSS1F403.389
call powr_v(kk,work3,RHO_LQP2,r_rho) GSS1F403.390
*ELSE GSS1F403.391
do i=1,kk GSS1F403.392
r_work1(i)=work1(i)**tl1 GSS1F403.393
r_work2(i)=work2(i)**P_LQ2 GSS1F403.394
r_rho (i)=work3(i)**RHO_LQP2 GSS1F403.395
end do GSS1F403.396
*ENDIF GSS1F403.397
C GSS1F403.398
kk=0 GSS1F403.399
DO I=1,NPNTS EVP3A.118
IF (BEVAP(I)) THEN EVP3A.119
IF (PRECIP(I) .GT. 0.0) THEN EVP3A.120
kk=kk+1 GSS1F403.400
ECON = ((LQ_A*TEVP(I)+LQ_B)*TEVP(I)+LQ_C)* EVP3A.121
& (100000.0/PKM1(I)) EVP3A.122
CA = AREA_FAC*CCA(I) EVP3A.123
LRATE = PRECIP(I)/CA EVP3A.124
C1 = RHO_LQA*CA*r_work1(kk) GSS1F403.401
C2 = RHO_LQB*CA*r_work2(kk)*r_rho(kk) GSS1F403.402
EVAP(I) = MIN(ECON*(C1+C2)*DELQ(I)*DELPKM1(I)/G,LRATE) EVP3A.135
ELSE EVP3A.136
EVAP(I) = 0.0 EVP3A.137
END IF EVP3A.138
END IF EVP3A.139
END DO EVP3A.140
C EVP3A.141
ELSE IF (IPHASE.EQ.2) THEN ! SNOW EVP3A.142
C EVP3A.143
*IF DEF,VECTLIB PXVECTLB.7
call powr_v(kk,work1,ti1,r_work1) GSS1F403.404
call powr_v(kk,work2,P_ICE2,r_work2) GSS1F403.405
call powr_v(kk,work3,RHO_ICP2,r_rho) GSS1F403.406
*ELSE GSS1F403.407
do i=1,kk GSS1F403.408
r_work1(i)=work1(i)**ti1 GSS1F403.409
r_work2(i)=work2(i)**P_ICE2 GSS1F403.410
r_rho (i)=work3(i)**RHO_ICP2 GSS1F403.411
end do GSS1F403.412
*ENDIF GSS1F403.413
C GSS1F403.414
kk=0 GSS1F403.415
DO I=1,NPNTS EVP3A.144
IF (BEVAP(I)) THEN EVP3A.145
IF (PRECIP(I) .GT. 0.0) THEN EVP3A.146
kk=kk+1 GSS1F403.416
IF(TEVP(I).LE.243.58) THEN EVP3A.147
ECON = 1.7405E-5*(100000.0/PKM1(I)) EVP3A.148
ELSE EVP3A.149
ECON = ((ICE_A*TEVP(I)+ICE_B)*TEVP(I)+ICE_C)* EVP3A.150
& (100000.0/PKM1(I)) EVP3A.151
END IF EVP3A.152
CA = AREA_FAC*CCA(I) EVP3A.153
LRATE = PRECIP(I)/CA EVP3A.154
C1 = RHO_ICEA*CA*r_work1(kk) GSS1F403.417
C2 = RHO_ICEB*CA*r_work2(kk)*r_rho(kk) GSS1F403.418
EVAP(I) = MIN(ECON*(C1+C2)*DELQ(I)*DELPKM1(I)/G,LRATE) EVP3A.165
ELSE EVP3A.166
EVAP(I) = 0.0 EVP3A.167
END IF EVP3A.168
END IF EVP3A.169
END DO EVP3A.170
C EVP3A.171
ENDIF EVP3A.172
C EVP3A.173
RETURN EVP3A.174
END EVP3A.175
C EVP3A.176
*ENDIF EVP3A.177