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