*IF DEF,A03_5A SFREST5A.2
C *****************************COPYRIGHT****************************** SFREST5A.3
C (c) CROWN COPYRIGHT 1996, METEOROLOGICAL OFFICE, All Rights Reserved. SFREST5A.4
C SFREST5A.5
C Use, duplication or disclosure of this code is subject to the SFREST5A.6
C restrictions as set forth in the contract. SFREST5A.7
C SFREST5A.8
C Meteorological Office SFREST5A.9
C London Road SFREST5A.10
C BRACKNELL SFREST5A.11
C Berkshire UK SFREST5A.12
C RG12 2SZ SFREST5A.13
C SFREST5A.14
C If no contract has been raised with this copy of the code, the use, SFREST5A.15
C duplication or disclosure of it is strictly prohibited. Permission SFREST5A.16
C to do so must first be obtained in writing from the Head of Numerical SFREST5A.17
C Modelling at the above address. SFREST5A.18
C ******************************COPYRIGHT****************************** SFREST5A.19
C*LL SUBROUTINE SF_RESIST---------------------------------------------- SFREST5A.20
CLL SFREST5A.21
CLL Purpose: Calculate bulk Richardson number for surface layer SFREST5A.22
CLL SFREST5A.23
C Modification History: AJC1F405.60
C Version Date Change AJC1F405.61
C 4.5 Jul. 98 Kill the IBM specific lines (JCThil) AJC1F405.62
CLL SFREST5A.24
CLLEND----------------------------------------------------------------- SFREST5A.25
C* SFREST5A.26
C*L Arguaments ------------------------------------------------------- SFREST5A.27
SUBROUTINE SF_RESIST ( 6,6SFREST5A.28
& P_POINTS,LAND_PTS,LAND_MASK,INT_STOM, SFREST5A.29
& P1,LAND_INDEX, SFREST5A.31
& ROOTD,SMVCCL,SMVCWT,SMC,V_SOIL,VFRAC,CANOPY,CATCH,DQ, SFREST5A.33
& EPDT,LYING_SNOW,GC,RESIST,VSHR,CH,PSIS,FRACA, SFREST5A.34
& RESFS,F_SE,RESFT,LTIMER SFREST5A.35
& ) SFREST5A.36
IMPLICIT NONE SFREST5A.37
SFREST5A.38
SFREST5A.39
INTEGER ! Variables defining grid. SFREST5A.40
& P_POINTS ! IN Number of P-grid points to be processed SFREST5A.41
&,LAND_PTS ! IN Number of land points to be processed. SFREST5A.42
SFREST5A.43
&,LAND_INDEX(LAND_PTS)! IN Index for compressed land point array; SFREST5A.45
C ! i'th element holds position in the FULL SFREST5A.46
C ! field of the ith land pt to be SFREST5A.47
C ! processed SFREST5A.48
&,P1 ! IN First P-point to be processed. SFREST5A.49
SFREST5A.51
LOGICAL SFREST5A.52
& INT_STOM ! IN T for interactive stomatal resistance. SFREST5A.53
SFREST5A.54
REAL SFREST5A.55
& CANOPY(LAND_PTS) ! IN Surface water (kg per sq metre). F642. SFREST5A.56
&,CATCH(LAND_PTS) ! IN Surface capacity (max. surface water) SFREST5A.57
C ! (kg per sq metre). F6416. SFREST5A.58
&,CH(P_POINTS) ! IN Transport coefficient for heat and SFREST5A.59
C ! moisture transport SFREST5A.60
&,DQ(P_POINTS) ! IN Sp humidity difference between surface SFREST5A.61
C ! and lowest atmospheric level (Q1 - Q*). SFREST5A.62
C ! Holds value over sea-ice where SFREST5A.63
C ! ICE_FRACT>0 i.e. Leads contribution not SFREST5A.64
C ! included. SFREST5A.65
&,EPDT(P_POINTS) ! IN "Potential" Evaporation * Timestep. SFREST5A.66
C ! Dummy variable for first call to routine SFREST5A.67
&,LYING_SNOW(P_POINTS)! IN Lying snow amount (kg per sq metre). SFREST5A.68
&,GC(LAND_PTS) ! IN Interactive canopy conductance SFREST5A.69
C ! to evaporation (m/s) SFREST5A.70
&,RESIST(LAND_PTS) ! IN Fixed "stomatal" resistance SFREST5A.71
C ! to evaporation (s/m) SFREST5A.72
&,ROOTD(LAND_PTS) ! IN "Root depth" (metres). F6412. SFREST5A.73
&,SMC(LAND_PTS) ! IN Soil moisture content (kg per sq m). SFREST5A.74
C ! F621. SFREST5A.75
&,SMVCCL(LAND_PTS) ! IN Critical volumetric SMC (cubic metres SFREST5A.76
C ! per cubic metre of soil). F6232. SFREST5A.77
&,SMVCWT(LAND_PTS) ! IN Volumetric wilting point (cubic m of SFREST5A.78
C ! water per cubic m of soil). F6231. SFREST5A.79
&,V_SOIL(LAND_PTS) ! IN Volumetric soil moisture concentration SFREST5A.80
C ! in the top soil layer (m3 H2O/m3 soil). SFREST5A.81
&,VFRAC(LAND_PTS) ! IN Vegetated fraction. SFREST5A.82
&,VSHR(P_POINTS) ! IN Magnitude of surface-to-lowest-lev. wind SFREST5A.83
C SFREST5A.84
C Note: (SMVCCL - SMVCWT) is the critical volumetric available soil SFREST5A.85
LOGICAL SFREST5A.86
& LAND_MASK(P_POINTS) ! IN .TRUE. for land; .FALSE. elsewhere. F60. SFREST5A.87
C SFREST5A.88
C Output variables. SFREST5A.89
C SFREST5A.90
REAL SFREST5A.91
& FRACA(P_POINTS) ! OUT Fraction of surface moisture flux with SFREST5A.92
C ! only aerodynamic resistance. SFREST5A.93
&,PSIS(P_POINTS) ! OUT Soil moisture availability factor. SFREST5A.94
&,RESFS(P_POINTS) ! OUT Combined soil, stomatal and aerodynamic SFREST5A.95
C ! resistance factor = PSIS/(1+RS/RA) for SFREST5A.96
C ! fraction (1-FRACA). SFREST5A.97
&,F_SE(P_POINTS) ! OUT Fraction of the evapotranspiration SFREST5A.98
C ! which is bare soil evaporation. SFREST5A.99
&,RESFT(P_POINTS) ! OUT Total resistance factor SFREST5A.100
C ! FRACA+(1-FRACA)*RESFS. SFREST5A.101
SFREST5A.102
LOGICAL LTIMER ! Logical switch for TIMER diags SFREST5A.103
C Define local storage. SFREST5A.104
C SFREST5A.105
C (a) Workspace. SFREST5A.106
C SFREST5A.107
*CALL C_DENSTY 
SFREST5A.108
*CALL SOIL_THICK SFREST5A.109
*CALL C_MDI SFREST5A.110
SFREST5A.111
SFREST5A.112
C*L Workspace -------------------------------------------------------- SFREST5A.113
INTEGER SFREST5A.114
& I ! Loop counter (horizontal field index). SFREST5A.115
&,J ! Loop counter (land field index). SFREST5A.116
&,L ! Loop counter (land field index). SFREST5A.117
REAL SFREST5A.118
& FSMC ! Soil moisture factor for bare soil evaporation. SFREST5A.119
&,SMCRIT ! "Critical" available SMC in kg per sq m. SFREST5A.120
SFREST5A.121
IF (LTIMER) THEN SFREST5A.122
CALL TIMER('SFRESIST',3) SFREST5A.123
ENDIF SFREST5A.124
C----------------------------------------------------------------------- SFREST5A.125
CL 6 Evaporation over land surfaces without snow is limited by SFREST5A.126
CL soil moisture availability and stomatal resistance. SFREST5A.127
C Set FRACA (= fA in the documentation) according to P243.68, SFREST5A.128
C PSIS according to P243.65, and RESFS (= fS) according to P243.75 SFREST5A.129
C and P243.61, using neutral-stability value of CH (as explained SFREST5A.130
C in section (v) of the P243 documentation). SFREST5A.131
C----------------------------------------------------------------------- SFREST5A.132
DO I=1,P_POINTS SFREST5A.133
C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SFREST5A.134
CL 6.1 Set parameters (workspace) to values relevant for non-land SFREST5A.135
CL points. Only aerodynamic resistance applies. SFREST5A.136
C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SFREST5A.137
FRACA(I) = 1.0 SFREST5A.138
PSIS(I) = 0.0 SFREST5A.139
RESFT(I) = 1.0 SFREST5A.140
RESFS(I) = 0.0 SFREST5A.141
ENDDO SFREST5A.143
C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SFREST5A.145
CL 6.2 Over-write workspace for other points. SFREST5A.146
C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SFREST5A.147
CDIR$ IVDEP SFREST5A.152
! Fujitsu vectorization directive GRB0F405.503
!OCL NOVREC GRB0F405.504
DO L=1,LAND_PTS SFREST5A.153
I = LAND_INDEX(L) - (P1-1) SFREST5A.154
SFREST5A.156
!----------------------------------------------------------------------- SFREST5A.157
! If the interactive stomatal resistance is being used, calculate the SFREST5A.158
! soil water factor for bare soil evaporation SFREST5A.159
!----------------------------------------------------------------------- SFREST5A.160
IF (INT_STOM) THEN SFREST5A.161
SFREST5A.162
IF (V_SOIL(L) .GT. SMVCCL(L)) THEN SFREST5A.163
FSMC = 1.0 SFREST5A.164
ELSEIF (V_SOIL(L) .LE. SMVCWT(L)) THEN SFREST5A.165
FSMC = 0.0 SFREST5A.166
ELSE SFREST5A.167
FSMC = (V_SOIL(L) - SMVCWT(L)) SFREST5A.168
& / (SMVCCL(L) - SMVCWT(L)) SFREST5A.169
ENDIF SFREST5A.170
SFREST5A.171
ELSE SFREST5A.172
C SFREST5A.173
C Calculate the soil moisture availability factor, PSIS. SFREST5A.174
C SFREST5A.175
SMCRIT = RHO_WATER * ROOTD(L) * (SMVCCL(L)-SMVCWT(L)) SFREST5A.176
C ... P243.66 SFREST5A.177
C SFREST5A.178
PSIS(I) = 0.0 SFREST5A.179
IF (SMC(L).GE.SMCRIT .AND. SMCRIT.GT.0.0) SFREST5A.180
& PSIS(I) = 1.0 SFREST5A.181
IF (SMC(L).LT.SMCRIT .AND. SMC(L).GT.0.0) SFREST5A.182
& PSIS(I) = SMC(L)/SMCRIT SFREST5A.183
SFREST5A.184
ENDIF SFREST5A.185
C SFREST5A.186
C For snow-covered land or land points with negative moisture flux SFREST5A.187
C set the fraction of the flux with only aerodynamic resistance to 1 SFREST5A.188
C (no surface/stomatal resistance to evap from snow or condensation). SFREST5A.189
C SFREST5A.190
FRACA(I) = 1.0 SFREST5A.191
C SFREST5A.192
C When there is positive moisture flux from snow-free land, calculate SFREST5A.193
C the fraction of the flux from the "canopy". SFREST5A.194
C SFREST5A.195
IF (DQ(I).LT.0.0 .AND. LYING_SNOW(I).LE.0.0) FRACA(I) = 0.0 SFREST5A.196
IF (DQ(I).LT.0.0.AND.LYING_SNOW(I).LE.0.0.AND.CATCH(L).GT.0.0) SFREST5A.197
& FRACA(I) = CANOPY(L)/(EPDT(I) + CATCH(L)) SFREST5A.198
SFREST5A.199
SFREST5A.200
!----------------------------------------------------------------------- SFREST5A.201
! If the interactive stomatal resistance is being used calculate SFREST5A.202
! separate resistance factors for bare soil evaporation and SFREST5A.203
! transpiration. Assume a surface resistance of 100 s/m for bare soil. SFREST5A.204
!----------------------------------------------------------------------- SFREST5A.205
IF (INT_STOM) THEN ! Interactive Canopy Resistance SFREST5A.206
SFREST5A.207
!----------------------------------------------------------------------- SFREST5A.208
! Set resistance and moisture availability factors to zero for land ice SFREST5A.209
!----------------------------------------------------------------------- SFREST5A.210
IF (GC(L).EQ.RMDI) THEN ! land-ice points SFREST5A.211
SFREST5A.212
PSIS(I) = 0.0 SFREST5A.213
RESFS(I) = 0.0 SFREST5A.214
F_SE(I) = 0.0 SFREST5A.215
SFREST5A.216
ELSE SFREST5A.217
SFREST5A.218
!----------------------------------------------------------------------- SFREST5A.219
! If the interactive stomatal resistance is being used set the moisture SFREST5A.220
! availability factor to one, since moisture stress is already taken SFREST5A.221
! account of in SF_STOM (Peter Cox 21/11/95). SFREST5A.222
!----------------------------------------------------------------------- SFREST5A.223
SFREST5A.224
PSIS(I) = 1.0 SFREST5A.225
RESFS(I) = VFRAC(L) * GC(L) / ( GC(L) + CH(I)*VSHR(I)) SFREST5A.226
& + (1 - VFRAC(L)) * FSMC / (1.0 + CH(I)*VSHR(I)*100.0) SFREST5A.227
SFREST5A.228
F_SE(I) = 0.0 SFREST5A.229
SFREST5A.230
IF (RESFS(I) .GT. 0.0) THEN SFREST5A.231
F_SE(I) = (1 - VFRAC(L)) * FSMC SFREST5A.232
& / (RESFS(I)*(1.0 + CH(I)*VSHR(I)*100.0)) SFREST5A.233
ENDIF SFREST5A.234
SFREST5A.235
ENDIF SFREST5A.236
SFREST5A.237
ELSE SFREST5A.238
SFREST5A.239
RESFS(I) = PSIS(I) / ( 1.0 + CH(I)*VSHR(I)*RESIST(L)) SFREST5A.240
F_SE(I) = 0.0 SFREST5A.241
SFREST5A.242
ENDIF SFREST5A.243
SFREST5A.244
RESFT(I) = FRACA(I) + (1.0 - FRACA(I)) * RESFS(I) SFREST5A.245
ENDDO ! Evaporation over land points only, section 3.4.2 SFREST5A.250
SFREST5A.252
IF (LTIMER) THEN SFREST5A.253
CALL TIMER('SFRESIST',4) SFREST5A.254
ENDIF SFREST5A.255
RETURN SFREST5A.256
END SFREST5A.257
*ENDIF SFREST5A.258