*IF DEF,A03_7A SFEVAP7A.2
C *****************************COPYRIGHT****************************** SFEVAP7A.3
C (c) CROWN COPYRIGHT 1997, METEOROLOGICAL OFFICE, All Rights Reserved. SFEVAP7A.4
C SFEVAP7A.5
C Use, duplication or disclosure of this code is subject to the SFEVAP7A.6
C restrictions as set forth in the contract. SFEVAP7A.7
C SFEVAP7A.8
C Meteorological Office SFEVAP7A.9
C London Road SFEVAP7A.10
C BRACKNELL SFEVAP7A.11
C Berkshire UK SFEVAP7A.12
C RG12 2SZ SFEVAP7A.13
C SFEVAP7A.14
C If no contract has been raised with this copy of the code, the use, SFEVAP7A.15
C duplication or disclosure of it is strictly prohibited. Permission SFEVAP7A.16
C to do so must first be obtained in writing from the Head of Numerical SFEVAP7A.17
C Modelling at the above address. SFEVAP7A.18
C ******************************COPYRIGHT****************************** SFEVAP7A.19
C*LL SUBROUTINE SF_EVAP------------------------------------------------ SFEVAP7A.20
CLL SFEVAP7A.21
CLL Purpose: Calculate surface evaporation and sublimation amounts SFEVAP7A.22
CLL (without applying them to the surface stores). SFEVAP7A.23
CLL SFEVAP7A.24
CLL SFEVAP7A.25
CLL Suitable for single column usage. SFEVAP7A.26
CLL SFEVAP7A.27
CLL Model Modification history: SFEVAP7A.28
CLL version Date SFEVAP7A.29
CLL SFEVAP7A.30
CLL 4.1 New deck. SFEVAP7A.31
CLL 4.2 Oct. 96 T3E migration - *DEF CRAY removed SFEVAP7A.32
CLL S J Swarbrick SFEVAP7A.33
CLL SFEVAP7A.34
CLL 4.4 Jul. 97 MOSES II Richard Essery SFEVAP7A.35
CLL SFEVAP7A.36
CLL Programming standard: Unified Model Documentation Paper No 4, SFEVAP7A.37
CLL version 2, dated 18/1/90. SFEVAP7A.38
CLL SFEVAP7A.39
CLL Logical component covered: P245. SFEVAP7A.40
CLL SFEVAP7A.41
CLL System task: SFEVAP7A.42
CLL SFEVAP7A.43
CLL Documentation: UMDP 24 SFEVAP7A.44
CLL SFEVAP7A.45
CLL--------------------------------------------------------------------- SFEVAP7A.46
C* SFEVAP7A.47
C*L Arguments :--------------------------------------------------------- SFEVAP7A.48
SUBROUTINE SF_EVAP ( 4,14SFEVAP7A.49
& P_POINTS,P_FIELD,P1,LAND1,LAND_PTS,LAND_FIELD,NTYPE, SFEVAP7A.50
& LAND_INDEX,TILE_INDEX,TILE_PTS,NSHYD,LTIMER, SFEVAP7A.51
& ASHTF,ASHTF_SNOW,CANOPY,DTRDZ_1,FRACA,LYING_SNOW,RESFS, SFEVAP7A.52
& RESFT,RHOKH_1,TILE_FRAC,SMC,WT_EXT,TIMESTEP, SFEVAP7A.53
& FQW_1,FQW_TILE,FTL_1,FTL_TILE,QW_1,TL_1,TSTAR_TILE, SFEVAP7A.54
& ECAN,ECAN_TILE,ESOIL,ESOIL_TILE,EXT SFEVAP7A.55
& ) SFEVAP7A.56
SFEVAP7A.57
IMPLICIT NONE SFEVAP7A.58
SFEVAP7A.59
INTEGER SFEVAP7A.60
& P_POINTS ! IN Number of P-grid points to be SFEVAP7A.61
! ! processed. SFEVAP7A.62
&,P_FIELD ! IN Total number of P-grid points. SFEVAP7A.63
&,P1 ! IN First P-point to be processed. SFEVAP7A.64
&,LAND1 ! IN First land point to be processed. SFEVAP7A.65
&,LAND_PTS ! IN Number of land points to be processed. SFEVAP7A.66
&,LAND_FIELD ! IN Total number of land points. SFEVAP7A.67
&,NTYPE ! IN Number of tiles per land point. SFEVAP7A.68
&,LAND_INDEX(P_FIELD) ! IN Index of land points. SFEVAP7A.69
&,TILE_INDEX(LAND_FIELD,NTYPE) SFEVAP7A.70
! ! IN Index of tile points. SFEVAP7A.71
&,TILE_PTS(NTYPE) ! IN Number of tile points. SFEVAP7A.72
&,NSHYD ! IN Number of soil moisture levels. SFEVAP7A.73
SFEVAP7A.74
LOGICAL SFEVAP7A.75
& LTIMER ! IN Logical for TIMER. SFEVAP7A.76
SFEVAP7A.77
REAL SFEVAP7A.78
& ASHTF(P_FIELD) ! IN Coefficient to calculate surface SFEVAP7A.79
! ! heat flux into soil or sea-ice. SFEVAP7A.80
&,ASHTF_SNOW(P_FIELD) ! IN ASHTF for snow SFEVAP7A.81
&,CANOPY(LAND_FIELD,NTYPE-1) SFEVAP7A.82
! ! IN Surface/canopy water on snow-free SFEVAP7A.83
! ! land tiles (kg/m2). SFEVAP7A.84
&,DTRDZ_1(P_FIELD) ! IN -g.dt/dp for surface layer SFEVAP7A.85
&,FRACA(LAND_FIELD,NTYPE-1) SFEVAP7A.86
! ! IN Fraction of surface moisture flux SFEVAP7A.87
! ! with only aerodynamic resistance SFEVAP7A.88
! ! for snow-free land tiles. SFEVAP7A.89
&,LYING_SNOW(P_FIELD) ! IN Lying snow amount (kg per sq metre). SFEVAP7A.90
&,RESFS(LAND_FIELD,NTYPE-1) SFEVAP7A.91
! ! IN Combined soil, stomatal and aerodynam. SFEVAP7A.92
! ! resistance factor for fraction 1-FRACA SFEVAP7A.93
! ! of snow-free land tiles. SFEVAP7A.94
&,RESFT(LAND_FIELD,NTYPE) SFEVAP7A.95
! ! IN Total resistance factor SFEVAP7A.96
! ! FRACA+(1-FRACA)*RESFS. SFEVAP7A.97
&,RHOKH_1(LAND_FIELD,NTYPE) SFEVAP7A.98
! ! IN Surface exchange coefficients. SFEVAP7A.99
&,TILE_FRAC(LAND_FIELD,NTYPE) SFEVAP7A.100
! ! IN Tile fractions. SFEVAP7A.101
&,SMC(LAND_FIELD) ! IN Available soil moisture (kg/m2). SFEVAP7A.102
&,WT_EXT(LAND_FIELD,NSHYD) SFEVAP7A.103
! ! IN Fraction of transpiration SFEVAP7A.104
! ! extracted from each soil layer. SFEVAP7A.105
&,TIMESTEP ! IN Timestep in seconds. SFEVAP7A.106
SFEVAP7A.107
REAL SFEVAP7A.108
& FQW_1(P_FIELD) ! INOUT Surface moisture flux (kg/m2/s). SFEVAP7A.109
&,FQW_TILE(LAND_FIELD,NTYPE) SFEVAP7A.110
! ! INOUT Local FQW_1 for tiles. SFEVAP7A.111
&,FTL_1(P_FIELD) ! INOUT Surface sensible heat flux (W/m2). SFEVAP7A.112
&,FTL_TILE(LAND_FIELD,NTYPE) SFEVAP7A.113
! ! INOUT Local FTL_1 for tiles. SFEVAP7A.114
&,QW_1(P_FIELD) ! INOUT Total water content of lowest SFEVAP7A.115
! ! atmospheric layer (kg per kg air). SFEVAP7A.116
&,TL_1(P_FIELD) ! INOUT Liquid/frozen water temperature for SFEVAP7A.117
! ! lowest atmospheric layer (K). SFEVAP7A.118
&,TSTAR_TILE(LAND_FIELD,NTYPE) SFEVAP7A.119
! ! INOUT Tile surface temperatures (K). SFEVAP7A.120
SFEVAP7A.121
REAL SFEVAP7A.122
& ECAN(P_FIELD) ! OUT Gridbox mean evaporation from canopy/ SFEVAP7A.123
! ! surface store (kg per sq m per s). SFEVAP7A.124
! ! Zero over sea and sea-ice. SFEVAP7A.125
&,ECAN_TILE(LAND_FIELD,NTYPE-1) SFEVAP7A.126
! ! OUT ECAN for snow-free land tiles. SFEVAP7A.127
&,ESOIL(P_FIELD) ! OUT Gridbox mean evapotranspiration from SFEVAP7A.128
! ! soil moisture (kg per sq m per s). SFEVAP7A.129
! ! Zero over sea and sea-ice. SFEVAP7A.130
&,ESOIL_TILE(LAND_FIELD,NTYPE-1) SFEVAP7A.131
! ! OUT ESOIL for snow-free land tiles. SFEVAP7A.132
&,EXT(LAND_FIELD,NSHYD) ! OUT Extraction of water from each SFEVAP7A.133
! ! soil layer (kg/m2/s). SFEVAP7A.134
SFEVAP7A.135
! Local and other symbolic constants :- SFEVAP7A.136
*CALL C_LHEAT 
SFEVAP7A.137
*CALL C_R_CP SFEVAP7A.138
SFEVAP7A.139
REAL SFEVAP7A.140
& DFQW(LAND_FIELD) ! Increment in GBM moisture flux. SFEVAP7A.141
&,DFTL(LAND_FIELD) ! Increment in GBM sensible heat flux. SFEVAP7A.142
&,FQW_TILE_OLD(LAND_FIELD,NTYPE) SFEVAP7A.143
! ! FQW_TILE before adjustment. SFEVAP7A.144
&,SNOW_FRAC(LAND_FIELD) ! Fractional snow coverage. SFEVAP7A.145
SFEVAP7A.146
REAL SFEVAP7A.147
& DIFF_LAT_HTF ! Increment in local latent heat flux. SFEVAP7A.148
&,DIFF_SENS_HTF ! Increment in local sensible heat flux. SFEVAP7A.149
&,DTSTAR ! Increment in local surface temperature. SFEVAP7A.150
&,EDT ! Moisture flux x timestep SFEVAP7A.151
&,FQW_ADJ ! Adjustment of moisture fluxes. SFEVAP7A.152
SFEVAP7A.153
INTEGER SFEVAP7A.154
& I ! Loop counter (horizontal field index). SFEVAP7A.155
&,J ! Loop counter (land, snow or land-ice field index). SFEVAP7A.156
&,K ! Loop counter (soil level index). SFEVAP7A.157
&,L ! Loop counter (land point field index). SFEVAP7A.158
&,N ! Loop counter (tile index). SFEVAP7A.159
SFEVAP7A.160
IF (LTIMER) THEN SFEVAP7A.161
CALL TIMER('SFEVAP ',3) SFEVAP7A.162
ENDIF SFEVAP7A.163
SFEVAP7A.164
DO N=1,NTYPE SFEVAP7A.165
DO J=1,TILE_PTS(N) SFEVAP7A.166
L = TILE_INDEX(J,N) SFEVAP7A.167
FQW_TILE_OLD(L,N) = FQW_TILE(L,N) SFEVAP7A.168
ENDDO SFEVAP7A.169
ENDDO SFEVAP7A.170
SFEVAP7A.171
DO N=1,NTYPE-1 SFEVAP7A.172
DO L=1,LAND_FIELD ABX1F405.911
ECAN_TILE(L,N) = 0. SFEVAP7A.174
ESOIL_TILE(L,N) = 0. SFEVAP7A.175
ENDDO SFEVAP7A.176
ENDDO SFEVAP7A.177
SFEVAP7A.178
DO L=LAND1,LAND1+LAND_PTS-1 SFEVAP7A.179
SNOW_FRAC(L) = TILE_FRAC(L,NTYPE) SFEVAP7A.180
ENDDO SFEVAP7A.181
SFEVAP7A.182
!----------------------------------------------------------------------- SFEVAP7A.183
! Sublimation from snow (tile NTYPE) SFEVAP7A.184
!----------------------------------------------------------------------- SFEVAP7A.185
DO J=1,TILE_PTS(NTYPE) SFEVAP7A.186
L = TILE_INDEX(J,NTYPE) SFEVAP7A.187
I = LAND_INDEX(L) SFEVAP7A.188
EDT = SNOW_FRAC(L)*FQW_TILE(L,NTYPE)*TIMESTEP SFEVAP7A.189
IF ( EDT .GT. LYING_SNOW(I) ) THEN SFEVAP7A.190
FQW_ADJ = ( 1. - LYING_SNOW(I)/(FQW_TILE(L,NTYPE)*TIMESTEP) ) SFEVAP7A.191
& / (1. - SNOW_FRAC(L)) SFEVAP7A.192
FQW_TILE(L,NTYPE) = LYING_SNOW(I) / (SNOW_FRAC(L)*TIMESTEP) SFEVAP7A.193
DO N=1,NTYPE-1 SFEVAP7A.194
FQW_TILE(L,N) = FQW_ADJ*FQW_TILE(L,N) SFEVAP7A.195
ENDDO SFEVAP7A.196
ENDIF SFEVAP7A.197
ENDDO SFEVAP7A.198
SFEVAP7A.199
!----------------------------------------------------------------------- SFEVAP7A.200
! Surface evaporation from and condensation onto snow-free land SFEVAP7A.201
! (tiles 1 to NTYPE-1) SFEVAP7A.202
!----------------------------------------------------------------------- SFEVAP7A.203
DO I=P1,P1+P_POINTS-1 SFEVAP7A.204
ECAN(I) = 0. SFEVAP7A.205
ESOIL(I) = 0. SFEVAP7A.206
ENDDO SFEVAP7A.207
SFEVAP7A.208
DO N=1,NTYPE-1 SFEVAP7A.209
DO J=1,TILE_PTS(N) SFEVAP7A.210
L = TILE_INDEX(J,N) SFEVAP7A.211
I = LAND_INDEX(L) SFEVAP7A.212
IF ( FQW_TILE(L,N) .GT. 0.0 ) THEN SFEVAP7A.213
ECAN_TILE(L,N) = FRACA(L,N) * FQW_TILE(L,N) / RESFT(L,N) SFEVAP7A.214
ESOIL_TILE(L,N) = (1. - FRACA(L,N))*RESFS(L,N)*FQW_TILE(L,N) SFEVAP7A.215
& / RESFT(L,N) SFEVAP7A.216
EDT = ECAN_TILE(L,N)*TIMESTEP SFEVAP7A.217
IF ( EDT .GT. CANOPY(L,N) ) THEN SFEVAP7A.218
ESOIL_TILE(L,N) = ( 1. - FRACA(L,N)*CANOPY(L,N)/EDT ) * SFEVAP7A.219
& RESFS(L,N)*FQW_TILE(L,N)/RESFT(L,N) SFEVAP7A.220
ECAN_TILE(L,N) = CANOPY(L,N) / TIMESTEP SFEVAP7A.221
ENDIF SFEVAP7A.222
ELSE SFEVAP7A.223
ECAN_TILE(L,N) = FQW_TILE(L,N) SFEVAP7A.224
ESOIL_TILE(L,N) = 0. SFEVAP7A.225
ENDIF SFEVAP7A.226
ECAN(I) = ECAN(I) + TILE_FRAC(L,N)*ECAN_TILE(L,N) SFEVAP7A.227
ESOIL(I) = ESOIL(I) + TILE_FRAC(L,N)*ESOIL_TILE(L,N) SFEVAP7A.228
ENDDO SFEVAP7A.229
ENDDO SFEVAP7A.230
SFEVAP7A.231
!----------------------------------------------------------------------- SFEVAP7A.232
! Soil evapotranspiration SFEVAP7A.233
!----------------------------------------------------------------------- SFEVAP7A.234
DO L=LAND1,LAND1+LAND_PTS-1 SFEVAP7A.235
I = LAND_INDEX(L) SFEVAP7A.236
EDT = ESOIL(I)*TIMESTEP SFEVAP7A.237
IF ( EDT .GT. SMC(L) ) THEN SFEVAP7A.238
DO N=1,NTYPE-1 SFEVAP7A.239
ESOIL_TILE(L,N) = SMC(L)*ESOIL_TILE(L,N) / EDT SFEVAP7A.240
ENDDO SFEVAP7A.241
ESOIL(I) = SMC(L) / TIMESTEP SFEVAP7A.242
ENDIF SFEVAP7A.243
ENDDO SFEVAP7A.244
SFEVAP7A.245
DO K=1,NSHYD SFEVAP7A.246
DO L=LAND1,LAND1+LAND_PTS-1 SFEVAP7A.247
I = LAND_INDEX(L) SFEVAP7A.248
EXT(L,K) = WT_EXT(L,K)*ESOIL(I) SFEVAP7A.249
ENDDO SFEVAP7A.250
ENDDO SFEVAP7A.251
SFEVAP7A.252
!----------------------------------------------------------------------- SFEVAP7A.253
! Calculate increments to surface heat fluxes, moisture fluxes and SFEVAP7A.254
! temperatures SFEVAP7A.255
!----------------------------------------------------------------------- SFEVAP7A.256
DO L=LAND1,LAND1+LAND_PTS-1 SFEVAP7A.257
DFTL(L) = 0. SFEVAP7A.258
DFQW(L) = 0. SFEVAP7A.259
ENDDO SFEVAP7A.260
SFEVAP7A.261
! Snow-free land tiles SFEVAP7A.262
DO N=1,NTYPE-1 SFEVAP7A.263
DO J=1,TILE_PTS(N) SFEVAP7A.264
L = TILE_INDEX(J,N) SFEVAP7A.265
I = LAND_INDEX(L) ABX1F405.912
DIFF_LAT_HTF = LC * ( FQW_TILE(L,N) - FQW_TILE_OLD(L,N) ) SFEVAP7A.266
DIFF_SENS_HTF = - DIFF_LAT_HTF / SFEVAP7A.267
& ( 1. + ASHTF(I)/(CP*RHOKH_1(L,N)) ) SFEVAP7A.268
FTL_TILE(L,N) = FTL_TILE(L,N) + DIFF_SENS_HTF SFEVAP7A.269
DTSTAR = - (DIFF_LAT_HTF + DIFF_SENS_HTF) / ASHTF(I) SFEVAP7A.270
TSTAR_TILE(L,N) = TSTAR_TILE(L,N) + DTSTAR SFEVAP7A.271
DFTL(L) = DFTL(L) + TILE_FRAC(L,N)*DIFF_SENS_HTF SFEVAP7A.272
DFQW(L) = DFQW(L) + TILE_FRAC(L,N)*DIFF_LAT_HTF / LC SFEVAP7A.273
ENDDO SFEVAP7A.274
ENDDO SFEVAP7A.275
SFEVAP7A.276
! Snow tile SFEVAP7A.277
N = NTYPE SFEVAP7A.278
DO J=1,TILE_PTS(N) SFEVAP7A.279
L = TILE_INDEX(J,N) SFEVAP7A.280
I = LAND_INDEX(L) SFEVAP7A.281
DIFF_LAT_HTF = (LC + LF) * ( FQW_TILE(L,N) - FQW_TILE_OLD(L,N) ) SFEVAP7A.282
DIFF_SENS_HTF = - DIFF_LAT_HTF / SFEVAP7A.283
& ( 1. + ASHTF_SNOW(I)/(CP*RHOKH_1(L,N)) ) SFEVAP7A.284
FTL_TILE(L,N) = FTL_TILE(L,N) + DIFF_SENS_HTF SFEVAP7A.285
DTSTAR = - (DIFF_LAT_HTF + DIFF_SENS_HTF) / ASHTF_SNOW(I) SFEVAP7A.286
TSTAR_TILE(L,N) = TSTAR_TILE(L,N) + DTSTAR SFEVAP7A.287
DFTL(L) = DFTL(L) + SNOW_FRAC(L)*DIFF_SENS_HTF SFEVAP7A.288
DFQW(L) = DFQW(L) + SNOW_FRAC(L)*DIFF_LAT_HTF / (LC + LF) SFEVAP7A.289
ENDDO SFEVAP7A.290
SFEVAP7A.291
!----------------------------------------------------------------------- SFEVAP7A.292
! Update level 1 temperature and humidity and GBM heat and moisture SFEVAP7A.293
! fluxes due to limited moisture availability SFEVAP7A.294
!----------------------------------------------------------------------- SFEVAP7A.295
DO L=LAND1,LAND1+LAND_PTS-1 SFEVAP7A.296
I = LAND_INDEX(L) SFEVAP7A.297
TL_1(I) = TL_1(I) + DTRDZ_1(I) * DFTL(L) / CP SFEVAP7A.298
QW_1(I) = QW_1(I) + DTRDZ_1(I) * DFQW(L) SFEVAP7A.299
FTL_1(I) = FTL_1(I) + DFTL(L) SFEVAP7A.300
FQW_1(I) = FQW_1(I) + DFQW(L) SFEVAP7A.301
ENDDO SFEVAP7A.302
SFEVAP7A.303
IF (LTIMER) THEN SFEVAP7A.304
CALL TIMER('SFEVAP ',4) SFEVAP7A.305
ENDIF SFEVAP7A.306
SFEVAP7A.307
RETURN SFEVAP7A.308
END SFEVAP7A.309
*ENDIF SFEVAP7A.310