*IF DEF,A03_5A SFFLUX5A.2
C *****************************COPYRIGHT****************************** SFFLUX5A.3
C (c) CROWN COPYRIGHT 1996, METEOROLOGICAL OFFICE, All Rights Reserved. SFFLUX5A.4
C SFFLUX5A.5
C Use, duplication or disclosure of this code is subject to the SFFLUX5A.6
C restrictions as set forth in the contract. SFFLUX5A.7
C SFFLUX5A.8
C Meteorological Office SFFLUX5A.9
C London Road SFFLUX5A.10
C BRACKNELL SFFLUX5A.11
C Berkshire UK SFFLUX5A.12
C RG12 2SZ SFFLUX5A.13
C SFFLUX5A.14
C If no contract has been raised with this copy of the code, the use, SFFLUX5A.15
C duplication or disclosure of it is strictly prohibited. Permission SFFLUX5A.16
C to do so must first be obtained in writing from the Head of Numerical SFFLUX5A.17
C Modelling at the above address. SFFLUX5A.18
C ******************************COPYRIGHT****************************** SFFLUX5A.19
C Vn. GSS2F402.301
CLL 4.2 Oct. 96 T3E migration - *DEF CRAY removed GSS2F402.302
CLL S J Swarbrick GSS2F402.303
C 4.5 Jul. 98 Kill the IBM specific lines (JCThil) AJC1F405.73
C ********************************************************************* GSS2F402.304
SUBROUTINE SF_FLUX ( 2,4SFFLUX5A.21
& P_POINTS,LAND_PTS,LAND_MASK, SFFLUX5A.22
& P1,LAND_INDEX, SFFLUX5A.24
& ALPHA1,DQ,DQ_LEAD,DTEMP,DTEMP_LEAD,DZ1,HCONS,ICE_FRACT, SFFLUX5A.26
& LYING_SNOW,QS1,QW_1,RADNET_C,RESFT,RHOKE,RHOKH_1,TI,TL_1,TS1, APA1F405.397
& Z0H,Z0M_EFF,Z1, SFFLUX5A.28
& ASHTF,E_SEA,EPOT,FQW_1,FTL_1,H_SEA,RHOKPM,RHOKPM_POT, ANG1F405.138
& TSTAR,VFRAC,TIMESTEP,CANCAP, APA1F405.398
& LTIMER) SFFLUX5A.30
SFFLUX5A.31
IMPLICIT NONE SFFLUX5A.32
SFFLUX5A.33
INTEGER ! Variables defining grid. SFFLUX5A.34
& P_POINTS ! IN Number of P-grid points to be processed. SFFLUX5A.35
&,LAND_PTS ! IN Number of land points to be processed. SFFLUX5A.36
&,LAND_INDEX(LAND_PTS)! IN Index for compressed land point array; SFFLUX5A.40
C ! ith element holds position in the FULL SFFLUX5A.41
C ! field of the ith land pt to be processed SFFLUX5A.42
&,P1 ! IN First P-point to be processed. SFFLUX5A.43
SFFLUX5A.45
REAL SFFLUX5A.46
& ALPHA1(P_POINTS) ! IN Gradient of saturated specific humidity SFFLUX5A.47
C ! with respect to temperature between the SFFLUX5A.48
C ! bottom model layer and the surface SFFLUX5A.49
&,DQ(P_POINTS) ! Sp humidity difference between surface SFFLUX5A.50
C ! and lowest atmospheric level (Q1 - Q*). SFFLUX5A.51
C ! Holds value over sea-ice where ICE_FRACT SFFLUX5A.52
C ! >0 i.e. Leads contribution not included. SFFLUX5A.53
&,DQ_LEAD(P_POINTS) ! DQ for leads fraction of gridsquare. SFFLUX5A.54
C ! Missing data indicator over non sea-ice. SFFLUX5A.55
&,DTEMP(P_POINTS) ! Liquid/ice static energy difference SFFLUX5A.56
C ! between surface and lowest atmospheric SFFLUX5A.57
C ! level, divided by CP (a modified SFFLUX5A.58
C ! temperature difference). SFFLUX5A.59
C ! Holds value over sea-ice where ICE_FRACT SFFLUX5A.60
C ! >0 i.e. Leads contribution not included. SFFLUX5A.61
&,DTEMP_LEAD(P_POINTS) ! DTEMP for leads fraction of gridsquare. SFFLUX5A.62
C ! Missing data indicator over non sea-ice. SFFLUX5A.63
&,DZ1 ! IN Thickness of the top soil layer (m). SFFLUX5A.64
&,HCONS(LAND_PTS) ! IN Soil thermal conductivity including SFFLUX5A.65
C ! the effects of water and ice (W/m/K). SFFLUX5A.66
&,ICE_FRACT(P_POINTS) ! IN Fraction of gridbox which is sea-ice. SFFLUX5A.67
&,LYING_SNOW(P_POINTS)! IN Lying snow amount (kg per sq metre). SFFLUX5A.68
&,QS1(P_POINTS) ! Sat. specific humidity qsat(TL_1,PSTAR) SFFLUX5A.69
&,QW_1(P_POINTS) ! OUT Total water content of lowest SFFLUX5A.70
C ! atmospheric layer (kg per kg air). SFFLUX5A.71
&,RESFT(P_POINTS) ! IN Total resistance factor SFFLUX5A.74
C ! FRACA+(1-FRACA)*RESFS. SFFLUX5A.75
&,RHOKE(P_POINTS) ! IN For FQW, then *GAMMA(1) for implicit cal SFFLUX5A.76
&,RHOKH_1(P_POINTS) ! IN For FTL,then *GAMMA(1) for implicit calc SFFLUX5A.77
&,TI(P_POINTS) ! IN Temperature of sea-ice surface layer (K). SFFLUX5A.78
&,TL_1(P_POINTS) ! IN Liquid/frozen water temperature for SFFLUX5A.79
C ! lowest atmospheric layer (K). SFFLUX5A.80
&,TS1(LAND_PTS) ! IN Temperature of top soil layer (K) SFFLUX5A.81
&,Z0H(P_POINTS) ! IN Roughness length for heat and moisture m SFFLUX5A.82
&,Z0M_EFF(P_POINTS) ! IN Effective roughness length for momentum SFFLUX5A.83
&,Z1(P_POINTS) ! IN Height of lowest atmospheric level (m). SFFLUX5A.84
SFFLUX5A.85
LOGICAL SFFLUX5A.86
& LAND_MASK(P_POINTS) ! IN .TRUE. for land; .FALSE. elsewhere. F60. SFFLUX5A.87
SFFLUX5A.88
SFFLUX5A.89
! output SFFLUX5A.90
REAL SFFLUX5A.91
& ASHTF(P_POINTS) ! OUT Coefficient to calculate surface SFFLUX5A.92
C ! heat flux into soil or sea-ice (W/m2/K). SFFLUX5A.93
&,E_SEA(P_POINTS) ! OUT Evaporation from sea times leads SFFLUX5A.94
C ! fraction (kg/m2/s). Zero over land. SFFLUX5A.95
&,EPOT(P_POINTS) ! OUT potential evaporation on P-grid ANG1F405.139
C ! (kg/m2/s). ANG1F405.140
&,FQW_1(P_POINTS) ! OUT "Explicit" surface flux of QW (i.e. SFFLUX5A.96
C ! evaporation), on P-grid (kg/m2/s). SFFLUX5A.97
&,FTL_1(P_POINTS) ! OUT "Explicit" surface flux of TL = H/CP. SFFLUX5A.98
C ! (sensible heat / CP). SFFLUX5A.99
&,H_SEA(P_POINTS) ! OUT Surface sensible heat flux over sea SFFLUX5A.100
C ! times leads fraction (W/m2). SFFLUX5A.101
C ! Zero over land. SFFLUX5A.102
&,RHOKPM(P_POINTS) ! OUT NB NOT * GAMMA for implicit calcs. SFFLUX5A.103
&,RHOKPM_POT(P_POINTS) ANG1F405.141
C ! OUT Surface exchange coeff. for ANG1F405.142
C ! potential evaporation. ANG1F405.143
SFFLUX5A.104
!----------------------------------------------------------------------- APA1F405.399
! Extra variables required for the thermal canopy options. APA1F405.400
!----------------------------------------------------------------------- APA1F405.401
REAL APA1F405.402
& TSTAR(P_POINTS) ! IN Mean gridsquare surface temperature (K). APA1F405.403
&,VFRAC(LAND_PTS) ! IN Vegetation fraction. APA1F405.404
&,TIMESTEP ! IN Timestep (s). APA1F405.405
&,CANCAP(P_POINTS) ! INOUT Volumetric heat capacity of APA1F405.406
C ! vegetation canopy (J/Kg/m3). APA1F405.407
&,RADNET_C(P_POINTS)! INOUT Adjusted net radiation for vegetation APA1F405.408
C ! over land (W/m2). APA1F405.409
APA1F405.410
LOGICAL LTIMER ! Logical switch for TIMER diags SFFLUX5A.105
SFFLUX5A.106
*CALL C_G 
SFFLUX5A.107
*CALL C_SOILH SFFLUX5A.108
*CALL C_LHEAT SFFLUX5A.109
*CALL C_R_CP SFFLUX5A.110
*CALL C_KAPPAI SFFLUX5A.111
*CALL CSIGMA APA1F405.411
*CALL MOSES_OPT APA1F405.412
SFFLUX5A.112
SFFLUX5A.113
! (3) Derived local parameters. SFFLUX5A.114
REAL GRCP,LS SFFLUX5A.115
PARAMETER ( SFFLUX5A.116
& GRCP=G/CP ! Used in calc of dT across surface layer. SFFLUX5A.117
&,LS=LF+LC ! Latent heat of sublimation. SFFLUX5A.118
& ) SFFLUX5A.119
SFFLUX5A.120
! (b) Scalars. SFFLUX5A.121
SFFLUX5A.122
INTEGER SFFLUX5A.123
& I ! Loop counter (horizontal field index). SFFLUX5A.124
&,L ! Loop counter (land point field index). SFFLUX5A.125
SFFLUX5A.126
REAL SFFLUX5A.127
& DS_RATIO ! 2 * snowdepth / depth of top soil layer. SFFLUX5A.128
&,FQW_ICE ! "Explicit" surface flux of QW for sea-ice fraction SFFLUX5A.129
! ! of gridsquare. SFFLUX5A.130
&,FTL_ICE ! "Explicit" surface flux of TL for sea-ice fraction SFFLUX5A.131
! ! of gridsquare. SFFLUX5A.132
&,LAT_HEAT SFFLUX5A.133
&,RAD_REDUC ! Radiation term required for surface flux calcs. SFFLUX5A.134
SFFLUX5A.135
C*L Workspace SFFLUX5A.136
REAL SFFLUX5A.138
& DQ1(P_POINTS) ! (qsat(TL_1,PSTAR)-QW_1) + g/cp*alpha1*Z1 SFFLUX5A.139
SFFLUX5A.145
SFFLUX5A.146
!*********************************************************************** SFFLUX5A.147
! Calculate sensible and latent heat fluxes for land points. SFFLUX5A.148
!*********************************************************************** SFFLUX5A.149
SFFLUX5A.150
IF (LTIMER) THEN SFFLUX5A.151
CALL TIMER('SFFLUX ',3) SFFLUX5A.152
ENDIF SFFLUX5A.153
CDIR$ IVDEP SFFLUX5A.159
! Fujitsu vectorization directive GRB0F405.495
!OCL NOVREC GRB0F405.496
DO L = 1,LAND_PTS SFFLUX5A.160
I = LAND_INDEX(L) - (P1-1) SFFLUX5A.161
ASHTF(I) = 2.0 * HCONS(L) / DZ1 SFFLUX5A.163
IF (LYING_SNOW(I) .GT. 0.0) THEN SFFLUX5A.164
LAT_HEAT = LS SFFLUX5A.165
DS_RATIO = 2.0 * LYING_SNOW(I) / (RHO_SNOW * DZ1) SFFLUX5A.166
IF (DS_RATIO.LE.1.0) THEN SFFLUX5A.167
ASHTF(I) = ASHTF(I) / SFFLUX5A.168
& (1. + DS_RATIO*(HCONS(L)/SNOW_HCON - 1.)) SFFLUX5A.169
ELSE IF (LYING_SNOW(I) .LT. 5.0E3) THEN SFFLUX5A.170
ASHTF(I) = ASHTF(I)*SNOW_HCON / HCONS(L) SFFLUX5A.171
ENDIF SFFLUX5A.172
ELSE SFFLUX5A.173
LAT_HEAT = LC SFFLUX5A.174
ENDIF SFFLUX5A.175
E_SEA(I) = 0.0 SFFLUX5A.176
H_SEA(I) = 0.0 SFFLUX5A.177
APA1F405.413
APA1F405.414
!----------------------------------------------------------------------- APA1F405.415
! Options for treatment of vegetation thermal canopy APA1F405.416
!----------------------------------------------------------------------- APA1F405.417
IF (CAN_MODEL .EQ. 1) THEN APA1F405.418
ASHTF(I) = ASHTF(I) APA1F405.419
CANCAP(I) = 0.0 APA1F405.420
APA1F405.421
ELSEIF (CAN_MODEL .EQ. 2) THEN APA1F405.422
ASHTF(I) = (1.0-VFRAC(L))*ASHTF(I) + APA1F405.423
& VFRAC(L)*4.0*SBCON*(TS1(L)**3) APA1F405.424
CANCAP(I) = 0.0 APA1F405.425
APA1F405.426
ELSEIF (CAN_MODEL .EQ. 3) THEN APA1F405.427
ASHTF(I) = (1.0-VFRAC(L))*ASHTF(I) + APA1F405.428
& VFRAC(L)*4.0*SBCON*(TS1(L)**3) APA1F405.429
CANCAP(I) = (1.0-VFRAC(L))*0.0 + VFRAC(L)*10.0*1.0E4 APA1F405.430
APA1F405.431
ENDIF APA1F405.432
ASHTF(I) = ASHTF(I) + CANCAP(I)/TIMESTEP APA1F405.433
APA1F405.434
RHOKPM(I) = RHOKH_1(I) / ( RHOKH_1(I) * SFFLUX5A.178
& (LAT_HEAT*ALPHA1(I)*RESFT(I) + CP) + ASHTF(I) ) SFFLUX5A.179
RADNET_C(I)=RADNET_C(I) + CANCAP(I)*(TSTAR(I)-TS1(L))/TIMESTEP APA1F405.435
RAD_REDUC = RADNET_C(I) - ASHTF(I) * APA1F405.436
& ( TL_1(I) - TS1(L) + GRCP * (Z1(I) SFFLUX5A.181
& + Z0M_EFF(I) - Z0H(I)) ) SFFLUX5A.182
DQ1(I) = (QS1(I)-QW_1(I)) + SFFLUX5A.183
& GRCP * ALPHA1(I) * (Z1(I) + Z0M_EFF(I) - Z0H(I)) SFFLUX5A.184
FQW_1(I) = RESFT(I)*RHOKPM(I)*( ALPHA1(I) * SFFLUX5A.185
& RAD_REDUC + (CP*RHOKH_1(I) + ASHTF(I))* DQ1(I) ) SFFLUX5A.186
FTL_1(I) = RHOKPM(I) * SFFLUX5A.187
& ( RAD_REDUC - LAT_HEAT*RESFT(I)*RHOKH_1(I)*DQ1(I) ) SFFLUX5A.188
RHOKPM_POT(I)=RHOKH_1(I) / ( RHOKH_1(I) * ANG1F405.144
& (LAT_HEAT*ALPHA1(I) + CP) + ASHTF(I) ) ANG1F405.145
EPOT(I) = RHOKPM_POT(I)*( ALPHA1(I) * ANG1F405.146
& RAD_REDUC + (CP*RHOKH_1(I) + ASHTF(I))* DQ1(I) ) ANG1F405.147
! SFFLUX5A.189
!*********************************************************************** SFFLUX5A.190
! Calculate sensible and latent heat fluxes for sea and sea-ice points SFFLUX5A.191
!*********************************************************************** SFFLUX5A.192
! SFFLUX5A.193
ENDDO SFFLUX5A.198
DO I=1,P_POINTS SFFLUX5A.199
IF ( .NOT. LAND_MASK(I).AND.ICE_FRACT(I).GT.0.0) THEN !sea-ice SFFLUX5A.200
ASHTF(I) = 2 * KAPPAI / DE SFFLUX5A.202
E_SEA(I) = - (1. - ICE_FRACT(I))*RHOKH_1(I)*DQ_LEAD(I) SFFLUX5A.203
SFFLUX5A.204
H_SEA(I) = - (1. - ICE_FRACT(I))*RHOKH_1(I)*CP*DTEMP_LEAD(I) SFFLUX5A.205
SFFLUX5A.206
!*********************************************************************** SFFLUX5A.207
! Calculate the sensible and latent heat fluxes from sea-ice portion SFFLUX5A.208
! of gridbox. Weight RHOKPM by ICE_FRACT for use in IMPL_CAL. SFFLUX5A.209
!*********************************************************************** SFFLUX5A.210
SFFLUX5A.211
RHOKPM(I) = RHOKH_1(I) / ( RHOKH_1(I) * SFFLUX5A.212
& (LS * ALPHA1(I) + CP) + ASHTF(I) ) SFFLUX5A.213
RAD_REDUC = RADNET_C(I) - ICE_FRACT(I) * ASHTF(I) * APA1F405.437
& ( TL_1(I) - TI(I) + GRCP * (Z1(I) SFFLUX5A.215
& + Z0M_EFF(I) - Z0H(I)) ) SFFLUX5A.216
DQ1(I) = (QS1(I)-QW_1(I)) + SFFLUX5A.217
& GRCP * ALPHA1(I) * (Z1(I) + Z0M_EFF(I) - Z0H(I)) SFFLUX5A.218
FQW_ICE = RHOKPM(I) * ( ALPHA1(I) * RAD_REDUC + SFFLUX5A.219
& (CP * RHOKH_1(I) + ASHTF(I)) * DQ1(I) * ICE_FRACT(I) ) SFFLUX5A.220
FTL_ICE = RHOKPM(I) * ( RAD_REDUC - SFFLUX5A.221
& ICE_FRACT(I) * LS * RHOKH_1(I) * DQ1(I) ) SFFLUX5A.222
RHOKPM(I) = ICE_FRACT(I) * RHOKPM(I) SFFLUX5A.223
RHOKPM_POT(I)=RHOKPM(I) ANG1F405.148
SFFLUX5A.224
!*********************************************************************** SFFLUX5A.225
! Calculate the total flux over the gridbox SFFLUX5A.226
!*********************************************************************** SFFLUX5A.227
! SFFLUX5A.228
FTL_1(I) = H_SEA(I)/CP + FTL_ICE SFFLUX5A.229
FQW_1(I) = E_SEA(I) + FQW_ICE SFFLUX5A.230
EPOT(I) = E_SEA(I) + FQW_ICE ANG1F405.149
! Sea points SFFLUX5A.235
ELSE IF( .NOT.LAND_MASK(I) .AND. .NOT.ICE_FRACT(I).GT.0.0 ) SFFLUX5A.236
& THEN SFFLUX5A.237
E_SEA(I) = - RHOKH_1(I) * DQ(I) SFFLUX5A.239
H_SEA(I) = - RHOKH_1(I) * CP * DTEMP(I) SFFLUX5A.240
FQW_1(I) = E_SEA(I) SFFLUX5A.241
EPOT(I) = E_SEA(I) ANG1F405.150
FTL_1(I) = H_SEA(I) / CP SFFLUX5A.242
RHOKPM(I) = 0.0 SFFLUX5A.243
RHOKPM_POT(I)=RHOKPM(I) ANG1F405.151
ASHTF(I) = 1.0 SFFLUX5A.244
! SFFLUX5A.245
ENDIF ! sea/sea-ice block SFFLUX5A.249
ENDDO SFFLUX5A.251
SFFLUX5A.252
IF (LTIMER) THEN SFFLUX5A.253
CALL TIMER('SFFLUX ',4) SFFLUX5A.254
ENDIF SFFLUX5A.255
RETURN SFFLUX5A.256
END SFFLUX5A.257
*ENDIF SFFLUX5A.258