*IF DEF,A03_6A ACB1F405.11
C *****************************COPYRIGHT****************************** SFMELT5B.3
C (c) CROWN COPYRIGHT 1997, METEOROLOGICAL OFFICE, All Rights Reserved. SFMELT5B.4
C SFMELT5B.5
C Use, duplication or disclosure of this code is subject to the SFMELT5B.6
C restrictions as set forth in the contract. SFMELT5B.7
C SFMELT5B.8
C Meteorological Office SFMELT5B.9
C London Road SFMELT5B.10
C BRACKNELL SFMELT5B.11
C Berkshire UK SFMELT5B.12
C RG12 2SZ SFMELT5B.13
C SFMELT5B.14
C If no contract has been raised with this copy of the code, the use, SFMELT5B.15
C duplication or disclosure of it is strictly prohibited. Permission SFMELT5B.16
C to do so must first be obtained in writing from the Head of Numerical SFMELT5B.17
C Modelling at the above address. SFMELT5B.18
C ******************************COPYRIGHT****************************** SFMELT5B.19
SFMELT5B.20
! SUBROUTINE SF_MELT---------------------------------------------------- SFMELT5B.21
! Purpose : Calculates surface melting (snow and sea-ice) and increments SFMELT5B.22
! in surface fluxes to satisfy energy balance. SFMELT5B.23
! Sub-surface snowmelt is calculated and snowdepth incremented SFMELT5B.24
! by melt and sublimation in P251. SFMELT5B.25
! R.Essery 19/1/95 SFMELT5B.26
! SFMELT5B.27
! SFMELT5B.28
! SFMELT5B.29
! Model Modification history: SFMELT5B.30
! version Date SFMELT5B.31
C 4.5 Jul. 98 Kill the IBM specific lines (JCThil) AJC1F405.66
!----------------------------------------------------------------------- SFMELT5B.32
SUBROUTINE SF_MELT( 3,6SFMELT5B.33
& P_FIELD,P1,N_TYPES,LAND_FIELD,LAND1 SFMELT5B.34
&,POINTS,LAND_MASK,LAND_PTS,LAND_INDEX SFMELT5B.38
&,ALPHA1,ASHTF,ASURF,TILE_FRAC,ICE_FRACT SFMELT5B.40
&,RHOKH1_PRIME,TIMESTEP,SIMLT,SMLT,DFQW,DIFF_SENS_HTF SFMELT5B.41
&,EI,LYING_SNOW,SURF_HT_FLUX,TSTAR_TILE,TI SFMELT5B.42
&,SICE_MLT_HTF,SNOMLT_SURF_HTF,SNOWMELT,LTIMER SFMELT5B.43
&) SFMELT5B.44
SFMELT5B.45
IMPLICIT NONE SFMELT5B.46
SFMELT5B.47
LOGICAL LTIMER SFMELT5B.48
SFMELT5B.49
INTEGER SFMELT5B.50
& P_FIELD ! IN No. of gridpoints in the whole grid. SFMELT5B.51
&,P1 ! IN 1st P-pt in full field to be processed. SFMELT5B.52
&,N_TYPES ! IN max number of tiles per grid-box SFMELT5B.53
&,LAND_FIELD ! IN No. of land points in the whole grid. SFMELT5B.54
&,LAND1 ! IN 1st L-pt in full field to be processed. SFMELT5B.55
&,POINTS ! IN No. of gridpoints to be processed. SFMELT5B.56
&,LAND_PTS ! IN No. of land points to be processed. SFMELT5B.57
SFMELT5B.58
LOGICAL SFMELT5B.59
& LAND_MASK(P_FIELD) ! IN T for land points, F otherwise. SFMELT5B.60
INTEGER SFMELT5B.62
& LAND_INDEX(P_FIELD) ! IN Index of land points on the P-grid. SFMELT5B.63
! The ith element contains the position SFMELT5B.64
! in whole grid of the ith land point. SFMELT5B.65
SFMELT5B.67
REAL SFMELT5B.68
& ALPHA1(P_FIELD,N_TYPES) SFMELT5B.69
! IN Gradient of saturated specific SFMELT5B.70
! humidity with respect to temp. SFMELT5B.71
! between the bottom model layer SFMELT5B.72
! and the surface. SFMELT5B.73
&,ASHTF(P_FIELD) ! IN Forward time weighted coeff. SFMELT5B.74
! to calculate the soil heat flux SFMELT5B.75
! between the surface and top soil SFMELT5B.76
! layer (W/m2/K). SFMELT5B.77
&,ASURF(P_FIELD) ! IN Reciprocal areal heat capacity of SFMELT5B.78
! top soil layer or sea-ice surface SFMELT5B.79
! layer (m2 K / J). SFMELT5B.80
&,ICE_FRACT(P_FIELD) ! IN Fraction of gridbox which is covered SFMELT5B.81
! by sea-ice. SFMELT5B.82
&,RHOKH1_PRIME(P_FIELD,N_TYPES) SFMELT5B.83
! IN Modified forward time-weighted SFMELT5B.84
! transfer coefficient. SFMELT5B.85
&,TILE_FRAC(P_FIELD,N_TYPES) SFMELT5B.86
! IN Fraction of gridbox which is covered SFMELT5B.87
! by a tile. SFMELT5B.88
&,TIMESTEP ! IN Timestep (sec). SFMELT5B.89
SFMELT5B.90
LOGICAL SFMELT5B.91
& SIMLT ! IN STASH flag for sea-ice melting ht flux. SFMELT5B.92
&,SMLT ! IN STASH flag for snow melting ht flux. SFMELT5B.93
SFMELT5B.94
REAL SFMELT5B.95
& DFQW(P_FIELD,N_TYPES)! INOUT Increment to the flux of total SFMELT5B.96
! water. SFMELT5B.97
&,DIFF_SENS_HTF(P_FIELD,N_TYPES) SFMELT5B.98
! INOUT Increment to the sensible heat SFMELT5B.99
! flux (W/m2). SFMELT5B.100
&,EI(P_FIELD,N_TYPES) ! INOUT Sublimation from lying snow or SFMELT5B.101
! sea-ice (Kg/m2/s). SFMELT5B.102
&,LYING_SNOW(P_FIELD) ! INOUT Lying snow (kg/m2). SFMELT5B.103
&,SURF_HT_FLUX(P_FIELD,N_TYPES) SFMELT5B.104
! INOUT Net downward heat flux at surface SFMELT5B.105
! over land or sea-ice fraction of SFMELT5B.106
! gridbox (W/m2). SFMELT5B.107
&,TSTAR_TILE(P_FIELD,N_TYPES) SFMELT5B.108
! INOUT Surface temperature (K). SFMELT5B.109
&,TI(P_FIELD) ! INOUT Sea-ice surface layer temp. (K). SFMELT5B.110
&,SICE_MLT_HTF(P_FIELD)! OUT Heat flux due to melting of sea-ice SFMELT5B.111
! (W/m2). SFMELT5B.112
&,SNOMLT_SURF_HTF(P_FIELD) SFMELT5B.113
! OUT Heat flux due to surface melting SFMELT5B.114
! of snow (W/m2). SFMELT5B.115
&,SNOWMELT(P_FIELD,N_TYPES) SFMELT5B.116
! OUT Surface snowmelt (kg/m2/s). SFMELT5B.117
SFMELT5B.118
*CALL C_0_DG_C 
SFMELT5B.119
*CALL C_LHEAT SFMELT5B.120
*CALL C_R_CP SFMELT5B.121
SFMELT5B.122
REAL SFMELT5B.123
& DMELT ! Temporary in calculations of melting heat fluxes SFMELT5B.124
&,DIFF_EI ! Increment to sublimation. SFMELT5B.125
&,DTSTAR ! Increment to surface temperature. SFMELT5B.126
&,DIFF_SURF_HTF ! Increment to surface heat flux. SFMELT5B.127
&,SNOW_MAX ! Snow available for melting at land points. SFMELT5B.128
&,TSTARMAX ! Maximum gridbox mean surface temperature at sea SFMELT5B.129
! points with ice. SFMELT5B.130
SFMELT5B.131
INTEGER SFMELT5B.132
& I ! Loop counter - full horizontal field. SFMELT5B.133
&,L ! Loop counter - land field. SFMELT5B.134
&,ITILE ! Loop counter - land tiles. SFMELT5B.135
SFMELT5B.136
SFMELT5B.137
IF (LTIMER) THEN SFMELT5B.138
CALL TIMER('SFMELT ',3) SFMELT5B.139
ENDIF SFMELT5B.140
SFMELT5B.141
DO I=P1,P1+POINTS-1 SFMELT5B.142
IF (SIMLT) SICE_MLT_HTF(I) = 0.0 SFMELT5B.143
IF (SMLT) SNOMLT_SURF_HTF(I) = 0.0 SFMELT5B.144
ENDDO SFMELT5B.145
SFMELT5B.146
SFMELT5B.147
!----------------------------------------------------------------------- SFMELT5B.148
! Melt land snow if TSTAR_TILE is greater than TM. SFMELT5B.149
!----------------------------------------------------------------------- SFMELT5B.150
DO ITILE=1,N_TYPES SFMELT5B.151
SFMELT5B.152
CDIR$ IVDEP SFMELT5B.158
! Fujitsu vectorization directive GRB0F405.501
!OCL NOVREC GRB0F405.502
DO L=LAND1,LAND1+LAND_PTS-1 SFMELT5B.159
I = LAND_INDEX(L) SFMELT5B.160
SFMELT5B.162
SFMELT5B.163
SNOW_MAX = MAX(0.0, LYING_SNOW(I) - EI(I,ITILE)*TIMESTEP ) SFMELT5B.164
SFMELT5B.165
IF ( SNOW_MAX.GT.0.0 .AND. TSTAR_TILE(I,ITILE).GT.TM ) THEN SFMELT5B.166
SFMELT5B.167
DMELT = ( CP + LC * ALPHA1(I,ITILE) ) SFMELT5B.168
& * RHOKH1_PRIME(I,ITILE) + ASHTF(I) SFMELT5B.169
SFMELT5B.170
DTSTAR = - MIN ( TSTAR_TILE(I,ITILE) - TM , SFMELT5B.171
& LF * SNOW_MAX / ( TIMESTEP * DMELT ) ) SFMELT5B.172
SFMELT5B.173
DMELT = DMELT + LF * ALPHA1(I,ITILE) * RHOKH1_PRIME(I,ITILE) SFMELT5B.174
SFMELT5B.175
SNOWMELT(I,ITILE) = - DMELT * DTSTAR / LF SFMELT5B.176
SFMELT5B.177
DIFF_SENS_HTF(I,ITILE) = DIFF_SENS_HTF(I,ITILE) + SFMELT5B.178
& CP * RHOKH1_PRIME(I,ITILE) * DTSTAR SFMELT5B.179
SFMELT5B.180
TSTAR_TILE(I,ITILE) = TSTAR_TILE(I,ITILE) + DTSTAR SFMELT5B.181
SFMELT5B.182
DIFF_SURF_HTF = ASHTF(I) * DTSTAR SFMELT5B.183
SFMELT5B.184
SURF_HT_FLUX(I,ITILE) = SURF_HT_FLUX(I,ITILE) + SFMELT5B.185
& DIFF_SURF_HTF SFMELT5B.186
SFMELT5B.187
DIFF_EI = ALPHA1(I,ITILE) * RHOKH1_PRIME(I,ITILE) * DTSTAR SFMELT5B.188
SFMELT5B.189
EI(I,ITILE) = EI(I,ITILE) + DIFF_EI SFMELT5B.190
SFMELT5B.191
DFQW(I,ITILE) = DFQW(I,ITILE) + DIFF_EI SFMELT5B.192
SFMELT5B.193
IF (SMLT) SFMELT5B.194
& SNOMLT_SURF_HTF(I) = SNOMLT_SURF_HTF(I) + SFMELT5B.195
& LF*SNOWMELT(I,ITILE) * TILE_FRAC(I,ITILE) SFMELT5B.196
SFMELT5B.197
SFMELT5B.198
ENDIF SFMELT5B.199
ENDDO ! End of loop over land points SFMELT5B.204
ENDDO ! loop over land tiles SFMELT5B.206
SFMELT5B.207
SFMELT5B.208
SFMELT5B.209
!----------------------------------------------------------------------- SFMELT5B.210
! Melt sea-ice if TSTAR_TILE > TSTARMAX or TI > TM. SFMELT5B.211
!----------------------------------------------------------------------- SFMELT5B.212
DO I=P1,P1+POINTS-1 SFMELT5B.213
IF ( .NOT. LAND_MASK(I) .AND. ICE_FRACT(I) .GT. 0.0 ) THEN SFMELT5B.214
SFMELT5B.215
TSTARMAX = ICE_FRACT(I)*TM + (1.0 - ICE_FRACT(I))*TFS SFMELT5B.216
SFMELT5B.217
IF ( TSTAR_TILE(I,1) .GT. TSTARMAX ) THEN SFMELT5B.218
DTSTAR = TSTARMAX - TSTAR_TILE(I,1) SFMELT5B.219
DMELT = (CP + (LC + LF)*ALPHA1(I,1))*RHOKH1_PRIME(I,1) SFMELT5B.220
& + ASHTF(I) SFMELT5B.221
DIFF_SENS_HTF(I,1) = CP * RHOKH1_PRIME(I,1) * DTSTAR SFMELT5B.222
DIFF_EI = ALPHA1(I,1) * RHOKH1_PRIME(I,1) * DTSTAR SFMELT5B.223
EI(I,1) = EI(I,1) + DIFF_EI SFMELT5B.224
DFQW(I,1) = DFQW(I,1) + DIFF_EI SFMELT5B.225
DIFF_SURF_HTF = ASHTF(I) * DTSTAR SFMELT5B.226
TI(I) =TI(I) + ASURF(I) * TIMESTEP * DIFF_SURF_HTF SFMELT5B.227
TSTAR_TILE(I,1) = TSTARMAX SFMELT5B.228
IF (SIMLT) SICE_MLT_HTF(I) = - DMELT * DTSTAR SFMELT5B.229
SFMELT5B.230
ENDIF !end of TSTAR_TILE > TSTARMAX block SFMELT5B.231
SFMELT5B.232
IF ( TI(I) .GT. TM ) THEN SFMELT5B.233
IF (SIMLT) SICE_MLT_HTF(I) = SICE_MLT_HTF(I) + SFMELT5B.234
& (TI(I) - TM)/(ASURF(I)*TIMESTEP) SFMELT5B.235
TI(I) = TM SFMELT5B.236
ENDIF ! end of TI > TM block SFMELT5B.237
SFMELT5B.238
ENDIF ! Sea-ice points SFMELT5B.239
SFMELT5B.240
ENDDO ! End of loop over p_points SFMELT5B.241
SFMELT5B.242
SFMELT5B.243
IF (LTIMER) THEN SFMELT5B.244
CALL TIMER('SFMELT ',4) SFMELT5B.245
ENDIF SFMELT5B.246
SFMELT5B.247
RETURN SFMELT5B.248
END SFMELT5B.249
*ENDIF SFMELT5B.250