*IF DEF,A03_6A SFRIB6A.2
C *****************************COPYRIGHT****************************** SFRIB6A.3
C (c) CROWN COPYRIGHT 1997, METEOROLOGICAL OFFICE, All Rights Reserved. SFRIB6A.4
C SFRIB6A.5
C Use, duplication or disclosure of this code is subject to the SFRIB6A.6
C restrictions as set forth in the contract. SFRIB6A.7
C SFRIB6A.8
C Meteorological Office SFRIB6A.9
C London Road SFRIB6A.10
C BRACKNELL SFRIB6A.11
C Berkshire UK SFRIB6A.12
C RG12 2SZ SFRIB6A.13
C SFRIB6A.14
C If no contract has been raised with this copy of the code, the use, SFRIB6A.15
C duplication or disclosure of it is strictly prohibited. Permission SFRIB6A.16
C to do so must first be obtained in writing from the Head of Numerical SFRIB6A.17
C Modelling at the above address. SFRIB6A.18
C ******************************COPYRIGHT****************************** SFRIB6A.19
! SFRIB6A.20
!!! SUBROUTINE SF_RIB------------------------------------------------ SFRIB6A.21
!!! SFRIB6A.22
!!! Purpose: Calculate bulk Richardson number for surface layer SFRIB6A.23
!!! SFRIB6A.24
!!! <- programmer of some or all of previous code changes SFRIB6A.25
!!! Simon Jackson, Roderick Smith SFRIB6A.26
!!! SFRIB6A.27
C Modification History: AJC1F405.53
C Version Date Change AJC1F405.54
C 4.5 Jul. 98 Kill the IBM specific lines (JCThil) AJC1F405.55
!!!END----------------------------------------------------------------- SFRIB6A.28
SFRIB6A.29
!! Arguaments ------------------------------------------------------- SFRIB6A.30
SUBROUTINE SF_RIB ( 2,6SFRIB6A.31
& P_POINTS,LAND_PTS,P_FIELD,LAND_FIELD,LAND_MASK,L_LAND,INT_STOM, SFRIB6A.32
& P1,LAND1, SFRIB6A.33
& GATHER,LAND_INDEX, SFRIB6A.35
& NSICE,SICE_INDEX,ICE_FRACT,Q_1,QW_1,QCL_1,QCF_1, SFRIB6A.37
& T_1,TL_1,QSL,QSTAR,QSTAR_LEAD, SFRIB6A.38
& QS1,TSTAR_NL,Z1_TQ,Z1_UV,Z0M_EFF,Z0M,Z0H,Z0HS,Z0MSEA, SFRIB6A.39
& WIND_PROFILE_FACTOR,U_1_P,U_0_P,V_1_P,V_0_P, SFRIB6A.40
& ROOTD,SMVCCL,SMVCWT,SMC,VFRAC,V_SOIL,CANOPY,CATCH, SFRIB6A.41
& LYING_SNOW,GC,RESIST,DB,DB_LEAD,RIB,RIB_LEAD,PSIS,VSHR,ALPHA1, SFRIB6A.42
& BT_1,BQ_1,FRACA,RESFS,DQ,DQ_LEAD,DTEMP,DTEMP_LEAD,LTIMER SFRIB6A.43
& ) SFRIB6A.44
SFRIB6A.45
IMPLICIT NONE SFRIB6A.46
SFRIB6A.47
SFRIB6A.48
INTEGER ! Variables defining grid. SFRIB6A.49
& P_POINTS ! IN Number of P-grid points to be processed SFRIB6A.50
&,LAND_PTS ! IN Number of land points to be processed. SFRIB6A.51
&,P_FIELD ! IN Total number of P-grid points SFRIB6A.52
&,LAND_FIELD ! IN Total number of land points. SFRIB6A.53
&,NSICE ! IN Number of sea-ice points. SFRIB6A.54
&,SICE_INDEX(P_FIELD) ! IN Index vector for gather to sea-ice SFRIB6A.55
! ! points SFRIB6A.56
&,P1 ! IN First P-point to be processed. SFRIB6A.57
&,LAND1 ! IN First land-point to be processed. SFRIB6A.58
&,LAND_INDEX(LAND_FIELD) SFRIB6A.60
! IN Index for compressed land point array; SFRIB6A.61
! i'th element holds position in the FULL SFRIB6A.62
! field of the ith land pt to be SFRIB6A.63
! processed SFRIB6A.64
LOGICAL SFRIB6A.65
& GATHER ! IN If true then leads variables are comp- SFRIB6A.66
! ressed for sea-ice calculations. This SFRIB6A.67
! saves duplicating calculations if there SFRIB6A.68
! are a relatively few of sea-ice points. SFRIB6A.69
! Set to false for a limited area run SFRIB6A.70
! with a high proportion of sea-ice. SFRIB6A.71
SFRIB6A.73
LOGICAL SFRIB6A.74
& INT_STOM ! IN T for interactive stomatal resistance. SFRIB6A.75
&,LTIMER ! IN logical for TIMER SFRIB6A.76
&,L_LAND ! IN calculate only over land if .true. SFRIB6A.77
&,LAND_MASK(P_FIELD) ! IN .TRUE. for land; .FALSE. elsewhere. F60. SFRIB6A.78
SFRIB6A.79
REAL SFRIB6A.80
& CANOPY(LAND_FIELD) ! IN Surface water (kg per sq metre). F642. SFRIB6A.81
&,CATCH(LAND_FIELD) ! IN Surface capacity (max. surface water) SFRIB6A.82
! (kg per sq metre). F6416. SFRIB6A.83
&,GC(LAND_FIELD) ! IN Interactive canopy conductance SFRIB6A.84
! to evaporation (m/s) SFRIB6A.85
&,ICE_FRACT(P_FIELD) ! IN Fraction of gridbox which is sea-ice. SFRIB6A.86
&,LYING_SNOW(P_FIELD) ! IN Lying snow amount (kg per sq metre). SFRIB6A.87
&,Q_1(P_FIELD) ! IN Specific humidity for lowest SFRIB6A.88
! atmospheric layer (kg water per kg air) SFRIB6A.89
&,QCF_1(P_FIELD) ! IN Cloud ice for lowest atmospheric layer SFRIB6A.90
! (kg water per kg air). SFRIB6A.91
&,QCL_1(P_FIELD) ! IN Cloud liquid water for lowest atm layer SFRIB6A.92
! (kg water per kg air). SFRIB6A.93
&,QW_1(P_FIELD) ! IN Total water content of lowest SFRIB6A.94
! atmospheric layer (kg per kg air). SFRIB6A.95
&,QS1(P_FIELD) ! IN Sat. specific humidity qsat(TL_1,PSTAR) SFRIB6A.96
&,QSL(P_FIELD) ! IN Saturated sp humidity at liquid/ice SFRIB6A.97
! temperature and pressure of lowest SFRIB6A.98
! atmospheric level. SFRIB6A.99
&,QSTAR(P_FIELD) ! IN Surface saturated sp humidity. Holds SFRIB6A.100
! value over sea-ice where ICE_FRACT > 0. SFRIB6A.101
! i.e. Leads contribution not included. SFRIB6A.102
&,QSTAR_LEAD(P_FIELD) ! IN QSTAR for sea-ice leads. SFRIB6A.103
! Missing data indicator over non sea-ice. SFRIB6A.104
&,RESIST(LAND_FIELD) ! IN "Stomatal" resistance to evaporation SFRIB6A.105
! (seconds per metre). F6415. SFRIB6A.106
&,ROOTD(LAND_FIELD) ! IN "Root depth" (metres). F6412. SFRIB6A.107
&,SMC(LAND_FIELD) ! IN Soil moisture content (kg per sq m). SFRIB6A.108
! F621. SFRIB6A.109
&,SMVCCL(LAND_FIELD) ! IN Critical volumetric SMC (cubic metres SFRIB6A.110
! per cubic metre of soil). F6232. SFRIB6A.111
&,SMVCWT(LAND_FIELD) ! IN Volumetric wilting point (cubic m of SFRIB6A.112
! water per cubic m of soil). F6231. SFRIB6A.113
SFRIB6A.114
! Note: (SMVCCL - SMVCWT) is the critical volumetric available soil SFRIB6A.115
! moisture content. ~~~~~~~~~ SFRIB6A.116
SFRIB6A.117
&,T_1(P_FIELD) ! IN Temperature for lowest atmospheric layer SFRIB6A.118
! (Kelvin). SFRIB6A.119
&,TL_1(P_FIELD) ! IN Liquid/frozen water temperature for SFRIB6A.120
! lowest atmospheric layer (K). SFRIB6A.121
&,TSTAR_NL(P_FIELD) ! IN TSTAR No Leads: surface temperature SFRIB6A.122
! over sea-ice fraction of gridsquare. SFRIB6A.123
! =TSTAR over non sea-ice points. SFRIB6A.124
&,U_1_P(P_FIELD) ! IN West-to-east wind component for lowest SFRIB6A.125
! atmospheric layer (m/s). On P grid. SFRIB6A.126
&,V_1_P(P_FIELD) ! IN South-to-north wind component for lowest SFRIB6A.130
! atmospheric layer (m/s). On P grid. SFRIB6A.131
&,U_0_P(P_FIELD) ! IN West-to-east component of ocean surface SFRIB6A.135
! current (m/s; zero over land if U_0 OK). SFRIB6A.136
! P grid. F615. SFRIB6A.137
&,V_0_P(P_FIELD) ! IN South-to-north component of ocean surface SFRIB6A.138
! current (m/s; zero over land if V_0 OK). SFRIB6A.139
! P grid. F616. SFRIB6A.140
&,V_SOIL(LAND_FIELD) ! IN Volumetric soil moisture concentration SFRIB6A.141
! in the top soil layer (m3 H2O/m3 soil). SFRIB6A.142
&,VFRAC(LAND_FIELD) ! IN Vegetated fraction. SFRIB6A.143
&,WIND_PROFILE_FACTOR(P_FIELD) SFRIB6A.144
! ! IN For transforming effective surface SFRIB6A.145
! transfer coefficients to those excluding SFRIB6A.146
! form drag. SFRIB6A.147
&,Z0H(P_FIELD) ! IN Roughness length for heat and moisture m SFRIB6A.148
&,Z0HS(P_FIELD) ! IN Roughness length for heat and moisture SFRIB6A.149
! transport over sea. SFRIB6A.150
&,Z0M(P_FIELD) ! IN Roughness length for heat and moisture m SFRIB6A.151
&,Z0MSEA(P_FIELD) ! IN Sea-surface roughness length for SFRIB6A.152
! momentum (m). F617. SFRIB6A.153
&,Z0M_EFF(P_FIELD) ! IN Effective roughness length for momentum SFRIB6A.154
&,Z1_TQ(P_FIELD) ! IN Height of lowest TQ level (m). SFRIB6A.155
&,Z1_UV(P_FIELD) ! IN Height of lowest UV level (m). SFRIB6A.156
SFRIB6A.157
SFRIB6A.158
! Output variables. SFRIB6A.159
SFRIB6A.160
REAL SFRIB6A.161
& ALPHA1(P_FIELD) ! OUT Gradient of saturated specific humidity SFRIB6A.162
! with respect to temperature between the SFRIB6A.163
! bottom model layer and the surface SFRIB6A.164
&,BQ_1(P_FIELD) ! OUT A buoyancy parameter for lowest atm SFRIB6A.165
! level. ("beta-q twiddle"). SFRIB6A.166
&,BT_1(P_FIELD) ! OUT A buoyancy parameter for lowest atm SFRIB6A.167
! level. ("beta-T twiddle"). SFRIB6A.168
&,DQ(P_FIELD) ! OUT Sp humidity difference between surface SFRIB6A.169
! and lowest atmospheric level (Q1 - Q*). SFRIB6A.170
! Holds value over sea-ice where SFRIB6A.171
! ICE_FRACT>0 i.e. Leads contribution not SFRIB6A.172
! included. SFRIB6A.173
&,DQ_LEAD(P_FIELD) ! OUT DQ for leads fraction of gridsquare. SFRIB6A.174
&,DTEMP(P_FIELD) ! OUT Liquid/ice static energy difference SFRIB6A.175
! between surface and lowest atmospheric SFRIB6A.176
! level, divided by CP (a modified SFRIB6A.177
! temperature difference). SFRIB6A.178
! Holds value over sea-ice where SFRIB6A.179
! ICE_FRACT>0 i.e. Leads contribution not SFRIB6A.180
! included. SFRIB6A.181
&,DTEMP_LEAD(P_FIELD)! OUT DTEMP for leads fraction of gridsquare. SFRIB6A.182
&,FRACA(P_FIELD) ! OUT Fraction of surface moisture flux with SFRIB6A.183
! only aerodynamic resistance. SFRIB6A.184
&,PSIS(P_FIELD) ! OUT Soil moisture availability factor. SFRIB6A.185
&,RESFS(P_FIELD) ! OUT Combined soil, stomatal and aerodynamic SFRIB6A.186
! resistance factor = PSIS/(1+RS/RA) for SFRIB6A.187
! fraction (1-FRACA) SFRIB6A.188
&,RESFT(P_FIELD) ! OUT Total resistance factor SFRIB6A.189
! FRACA+(1-FRACA)*RESFS. SFRIB6A.190
&,DB(P_POINTS) ! OUT Buoyancy difference between surface SFRIB6A.191
! ! and lowest atmospheric level. SFRIB6A.192
! ! Holds value over sea-ice where ICE_FRACT SFRIB6A.193
! ! >0 i.e. Leads contribution not included. SFRIB6A.194
&,DB_LEAD(P_POINTS) ! OUT DB for leads fraction of gridsquare. SFRIB6A.195
! ! Missing data indicator over non sea-ice. SFRIB6A.196
&,RIB(P_FIELD) ! OUT Bulk Richardson number for lowest layer SFRIB6A.197
&,RIB_LEAD(P_FIELD) ! OUT Bulk Richardson no. for sea-ice leads SFRIB6A.198
! at lowest layer. At non sea-ice points SFRIB6A.199
! holds RIB for FCDCH calculation, then SFRIB6A.200
! set to missing data indicator. SFRIB6A.201
&,VSHR(P_FIELD) ! OUT Magnitude of surface-to-lowest-lev. wind SFRIB6A.202
SFRIB6A.203
SFRIB6A.204
! Symbolic constants ----------------------------------------------- SFRIB6A.205
SFRIB6A.206
SFRIB6A.207
*CALL C_MDI 
SFRIB6A.208
*CALL C_0_DG_C SFRIB6A.209
*CALL C_G SFRIB6A.210
*CALL C_LHEAT SFRIB6A.211
*CALL C_SOILH SFRIB6A.212
*CALL C_R_CP SFRIB6A.213
*CALL C_EPSLON SFRIB6A.214
*CALL C_VKMAN SFRIB6A.215
*CALL C_DENSTY SFRIB6A.216
SFRIB6A.217
! (3) Derived local parameters. SFRIB6A.218
SFRIB6A.219
REAL ETAR,GRCP,LCRCP,LFRCP,LS,LSRCP SFRIB6A.220
PARAMETER ( SFRIB6A.221
& ETAR=1./(1.-EPSILON)! Used in calc of buoyancy parameter BETAC SFRIB6A.222
&,GRCP=G/CP ! Used in calc of dT across surface layer. SFRIB6A.223
&,LCRCP=LC/CP ! Evaporation-to-dT conversion factor. SFRIB6A.224
&,LFRCP=LF/CP ! Freezing-to-dT conversion factor. SFRIB6A.225
&,LS=LF+LC ! Latent heat of sublimation. SFRIB6A.226
&,LSRCP=LS/CP ! Sublimation-to-dT conversion factor. SFRIB6A.227
& ) SFRIB6A.228
SFRIB6A.229
! Define local storage. SFRIB6A.230
SFRIB6A.231
! (a) Workspace. SFRIB6A.232
SFRIB6A.233
! Workspace -------------------------------------------------------- SFRIB6A.234
INTEGER SFRIB6A.235
& I ! Loop counter (horizontal field index). SFRIB6A.236
&,L ! Loop counter (land field index). SFRIB6A.237
&,SI ! Loop counter (sea-ice field index). SFRIB6A.238
REAL SFRIB6A.239
& VIRT_FACTOR ! Factor for converting temperature to virtual temp. SFRIB6A.240
&,D_T ! Temporary in calculation of alpha1. SFRIB6A.241
&,USHEAR ! U-component of surface-to-lowest-level wind shear. SFRIB6A.242
&,VSHEAR ! V-component of surface-to-lowest-level wind shear. SFRIB6A.243
&,VSHR2 ! Square of magnitude of surface-to-lowest-level SFRIB6A.244
! ! wind shear. SFRIB6A.245
&,ZETAM ! Temporary in calculation of CHN. SFRIB6A.246
&,ZETAH ! Temporary in calculation of CHN. SFRIB6A.247
SFRIB6A.248
REAL SFRIB6A.249
& CHN(P_FIELD) ! Neutral-stability value of CH, used as a SFRIB6A.250
! first approximation to the "true" CH. SFRIB6A.251
&,EPDT(P_FIELD) ! "Potential" Evaporation * Timestep - dummy SFRIB6A.252
! variable = 0. SFRIB6A.253
&,F_SE(P_FIELD) ! Dummy variable - actual value set in SFRIB6A.254
! 2nd Call to SF_RESIST in SF_EXCH SFRIB6A.255
SFRIB6A.256
SFRIB6A.257
EXTERNAL SF_RESIST SFRIB6A.258
SFRIB6A.259
!---------------------------------------------------------------------- SFRIB6A.260
!! 1 Calculate buoyancy parameters for the lowest model level. SFRIB6A.261
!---------------------------------------------------------------------- SFRIB6A.262
IF (LTIMER) THEN SFRIB6A.263
CALL TIMER('SF_RIB ',3) SFRIB6A.264
ENDIF SFRIB6A.265
SFRIB6A.266
DO I=P1,P1+P_POINTS-1 SFRIB6A.267
SFRIB6A.268
VIRT_FACTOR = 1.0 + C_VIRTUAL*Q_1(I) - QCL_1(I) - QCF_1(I) SFRIB6A.269
BT_1(I) = 1.0 / T_1(I) ! P243.19 (1st eqn) SFRIB6A.270
BQ_1(I) = C_VIRTUAL / VIRT_FACTOR SFRIB6A.271
! ! P243.19 (2nd eqn) SFRIB6A.272
!*********************************************************************** SFRIB6A.273
!! 2. Calculate gradient of saturated specific SFRIB6A.274
!! humidity for use in calculation of surface fluxes SFRIB6A.275
!*********************************************************************** SFRIB6A.276
! SFRIB6A.277
D_T = TSTAR_NL(I)-TL_1(I) SFRIB6A.278
SFRIB6A.279
IF (D_T .GT. 0.05 .OR. D_T .LT. -0.05) THEN SFRIB6A.280
ALPHA1(I) = (QSTAR(I) - QS1(I)) / D_T SFRIB6A.281
ELSEIF (TL_1(I) .GT. TM) THEN SFRIB6A.282
SFRIB6A.283
ALPHA1(I)=(EPSILON * LC * QS1(I) * SFRIB6A.284
& (1.0+C_VIRTUAL*QS1(I)) )/(R*TL_1(I)*TL_1(I)) SFRIB6A.285
SFRIB6A.286
ELSE SFRIB6A.287
SFRIB6A.288
ALPHA1(I)=(EPSILON * LS * QS1(I) * SFRIB6A.289
& (1.0+C_VIRTUAL*QS1(I)) )/(R*TL_1(I)*TL_1(I)) SFRIB6A.290
ENDIF SFRIB6A.291
SFRIB6A.292
! ALPHA1 set to zero over open sea, so that P-M only applies over land SFRIB6A.293
SFRIB6A.294
IF(.NOT.LAND_MASK(I).AND.ICE_FRACT(I).LE.0) ALPHA1(I)=0.0 SFRIB6A.295
SFRIB6A.296
ENDDO SFRIB6A.297
SFRIB6A.298
!----------------------------------------------------------------------- SFRIB6A.299
!! 3 Calculate temperature (strictly, liquid/ice static energy) and SFRIB6A.300
!! humidity jumps, and wind shear, across the surface layer. SFRIB6A.301
!! Separate values are required for the leads and ice fractions SFRIB6A.302
!! of sea-ice grid-squares. SFRIB6A.303
!----------------------------------------------------------------------- SFRIB6A.304
IF (GATHER) THEN SFRIB6A.306
DO I=P1,P1+P_POINTS-1 SFRIB6A.307
DTEMP(I) = TL_1(I) - TSTAR_NL(I) SFRIB6A.308
& + GRCP * ( Z1_TQ(I) + Z0M_EFF(I) - Z0H(I) ) SFRIB6A.309
! ! P243.118 SFRIB6A.310
DQ(I) = QW_1(I) - QSTAR(I) ! P243.119 SFRIB6A.311
SFRIB6A.312
DTEMP_LEAD(I) = 1.E30 ! Missing data indicator SFRIB6A.313
DQ_LEAD(I) = 1.E30 ! Missing data indicator SFRIB6A.314
USHEAR = U_1_P(I) - U_0_P(I) SFRIB6A.315
VSHEAR = V_1_P(I) - V_0_P(I) SFRIB6A.316
VSHR2 = MAX (1.0E-6 , USHEAR*USHEAR + VSHEAR*VSHEAR) SFRIB6A.317
VSHR(I) = SQRT(VSHR2) SFRIB6A.318
! ! P243.120 (previous 4 lines of code) SFRIB6A.319
ENDDO SFRIB6A.320
SFRIB6A.321
!----------------------------------------------------------------------- SFRIB6A.322
!! 4 Calculate leads values by looping round sea-ice points only. SFRIB6A.323
!! Avoids an if test in the above loop, so code can run faster. SFRIB6A.324
!----------------------------------------------------------------------- SFRIB6A.325
CDIR$ IVDEP SFRIB6A.326
! Fujitsu vectorization directive GRB0F405.511
!OCL NOVREC GRB0F405.512
DO SI=1,NSICE SFRIB6A.327
I = SICE_INDEX(SI) SFRIB6A.328
DTEMP_LEAD(I) = TL_1(I)-TFS + GRCP* SFRIB6A.329
& (Z1_TQ(I)+Z0MSEA(I)-Z0HS(I)) SFRIB6A.330
DQ_LEAD(I) = QW_1(I) - QSTAR_LEAD(SI) SFRIB6A.331
ENDDO SFRIB6A.332
ELSE SFRIB6A.333
DO I=P1,P1+P_POINTS-1 SFRIB6A.335
USHEAR = U_1_P(I) - U_0_P(I) SFRIB6A.336
VSHEAR = V_1_P(I) - V_0_P(I) SFRIB6A.337
SFRIB6A.338
VSHR2 = MAX (1.0E-6 , USHEAR*USHEAR + VSHEAR*VSHEAR) SFRIB6A.339
VSHR(I) = SQRT(VSHR2) SFRIB6A.340
! ... P243.120 (previous 4 lines of code) SFRIB6A.341
DTEMP(I) = TL_1(I) - TSTAR_NL(I) SFRIB6A.342
& + GRCP * ( Z1_TQ(I) + Z0M_EFF(I) - Z0H(I) ) SFRIB6A.343
! ! P243.118 SFRIB6A.344
DQ(I) = QW_1(I) - QSTAR(I) ! P243.119 SFRIB6A.345
! SFRIB6A.346
IF ( ICE_FRACT(I).GT.0.0 .AND. .NOT.LAND_MASK(I) ) THEN SFRIB6A.347
DTEMP_LEAD(I) = TL_1(I)-TFS + GRCP* SFRIB6A.348
& (Z1_TQ(I)+Z0MSEA(I)-Z0HS(I)) SFRIB6A.349
DQ_LEAD(I) = QW_1(I) - QSTAR_LEAD(I) SFRIB6A.350
ELSE SFRIB6A.351
DTEMP_LEAD(I) = RMDI ! Missing data indicator SFRIB6A.352
DQ_LEAD(I) = RMDI ! Missing data indicator SFRIB6A.353
ENDIF SFRIB6A.354
SFRIB6A.355
ENDDO SFRIB6A.356
ENDIF ! End of IF (GATHER) THEN... ELSE... SFRIB6A.358
SFRIB6A.360
!----------------------------------------------------------------------- SFRIB6A.361
!! 5 Evaporation over land surfaces without snow is limited by SFRIB6A.362
!! soil moisture availability and stomatal resistance. SFRIB6A.363
!! Set FRACA (= fA in the documentation) according to P243.68, SFRIB6A.364
!! PSIS according to P243.65, and RESFS (= fS) according to P243.75 SFRIB6A.365
!! and P243.61, using neutral-stability value of CH (as explained SFRIB6A.366
!! in section (v) of the P243 documentation). SFRIB6A.367
!----------------------------------------------------------------------- SFRIB6A.368
SFRIB6A.369
DO I=P1,P1+P_POINTS-1 SFRIB6A.370
ZETAM = LOG ( (Z1_UV(I) + Z0M_EFF(I))/Z0M_EFF(I) ) SFRIB6A.371
ZETAH = LOG ( (Z1_TQ(I) + Z0M_EFF(I))/Z0H(I) ) SFRIB6A.372
CHN(I) = (VKMAN/ZETAH) * (VKMAN/ZETAM) * WIND_PROFILE_FACTOR(I) SFRIB6A.373
CHN(I) = CHN(I)*VSHR(I) SFRIB6A.374
SFRIB6A.375
EPDT(I) = 0.0 !Dummy variable for SF_RESIST SFRIB6A.376
SFRIB6A.377
ENDDO ! Calc of CHN SFRIB6A.378
SFRIB6A.379
SFRIB6A.380
CALL SF_RESIST ( SFRIB6A.381
& P_POINTS,LAND_PTS,P_FIELD,LAND_FIELD,LAND_MASK,INT_STOM,P1,LAND1, SFRIB6A.382
& LAND_INDEX, SFRIB6A.384
& ROOTD,SMVCCL,SMVCWT,SMC,V_SOIL,VFRAC,CANOPY,CATCH,DQ, SFRIB6A.386
& EPDT,LYING_SNOW,GC,RESIST,CHN,PSIS,FRACA, SFRIB6A.387
& RESFS,F_SE,RESFT,LTIMER) SFRIB6A.388
SFRIB6A.389
SFRIB6A.390
!----------------------------------------------------------------------- SFRIB6A.391
!! 6 Calculate bulk Richardson numbers for the surface layer. SFRIB6A.392
!! At sea-ice points RIB contains value for ice only (not leads). SFRIB6A.393
!! Initialise RIB_LEAD to RIB so that it contains sensible SFRIB6A.394
!! values at non sea ice points for the FCDCH calculation below. SFRIB6A.395
!----------------------------------------------------------------------- SFRIB6A.396
IF (GATHER) THEN SFRIB6A.398
DO I=P1,P1+P_POINTS-1 SFRIB6A.399
SFRIB6A.400
DB(I) = G * ( BT_1(I)*DTEMP(I) + BQ_1(I)*RESFT(I)*DQ(I) ) SFRIB6A.401
RIB(I) = Z1_UV(I) * DB(I) / ( VSHR(I)*VSHR(I) ) SFRIB6A.402
DB_LEAD(I) = DB(I) SFRIB6A.403
RIB_LEAD(I) = RIB(I) SFRIB6A.404
SFRIB6A.405
ENDDO SFRIB6A.406
!----------------------------------------------------------------------- SFRIB6A.407
!! 6.1 Calculate bulk Richardson no. for leads at sea-ice points SFRIB6A.408
!! only. SFRIB6A.409
!----------------------------------------------------------------------- SFRIB6A.410
SFRIB6A.411
CDIR$ IVDEP SFRIB6A.412
! Fujitsu vectorization directive GRB0F405.513
!OCL NOVREC GRB0F405.514
DO SI = 1,NSICE SFRIB6A.413
I = SICE_INDEX(SI) SFRIB6A.414
DB_LEAD(I) = G * ( BT_1(I) * DTEMP_LEAD(I) + SFRIB6A.415
& BQ_1(I) * RESFT(I) * DQ_LEAD(I) ) SFRIB6A.416
RIB_LEAD(I) = Z1_UV(I) * DB_LEAD(I) / ( VSHR(I) * VSHR(I) ) SFRIB6A.417
! ... P2430.2, for sea-ice leads. SFRIB6A.418
ENDDO SFRIB6A.419
ELSE SFRIB6A.420
DO I=P1,P1+P_POINTS-1 SFRIB6A.422
SFRIB6A.423
DB(I) = G * ( BT_1(I)*DTEMP(I) + BQ_1(I)*RESFT(I)*DQ(I) ) SFRIB6A.424
RIB(I) = Z1_UV(I) * DB(I) / ( VSHR(I)*VSHR(I) ) SFRIB6A.425
! SFRIB6A.426
DB_LEAD(I) = DB(I) SFRIB6A.427
RIB_LEAD(I) = RIB(I) SFRIB6A.428
! SFRIB6A.429
IF ( ICE_FRACT(I).GT.0.0 .AND. .NOT.LAND_MASK(I) ) THEN SFRIB6A.430
DB_LEAD(I) = G * ( BT_1(I) * DTEMP_LEAD(I) + SFRIB6A.431
& BQ_1(I) * RESFT(I) * DQ_LEAD(I) ) SFRIB6A.432
RIB_LEAD(I) = Z1_UV(I) * DB_LEAD(I) / ( VSHR(I) * VSHR(I) ) SFRIB6A.433
! ... P2430.2, for sea-ice leads. SFRIB6A.434
SFRIB6A.435
ENDIF ! Ice_fract SFRIB6A.436
ENDDO SFRIB6A.437
ENDIF ! End of IF (GATHER) THEN... ELSE... SFRIB6A.439
SFRIB6A.441
IF (LTIMER) THEN SFRIB6A.442
CALL TIMER('SF_RIB ',4) SFRIB6A.443
ENDIF SFRIB6A.444
RETURN SFRIB6A.445
END SFRIB6A.446
SFRIB6A.447
*ENDIF SFRIB6A.448