*IF DEF,A03_6A ACB1F405.9
C *****************************COPYRIGHT****************************** SFFLUX5B.3
C (c) CROWN COPYRIGHT 1997, METEOROLOGICAL OFFICE, All Rights Reserved. SFFLUX5B.4
C SFFLUX5B.5
C Use, duplication or disclosure of this code is subject to the SFFLUX5B.6
C restrictions as set forth in the contract. SFFLUX5B.7
C SFFLUX5B.8
C Meteorological Office SFFLUX5B.9
C London Road SFFLUX5B.10
C BRACKNELL SFFLUX5B.11
C Berkshire UK SFFLUX5B.12
C RG12 2SZ SFFLUX5B.13
C SFFLUX5B.14
C If no contract has been raised with this copy of the code, the use, SFFLUX5B.15
C duplication or disclosure of it is strictly prohibited. Permission SFFLUX5B.16
C to do so must first be obtained in writing from the Head of Numerical SFFLUX5B.17
C Modelling at the above address. SFFLUX5B.18
C ******************************COPYRIGHT****************************** SFFLUX5B.19
C Modification History: AJC1F405.70
C Version Date Change AJC1F405.71
C 4.5 Jul. 98 Kill the IBM specific lines (JCThil) AJC1F405.72
SFFLUX5B.20
SUBROUTINE SF_FLUX ( 2,4SFFLUX5B.21
& P_POINTS,P_FIELD,LAND_PTS,LAND_FIELD,LAND_MASK,L_LAND,P1,LAND1, SFFLUX5B.22
& LAND_INDEX, SFFLUX5B.24
& ALPHA1,DQ,DQ_LEAD,DTEMP,DTEMP_LEAD,DZ1,HCONS,ICE_FRACT, SFFLUX5B.26
& LYING_SNOW,QS1,QW_1,RADNET_C,RESFT,RHOKE,RHOKH_1,TI,TL_1,TS1, APA1F405.447
& Z0H,Z0M_EFF,Z1_TQ,Z1_UV, SFFLUX5B.28
& ASHTF,E_SEA,EPOT,FQW_1,FTL_1,H_SEA,RHOKPM,RHOKPM_POT,LTIMER ANG1F405.152
&,TSTAR,VFRAC,TIMESTEP,CANCAP APA1F405.448
& ) SFFLUX5B.30
SFFLUX5B.31
IMPLICIT NONE SFFLUX5B.32
SFFLUX5B.33
INTEGER ! Variables defining grid. SFFLUX5B.34
& P_POINTS ! IN Number of P-grid points to be processed. SFFLUX5B.35
&,P_FIELD ! IN Total number of P-grid points. SFFLUX5B.36
&,P1 ! IN First P-point to be processed. SFFLUX5B.37
&,LAND1 ! IN First land point to be processed. SFFLUX5B.38
&,LAND_PTS ! IN Number of land points to be processed. SFFLUX5B.39
&,LAND_FIELD ! IN Total number of land points. SFFLUX5B.40
&,LAND_INDEX(LAND_FIELD) ! IN Index for compressed land point array SFFLUX5B.44
! ith element holds position in the FULL SFFLUX5B.45
! field of the ith land pt to be processed SFFLUX5B.46
SFFLUX5B.48
LOGICAL SFFLUX5B.49
& L_LAND ! IN switch to only calculate for land points SFFLUX5B.50
&,LTIMER SFFLUX5B.51
REAL SFFLUX5B.52
& ALPHA1(P_FIELD) ! IN Gradient of saturated specific humidity SFFLUX5B.53
! with respect to temperature between the SFFLUX5B.54
! bottom model layer and the surface SFFLUX5B.55
&,DQ(P_FIELD) ! IN Sp humidity difference between surface SFFLUX5B.56
! and lowest atmospheric level (Q1 - Q*). SFFLUX5B.57
! Holds value over sea-ice where ICE_FRACT SFFLUX5B.58
! >0 i.e. Leads contribution not included. SFFLUX5B.59
&,DQ_LEAD(P_FIELD) ! IN DQ for leads fraction of gridsquare. SFFLUX5B.60
! Missing data indicator over non sea-ice. SFFLUX5B.61
&,DTEMP(P_FIELD) ! IN Liquid/ice static energy difference SFFLUX5B.62
! between surface and lowest atmospheric SFFLUX5B.63
! level, divided by CP (a modified SFFLUX5B.64
! temperature difference). SFFLUX5B.65
! Holds value over sea-ice where ICE_FRACT SFFLUX5B.66
! >0 i.e. Leads contribution not included. SFFLUX5B.67
&,DTEMP_LEAD(P_FIELD) ! IN DTEMP for leads fraction of gridsquare. SFFLUX5B.68
! Missing data indicator over non sea-ice. SFFLUX5B.69
&,DZ1 ! IN Thickness of the top soil layer (m). SFFLUX5B.70
&,HCONS(LAND_FIELD) ! IN Soil thermal conductivity including SFFLUX5B.71
! the effects of water and ice(W/m/K). SFFLUX5B.72
&,ICE_FRACT(P_FIELD) ! IN Fraction of gridbox which is sea-ice. SFFLUX5B.73
&,LYING_SNOW(P_FIELD) ! IN Lying snow amount (kg per sq metre). SFFLUX5B.74
&,QS1(P_FIELD) ! IN Sat. specific humidity qsat(TL_1,PSTAR) SFFLUX5B.75
&,QW_1(P_FIELD) ! IN Total water content of lowest SFFLUX5B.76
! atmospheric layer (kg per kg air). SFFLUX5B.77
&,RESFT(P_FIELD) ! IN Total resistance factor SFFLUX5B.80
! FRACA+(1-FRACA)*RESFS. SFFLUX5B.81
&,RHOKE(P_FIELD) ! IN For FQW, then *GAMMA(1) for implicit SFFLUX5B.82
! calcs SFFLUX5B.83
&,RHOKH_1(P_FIELD) ! IN For FTL, then *GAMMA(1) for implicit SFFLUX5B.84
! ! calcs SFFLUX5B.85
&,TI(P_FIELD) ! IN Temperature of sea-ice surface layer (K) SFFLUX5B.86
&,TL_1(P_FIELD) ! IN Liquid/frozen water temperature for SFFLUX5B.87
! lowest atmospheric layer (K). SFFLUX5B.88
&,TS1(LAND_FIELD) ! IN Temperature of top soil layer (K) SFFLUX5B.89
&,Z0H(P_FIELD) ! IN Roughness length for heat and moisture m SFFLUX5B.90
&,Z0M_EFF(P_FIELD) ! IN Effective roughness length for momentum SFFLUX5B.91
&,Z1_TQ(P_FIELD) ! IN Height of lowest atmospheric level (m). SFFLUX5B.92
&,Z1_UV(P_FIELD) ! IN Height of lowest atmospheric level (m). SFFLUX5B.93
SFFLUX5B.94
LOGICAL SFFLUX5B.95
& LAND_MASK(P_FIELD) ! IN .TRUE. for land; .FALSE. elsewhere. F60. SFFLUX5B.96
SFFLUX5B.97
SFFLUX5B.98
! output SFFLUX5B.99
REAL SFFLUX5B.100
& ASHTF(P_FIELD) ! OUT Coefficient to calculate surface SFFLUX5B.101
! heat flux into soil or sea-ice (W/m2/K). SFFLUX5B.102
&,E_SEA(P_FIELD) ! OUT Evaporation from sea times leads SFFLUX5B.103
! fraction (kg/m2/s). Zero over land. SFFLUX5B.104
&,EPOT(P_FIELD) ! OUT potential evaporation on P-grid ANG1F405.153
! (kg/m2/s). ANG1F405.154
&,FQW_1(P_FIELD) ! OUT "Explicit" surface flux of QW (i.e. SFFLUX5B.105
! evaporation), on P-grid (kg/m2/s). SFFLUX5B.106
&,FTL_1(P_FIELD) ! OUT "Explicit" surface flux of TL = H/CP. SFFLUX5B.107
! (sensible heat / CP). SFFLUX5B.108
&,H_SEA(P_FIELD) ! OUT Surface sensible heat flux over sea SFFLUX5B.109
! times leads fraction (W/m2). SFFLUX5B.110
! Zero over land. SFFLUX5B.111
&,RHOKPM(P_FIELD) ! OUT NB NOT * GAMMA for implicit calcs. SFFLUX5B.112
&,RHOKPM_POT(P_FIELD) ! OUT Surface exchange coeff. for ANG1F405.155
! potential evaporation. ANG1F405.156
SFFLUX5B.113
!----------------------------------------------------------------------- APA1F405.449
! Extra variables required for the thermal canopy options. APA1F405.450
!----------------------------------------------------------------------- APA1F405.451
REAL APA1F405.452
& TSTAR(P_FIELD) ! IN Mean gridsquare surface temperature (K). APA1F405.453
&,VFRAC(LAND_FIELD)! IN Vegetation fraction. APA1F405.454
&,TIMESTEP ! IN Timestep (s). APA1F405.455
&,CANCAP(P_FIELD) ! INOUT Volumetric heat capacity of APA1F405.456
C ! vegetation canopy (J/Kg/m3). APA1F405.457
&,RADNET_C(P_FIELD)! INOUT Adjusted net radiation for vegetation APA1F405.458
C ! over land (W/m2). APA1F405.459
SFFLUX5B.114
*CALL C_G 
SFFLUX5B.115
*CALL C_SOILH SFFLUX5B.116
*CALL C_LHEAT SFFLUX5B.117
*CALL C_R_CP SFFLUX5B.118
*CALL C_KAPPAI SFFLUX5B.119
*CALL CSIGMA APA1F405.460
*CALL MOSES_OPT APA1F405.461
SFFLUX5B.120
SFFLUX5B.121
! (3) Derived local parameters. SFFLUX5B.122
REAL GRCP,LS SFFLUX5B.123
PARAMETER ( SFFLUX5B.124
& GRCP=G/CP ! Used in calc of dT across surface layer. SFFLUX5B.125
&,LS=LF+LC ! Latent heat of sublimation. SFFLUX5B.126
& ) SFFLUX5B.127
SFFLUX5B.128
! (b) Scalars. SFFLUX5B.129
SFFLUX5B.130
INTEGER SFFLUX5B.131
& I ! Loop counter (horizontal field index). SFFLUX5B.132
&,L ! Loop counter (land point field index). SFFLUX5B.133
SFFLUX5B.134
REAL SFFLUX5B.135
& DS_RATIO ! 2 * snowdepth / depth of top soil layer. SFFLUX5B.136
&,FQW_ICE ! "Explicit" surface flux of QW for sea-ice SFFLUX5B.137
! fraction of gridsquare. SFFLUX5B.138
&,FTL_ICE ! "Explicit" surface flux of TL for sea-ice SFFLUX5B.139
! fraction of gridsquare. SFFLUX5B.140
&,LAT_HEAT SFFLUX5B.141
&,RAD_REDUC ! Radiation term required for surface flux SFFLUX5B.142
! calcs. SFFLUX5B.143
SFFLUX5B.144
!! Workspace SFFLUX5B.145
REAL SFFLUX5B.146
& DQ1(P_FIELD) ! (qsat(TL_1,PSTAR)-QW_1) + g/cp*alpha1*Z1 SFFLUX5B.147
SFFLUX5B.148
SFFLUX5B.149
EXTERNAL TIMER SFFLUX5B.150
SFFLUX5B.151
!*********************************************************************** SFFLUX5B.152
! Calculate sensible and latent heat fluxes for land points. SFFLUX5B.153
!*********************************************************************** SFFLUX5B.154
IF (LTIMER) THEN SFFLUX5B.155
CALL TIMER('SF_FLUX ',3) SFFLUX5B.156
ENDIF SFFLUX5B.157
SFFLUX5B.158
CDIR$ IVDEP SFFLUX5B.164
! Fujitsu vectorization directive GRB0F405.497
!OCL NOVREC GRB0F405.498
DO L = LAND1,LAND1+LAND_PTS-1 SFFLUX5B.165
I = LAND_INDEX(L) SFFLUX5B.166
SFFLUX5B.168
ASHTF(I) = 2.0 * HCONS(L) / DZ1 SFFLUX5B.169
IF (LYING_SNOW(I) .GT. 0.0) THEN SFFLUX5B.170
LAT_HEAT = LS SFFLUX5B.171
DS_RATIO = 2.0 * LYING_SNOW(I) / (RHO_SNOW * DZ1) SFFLUX5B.172
IF (DS_RATIO.LE.1.0) THEN SFFLUX5B.173
ASHTF(I) = ASHTF(I) / SFFLUX5B.174
& (1. + DS_RATIO*(HCONS(L)/SNOW_HCON - 1.)) SFFLUX5B.175
ELSE IF (LYING_SNOW(I) .LT. 5.0E3) THEN SFFLUX5B.176
ASHTF(I) = ASHTF(I)*SNOW_HCON / HCONS(L) SFFLUX5B.177
ENDIF SFFLUX5B.178
ELSE SFFLUX5B.179
LAT_HEAT = LC SFFLUX5B.180
ENDIF SFFLUX5B.181
E_SEA(I) = 0.0 SFFLUX5B.182
H_SEA(I) = 0.0 SFFLUX5B.183
SFFLUX5B.184
!----------------------------------------------------------------------- APA1F405.462
! Options for treatment of vegetation thermal canopy APA1F405.463
!----------------------------------------------------------------------- APA1F405.464
IF (CAN_MODEL .EQ. 1) THEN APA1F405.465
ASHTF(I) = ASHTF(I) APA1F405.466
CANCAP(I) = 0.0 APA1F405.467
APA1F405.468
ELSEIF (CAN_MODEL .EQ. 2) THEN APA1F405.469
ASHTF(I) = (1.0-VFRAC(L))*ASHTF(I) + APA1F405.470
& VFRAC(L)*4.0*SBCON*(TS1(L)**3) APA1F405.471
CANCAP(I) = 0.0 APA1F405.472
APA1F405.473
ELSEIF (CAN_MODEL .EQ. 3) THEN APA1F405.474
ASHTF(I) = (1.0-VFRAC(L))*ASHTF(I) + APA1F405.475
& VFRAC(L)*4.0*SBCON*(TS1(L)**3) APA1F405.476
CANCAP(I) = (1.0-VFRAC(L))*0.0 + VFRAC(L)*10.0*1.0E4 APA1F405.477
APA1F405.478
ENDIF APA1F405.479
ASHTF(I) = ASHTF(I) + CANCAP(I)/TIMESTEP APA1F405.480
APA1F405.481
RHOKPM(I) = RHOKH_1(I) / ( RHOKH_1(I) * SFFLUX5B.185
& (LAT_HEAT*ALPHA1(I)*RESFT(I) + CP) + ASHTF(I) ) SFFLUX5B.186
RADNET_C(I)=RADNET_C(I) + CANCAP(I)*(TSTAR(I)-TS1(L))/TIMESTEP APA1F405.482
RAD_REDUC = RADNET_C(I) - ASHTF(I) * APA1F405.483
& ( TL_1(I) - TS1(L) + GRCP * (Z1_TQ(I) SFFLUX5B.188
& + Z0M_EFF(I) - Z0H(I)) ) SFFLUX5B.189
DQ1(I) = (QS1(I)-QW_1(I)) + SFFLUX5B.190
& GRCP * ALPHA1(I) * (Z1_TQ(I) + Z0M_EFF(I) - Z0H(I)) SFFLUX5B.191
FQW_1(I) = RESFT(I)*RHOKPM(I)*( ALPHA1(I) * SFFLUX5B.192
& RAD_REDUC + (CP*RHOKH_1(I) + ASHTF(I))* DQ1(I) ) SFFLUX5B.193
RHOKPM_POT(I)=RHOKH_1(I) / ( RHOKH_1(I) * ANG1F405.157
& (LAT_HEAT*ALPHA1(I) + CP) + ASHTF(I) ) ANG1F405.158
EPOT(I) = RHOKPM_POT(I)*( ALPHA1(I) * ANG1F405.159
& RAD_REDUC + (CP*RHOKH_1(I) + ASHTF(I))* DQ1(I) ) ANG1F405.160
FTL_1(I) = RHOKPM(I) * SFFLUX5B.194
& ( RAD_REDUC - LAT_HEAT*RESFT(I)*RHOKH_1(I)*DQ1(I) ) SFFLUX5B.195
SFFLUX5B.196
!*********************************************************************** SFFLUX5B.197
! Calculate sensible and latent heat fluxes for sea and sea-ice points SFFLUX5B.198
!*********************************************************************** SFFLUX5B.199
SFFLUX5B.200
ENDDO ! loop over land points SFFLUX5B.205
SFFLUX5B.206
IF (.NOT.L_LAND) THEN SFFLUX5B.207
DO I=P1,P1+P_POINTS-1 SFFLUX5B.208
IF ( .NOT. LAND_MASK(I).AND.ICE_FRACT(I).GT.0.0) THEN !sea-ice SFFLUX5B.209
ASHTF(I) = 2 * KAPPAI / DE SFFLUX5B.211
E_SEA(I) = - (1. - ICE_FRACT(I))*RHOKH_1(I)*DQ_LEAD(I) SFFLUX5B.212
SFFLUX5B.213
H_SEA(I) = - (1. - ICE_FRACT(I))*RHOKH_1(I)*CP*DTEMP_LEAD(I) SFFLUX5B.214
SFFLUX5B.215
!*********************************************************************** SFFLUX5B.216
! Calculate the sensible and latent heat fluxes from sea-ice portion SFFLUX5B.217
! of gridbox. Weight RHOKPM by ICE_FRACT for use in IMPL_CAL. SFFLUX5B.218
!*********************************************************************** SFFLUX5B.219
SFFLUX5B.220
RHOKPM(I) = RHOKH_1(I) / ( RHOKH_1(I) * SFFLUX5B.221
& (LS * ALPHA1(I) + CP) + ASHTF(I) ) SFFLUX5B.222
RAD_REDUC = RADNET_C(I) - ICE_FRACT(I) * ASHTF(I) * APA1F405.484
& ( TL_1(I) - TI(I) + GRCP * (Z1_TQ(I) SFFLUX5B.224
& + Z0M_EFF(I) - Z0H(I)) ) SFFLUX5B.225
DQ1(I) = (QS1(I)-QW_1(I)) + SFFLUX5B.226
& GRCP * ALPHA1(I) * (Z1_TQ(I) + Z0M_EFF(I) - Z0H(I)) SFFLUX5B.227
FQW_ICE = RHOKPM(I) * ( ALPHA1(I) * RAD_REDUC + SFFLUX5B.228
& (CP * RHOKH_1(I) + ASHTF(I)) * DQ1(I) * ICE_FRACT(I) ) SFFLUX5B.229
FTL_ICE = RHOKPM(I) * ( RAD_REDUC - SFFLUX5B.230
& ICE_FRACT(I) * LS * RHOKH_1(I) * DQ1(I) ) SFFLUX5B.231
RHOKPM(I) = ICE_FRACT(I) * RHOKPM(I) SFFLUX5B.232
RHOKPM_POT(I)=RHOKPM(I) ANG1F405.161
SFFLUX5B.233
!*********************************************************************** SFFLUX5B.234
! Calculate the total flux over the gridbox SFFLUX5B.235
!*********************************************************************** SFFLUX5B.236
SFFLUX5B.237
FTL_1(I) = H_SEA(I)/CP + FTL_ICE SFFLUX5B.238
FQW_1(I) = E_SEA(I) + FQW_ICE SFFLUX5B.239
EPOT(I) = E_SEA(I) + FQW_ICE ANG1F405.162
! Sea points SFFLUX5B.244
ELSE IF( .NOT.LAND_MASK(I) .AND. .NOT.ICE_FRACT(I).GT.0.0 ) SFFLUX5B.245
& THEN SFFLUX5B.246
E_SEA(I) = - RHOKH_1(I) * DQ(I) SFFLUX5B.248
H_SEA(I) = - RHOKH_1(I) * CP * DTEMP(I) SFFLUX5B.249
FQW_1(I) = E_SEA(I) SFFLUX5B.250
EPOT(I) = E_SEA(I) ANG1F405.163
FTL_1(I) = H_SEA(I) / CP SFFLUX5B.251
RHOKPM(I) = 0.0 SFFLUX5B.252
RHOKPM_POT(I)=RHOKPM(I) ANG1F405.164
ASHTF(I) = 1.0 SFFLUX5B.253
SFFLUX5B.254
ENDIF ! sea/sea-ice block SFFLUX5B.258
ENDDO SFFLUX5B.260
SFFLUX5B.261
ENDIF ! L_LAND SFFLUX5B.263
IF (LTIMER) THEN SFFLUX5B.265
CALL TIMER('SF_FLUX ',4) SFFLUX5B.266
ENDIF SFFLUX5B.267
SFFLUX5B.268
RETURN SFFLUX5B.269
END SFFLUX5B.270
*ENDIF SFFLUX5B.271