*IF DEF,A03_6A SFRUGH6A.2
C *****************************COPYRIGHT****************************** SFRUGH6A.3
C (c) CROWN COPYRIGHT 1997, METEOROLOGICAL OFFICE, All Rights Reserved. SFRUGH6A.4
C SFRUGH6A.5
C Use, duplication or disclosure of this code is subject to the SFRUGH6A.6
C restrictions as set forth in the contract. SFRUGH6A.7
C SFRUGH6A.8
C Meteorological Office SFRUGH6A.9
C London Road SFRUGH6A.10
C BRACKNELL SFRUGH6A.11
C Berkshire UK SFRUGH6A.12
C RG12 2SZ SFRUGH6A.13
C SFRUGH6A.14
C If no contract has been raised with this copy of the code, the use, SFRUGH6A.15
C duplication or disclosure of it is strictly prohibited. Permission SFRUGH6A.16
C to do so must first be obtained in writing from the Head of Numerical SFRUGH6A.17
C Modelling at the above address. SFRUGH6A.18
C ******************************COPYRIGHT****************************** SFRUGH6A.19
! SFRUGH6A.20
!!! SUBROUTINE SF_ROUGH----------------------------------------------- SFRUGH6A.21
!!! SFRUGH6A.22
!!! Purpose: Calculate roughness lengths, blending height and wind SFRUGH6A.23
!!! profile factor SFRUGH6A.24
!!! SFRUGH6A.25
!!! SJ <- programmerof some or all of previous code changes SFRUGH6A.26
C Modification History: AJC1F405.47
C Version Date Change AJC1F405.48
C 4.5 Jul. 98 Kill the IBM specific lines (JCThil) AJC1F405.49
!!! SFRUGH6A.27
!!!-------------------------------------------------------------------- SFRUGH6A.28
SFRUGH6A.29
! Arguaments -------------------------------------------------------- SFRUGH6A.30
SFRUGH6A.31
SUBROUTINE SF_ROUGH ( 6,4SFRUGH6A.32
& P_FIELD,P_POINTS,LAND_FIELD,LAND_PTS,LAND_MASK,L_LAND,P1,LAND1, SFRUGH6A.33
& LAND_INDEX, SFRUGH6A.35
& L_Z0_OROG,Z1_UV,Z0MSEA,ICE_FRACT, SFRUGH6A.37
& LYING_SNOW,Z0V,SIL_OROG,HO2R2_OROG,RIB,Z0M_EFF,Z0M,Z0H, SFRUGH6A.38
& WIND_PROFILE_FACTOR,H_BLEND_OROG,MIZ_RUF,Z0HS,LTIMER SFRUGH6A.39
& ) SFRUGH6A.40
SFRUGH6A.41
IMPLICIT NONE SFRUGH6A.42
SFRUGH6A.43
INTEGER ! Variables defining grid. SFRUGH6A.44
& P_POINTS ! IN Number of P-grid points to be processed SFRUGH6A.45
&,P_FIELD ! IN Number of points on P-grid. SFRUGH6A.46
&,P1 ! IN First P-point to be processed. SFRUGH6A.47
&,LAND1 ! IN First land point to be processed. SFRUGH6A.48
&,LAND_PTS ! IN Number of land points to be processed. SFRUGH6A.49
&,LAND_FIELD ! IN Number of land points. SFRUGH6A.50
SFRUGH6A.51
&,LAND_INDEX(LAND_FIELD)!IN Index for compressed land point array; SFRUGH6A.53
! i'th element holds position in the FULL SFRUGH6A.54
! field of the ith land pt to be SFRUGH6A.55
! processed SFRUGH6A.56
LOGICAL SFRUGH6A.58
& LAND_MASK(P_FIELD) ! IN .TRUE. for land; .FALSE. elsewhere. F60 SFRUGH6A.59
&,L_LAND ! IN .TRUE. to calculate land points only SFRUGH6A.60
! This saves time when tiling SFRUGH6A.61
&,L_Z0_OROG ! IN .TRUE. to use orographic roughness. SFRUGH6A.62
&,LTIMER ! IN .TRUE. for timer diagnostics SFRUGH6A.63
SFRUGH6A.64
REAL SFRUGH6A.65
& HO2R2_OROG(LAND_FIELD)!IN Peak to trough height of unresolved SFRUGH6A.66
! orography devided by 2SQRT(2) (m). SFRUGH6A.67
&,ICE_FRACT(P_FIELD) ! IN Fraction of gridbox which is sea-ice. SFRUGH6A.68
&,LYING_SNOW(P_FIELD) ! IN Lying snow amount (kg per sq metre). SFRUGH6A.69
&,RIB(P_FIELD) ! IN Bulk Richardson number for lowest layer SFRUGH6A.70
&,SIL_OROG(LAND_FIELD) ! IN Silhouette area of unresolved orography SFRUGH6A.71
! per unit horizontal area SFRUGH6A.72
&,Z0V(P_FIELD) ! IN Vegetative roughness length (m). F6418 SFRUGH6A.73
&,Z1_UV(P_FIELD) ! IN Height of lowest atmospheric level (m). SFRUGH6A.74
SFRUGH6A.75
! Modified (INOUT) variables. SFRUGH6A.76
SFRUGH6A.77
REAL SFRUGH6A.78
& Z0MSEA(P_FIELD) ! INOUT Sea-surface roughness length for SFRUGH6A.79
! momentum (m). F617. SFRUGH6A.80
SFRUGH6A.81
! Output variables. SFRUGH6A.82
SFRUGH6A.83
REAL SFRUGH6A.84
& MIZ_RUF(P_FIELD) ! OUT Surface roughness length for the SFRUGH6A.85
! marginal ice zone at sea-ice points. SFRUGH6A.86
&,H_BLEND_OROG(P_FIELD)!OUT Blending height SFRUGH6A.87
&,WIND_PROFILE_FACTOR(P_FIELD) SFRUGH6A.88
! ! OUT For transforming effective surface SFRUGH6A.89
! transfer coefficients to those excluding SFRUGH6A.90
! form drag. SFRUGH6A.91
&,Z0M_EFF(P_FIELD) ! OUT Effective roughness length for SFRUGH6A.92
! momentum (m) SFRUGH6A.93
&,Z0H(P_FIELD) ! OUT Roughness length for heat and moisture SFRUGH6A.94
&,Z0M(P_FIELD) ! OUT Roughness length for momentum (m). SFRUGH6A.95
&,Z0HS(P_FIELD) ! OUT Roughness length for heat and moisture SFRUGH6A.96
! transport over sea. SFRUGH6A.97
SFRUGH6A.98
! Work Variables SFRUGH6A.99
SFRUGH6A.100
INTEGER SFRUGH6A.101
& I ! Loop counter SFRUGH6A.102
&,L ! Another loop counter - this time for land points SFRUGH6A.103
SFRUGH6A.104
REAL SFRUGH6A.105
& RIB_FN ! Interpolation coefficient for 0 < RIB < RI_CRIT SFRUGH6A.106
&,ZETA1 ! Work space SFRUGH6A.107
&,Z0 ! yet more workspace SFRUGH6A.108
SFRUGH6A.109
! Common parameters SFRUGH6A.110
SFRUGH6A.111
*CALL C_MDI 
SFRUGH6A.112
*CALL C_VKMAN SFRUGH6A.113
*CALL C_ROUGH SFRUGH6A.114
*CALL C_SURF SFRUGH6A.115
SFRUGH6A.116
! Local parameters SFRUGH6A.117
SFRUGH6A.118
REAL H_BLEND_MIN,H_BLEND_MAX SFRUGH6A.119
PARAMETER ( SFRUGH6A.120
& H_BLEND_MIN=0.0 ! Minimun value of blending height SFRUGH6A.121
&,H_BLEND_MAX=1000.0 ! Maximum value of blending height SFRUGH6A.122
& ) SFRUGH6A.123
SFRUGH6A.124
SFRUGH6A.125
EXTERNAL TIMER SFRUGH6A.126
SFRUGH6A.127
!----------------------------------------------------------------------- SFRUGH6A.128
!! 1 Fix roughness lengths for the various surface types. SFRUGH6A.129
!----------------------------------------------------------------------- SFRUGH6A.130
IF (LTIMER) THEN SFRUGH6A.131
CALL TIMER('SF_ROUGH',3) SFRUGH6A.132
ENDIF SFRUGH6A.133
SFRUGH6A.134
IF(.NOT.L_LAND) THEN ! sea points as well as land points SFRUGH6A.135
DO I = P1,P1+P_POINTS-1 SFRUGH6A.136
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SFRUGH6A.137
!! 1.1 Liquid sea. Overwrite sea-ice and land in 3.1.2, 3.1.3. SFRUGH6A.138
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SFRUGH6A.139
Z0M(I) = Z0MSEA(I) ! P243.B5 SFRUGH6A.140
Z0H(I) = Z0HSEA ! " SFRUGH6A.141
Z0M_EFF(I) = Z0MSEA(I) SFRUGH6A.142
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SFRUGH6A.143
!! 1.2 Sea ice: Z0MIZ set on all points for input to FCDCH routine SFRUGH6A.144
!! in CD_MIZ,CH_MIZ calculations. Similarily Z0HSEA SFRUGH6A.145
!! CD_LEAD,CH_LEAD calculations. Z0SICE for CD,CH over sea-ice. SFRUGH6A.146
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SFRUGH6A.147
MIZ_RUF(I) = Z0MIZ SFRUGH6A.148
Z0HS(I) = Z0HSEA SFRUGH6A.149
IF (ICE_FRACT(I).GT.0.0 .AND. .NOT.LAND_MASK(I)) THEN SFRUGH6A.150
Z0M(I) = Z0SICE ! P243.B4 SFRUGH6A.151
Z0H(I) = Z0SICE ! " SFRUGH6A.152
Z0M_EFF(I) = Z0SICE SFRUGH6A.153
ENDIF SFRUGH6A.154
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SFRUGH6A.155
!! 1.2a Specify blending height for all points. Set to minimum value SFRUGH6A.156
!! so that LAMBDA_EFF = LAMBDA over the sea in KMKH. SFRUGH6A.157
!! This avoids having to pass land-sea mask into KMKH. SFRUGH6A.158
!! Also set the wind profile factor to the default value of 1.0 SFRUGH6A.159
!! for non-land points. SFRUGH6A.160
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SFRUGH6A.161
SFRUGH6A.162
H_BLEND_OROG(I) = H_BLEND_MIN SFRUGH6A.163
WIND_PROFILE_FACTOR(I) = 1.0 SFRUGH6A.164
SFRUGH6A.165
ENDDO SFRUGH6A.166
ENDIF ! End of L_LAND block SFRUGH6A.167
SFRUGH6A.168
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SFRUGH6A.169
!! 1.3 Land. Reduce roughness if there is any snow lying. SFRUGH6A.170
!! Eqns P243.B1, B2. SFRUGH6A.171
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SFRUGH6A.172
SFRUGH6A.173
SFRUGH6A.179
CDIR$ IVDEP SFRUGH6A.180
! Fujitsu vectorization directive GRB0F405.517
!OCL NOVREC GRB0F405.518
DO L = LAND1,LAND1+LAND_PTS-1 SFRUGH6A.181
I = LAND_INDEX(L) SFRUGH6A.182
SFRUGH6A.184
! Only reduce non-orographic roughness for land points without permanent SFRUGH6A.185
! snow. SFRUGH6A.186
IF (LYING_SNOW(I) .LT. 5.0E3) THEN SFRUGH6A.187
SFRUGH6A.188
Z0 = Z0V(I) - 4.0E-4 * LYING_SNOW(I) SFRUGH6A.189
ZETA1 = MIN( 5.0E-4 , Z0V(I) ) SFRUGH6A.190
Z0M(I) = MAX( ZETA1 , Z0 ) SFRUGH6A.191
Z0H(I) = MIN( 0.1*Z0V(I) , Z0M(I) ) ARN0F405.1849
ELSE ! for permanent land-ice Z0V is appropriate SFRUGH6A.193
Z0M(I) = Z0V(I) ! P243.B1, based on P243.B2 (2nd case) SFRUGH6A.194
Z0H(I) = Z0V(I) ! " , " " " ( " " ) SFRUGH6A.195
ENDIF SFRUGH6A.196
SFRUGH6A.197
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SFRUGH6A.198
!! 1.4 Orographic roughness. Calculate Z0M_EFF in neutral case. SFRUGH6A.199
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SFRUGH6A.200
IF (L_Z0_OROG) THEN SFRUGH6A.201
SFRUGH6A.202
! Set blending height, effective roughness length and SFRUGH6A.203
! wind profile factor at land points. SFRUGH6A.204
SFRUGH6A.205
H_BLEND_OROG(I) = MAX ( Z1_UV(I) + Z0M(I) , SFRUGH6A.206
& HO2R2_OROG(L) * SQRT(2.0) ) SFRUGH6A.207
H_BLEND_OROG(I) = MIN ( H_BLEND_MAX, H_BLEND_OROG(I) ) SFRUGH6A.208
SFRUGH6A.209
SFRUGH6A.210
! Apply simple stability correction to form drag if RIB is stable SFRUGH6A.211
SFRUGH6A.212
IF (SIL_OROG(L) .EQ. RMDI) THEN SFRUGH6A.213
ZETA1 = 0.0 SFRUGH6A.214
ELSE SFRUGH6A.215
RIB_FN = ( 1.0 - RIB(I) / RI_CRIT ) SFRUGH6A.216
IF (RIB_FN.GT.1.0) RIB_FN = 1.0 SFRUGH6A.217
IF (RIB_FN.LT.0.0) RIB_FN = 0.0 SFRUGH6A.218
ZETA1 = 0.5 * OROG_DRAG_PARAM * SIL_OROG(L) * RIB_FN SFRUGH6A.219
ENDIF SFRUGH6A.220
SFRUGH6A.221
Z0M_EFF(I) = H_BLEND_OROG(I) / EXP ( VKMAN / SQRT ( ZETA1 + SFRUGH6A.222
& (VKMAN / LOG ( H_BLEND_OROG(I) / Z0M(I) ) ) * SFRUGH6A.223
& (VKMAN / LOG ( H_BLEND_OROG(I) / Z0M(I) ) ) ) ) SFRUGH6A.224
SFRUGH6A.225
SFRUGH6A.226
IF (RIB(I).GT.RI_CRIT) Z0M_EFF(I)=Z0M(I) SFRUGH6A.227
SFRUGH6A.228
WIND_PROFILE_FACTOR(I) = LOG( H_BLEND_OROG(I) / Z0M_EFF(I) ) / SFRUGH6A.229
& LOG( H_BLEND_OROG(I) / Z0M(I) ) SFRUGH6A.230
SFRUGH6A.231
ELSE SFRUGH6A.232
! Orographic roughness not represented so leave blending height and SFRUGH6A.233
! wind profile factor at their default values and set effective SFRUGH6A.234
! roughness length to its value based on land type. SFRUGH6A.235
SFRUGH6A.236
Z0M_EFF(I) = Z0M(I) SFRUGH6A.237
ENDIF SFRUGH6A.238
SFRUGH6A.239
ENDDO SFRUGH6A.244
SFRUGH6A.246
IF (LTIMER) THEN SFRUGH6A.247
CALL TIMER('SF_ROUGH',4) SFRUGH6A.248
ENDIF SFRUGH6A.249
SFRUGH6A.250
RETURN SFRUGH6A.251
END SFRUGH6A.252
SFRUGH6A.253
*ENDIF SFRUGH6A.254