*IF DEF,FLUXPROC FPSEAIC1.2
C ******************************COPYRIGHT****************************** FPSEAIC1.3
C (c) CROWN COPYRIGHT 1998, METEOROLOGICAL OFFICE, All Rights Reserved. FPSEAIC1.4
C FPSEAIC1.5
C Use, duplication or disclosure of this code is subject to the FPSEAIC1.6
C restrictions as set forth in the contract. FPSEAIC1.7
C FPSEAIC1.8
C Meteorological Office FPSEAIC1.9
C London Road FPSEAIC1.10
C BRACKNELL FPSEAIC1.11
C Berkshire UK FPSEAIC1.12
C RG12 2SZ FPSEAIC1.13
C FPSEAIC1.14
C If no contract has been raised with this copy of the code, the use, FPSEAIC1.15
C duplication or disclosure of it is strictly prohibited. Permission FPSEAIC1.16
C to do so must first be obtained in writing from the Head of Numerical FPSEAIC1.17
C Modelling at the above address. FPSEAIC1.18
C ******************************COPYRIGHT****************************** FPSEAIC1.19
C FPSEAIC1.20
C Programming standard: Unified Model Documentation Paper No 3 FPSEAIC1.21
C Version No 1 15/1/90 FPSEAIC1.22
C History: FPSEAIC1.23
C version date change FPSEAIC1.24
C 4.5 03/09/98 New code FPSEAIC1.25
C FPSEAIC1.26
! Author: M. J. Bell FPSEAIC1.27
!---------------------------------------------------------------------- FPSEAIC1.28
! contains routines: sea_ice FPSEAIC1.29
! FPSEAIC1.30
! Purpose: Flux processing routine. FPSEAIC1.31
! To produce a pp field containing: FPSEAIC1.32
! Snowfall rate FPSEAIC1.33
! Sublimation rate FPSEAIC1.34
! Topmelt FPSEAIC1.35
! Bottom melt FPSEAIC1.36
! for each of the fields required FPSEAIC1.37
!---------------------------------------------------------------------- FPSEAIC1.38
subroutine sea_ice( 1,17FPSEAIC1.39
*CALL AFIELDS 
FPSEAIC1.40
*CALL ARGPPX FPSEAIC1.41
# icode ) FPSEAIC1.42
FPSEAIC1.43
implicit none FPSEAIC1.44
FPSEAIC1.45
! declaration of argument list FPSEAIC1.46
FPSEAIC1.47
! array dimensions, lsms, interpolation coeffs etc. : all intent IN FPSEAIC1.48
*CALL CFIELDS FPSEAIC1.49
FPSEAIC1.50
integer icode ! IN/OUT error code ; > 0 => fatal error detected FPSEAIC1.51
FPSEAIC1.52
! declaration of parameters FPSEAIC1.53
*CALL CSUBMODL FPSEAIC1.54
*CALL CPPXREF FPSEAIC1.55
*CALL PPXLOOK FPSEAIC1.56
*CALL CFDCODES FPSEAIC1.57
*CALL PLOOKUPS FPSEAIC1.58
FPSEAIC1.59
! declaration of globals used FPSEAIC1.60
*CALL CUNITNOS FPSEAIC1.61
*CALL CMESS FPSEAIC1.62
*CALL C_MDI FPSEAIC1.63
*CALL CVALOFF FPSEAIC1.64
*CALL CDEBUG FPSEAIC1.65
*CALL CREFTIM FPSEAIC1.66
*CALL CVALTIM FPSEAIC1.67
FPSEAIC1.68
! declaration of local arrays FPSEAIC1.69
integer Int_Head_drain(Len_IntHd) ! integer part of lookup FPSEAIC1.70
! (drain) FPSEAIC1.71
integer Int_Head_convrain(Len_IntHd)! integer part of lookup FPSEAIC1.72
! (crain) FPSEAIC1.73
integer Int_Head_dsnow(Len_IntHd) ! integer part of lookup FPSEAIC1.74
! (dsnow) FPSEAIC1.75
integer Int_Head_convsnow(Len_IntHd)! integer part of lookup FPSEAIC1.76
! (csnow) FPSEAIC1.77
integer Int_Head_subrate(Len_IntHd)! integer part of lookup FPSEAIC1.78
! (subrate) FPSEAIC1.79
integer Int_Head_topmelt(Len_IntHd)! integer part of lookup FPSEAIC1.80
! (topmelt) FPSEAIC1.81
integer Int_Head_botmelt(Len_IntHd)! integer part of lookup FPSEAIC1.82
! (botmelt) FPSEAIC1.83
real Real_Head_drain(Len_RealHd) ! real part of lookup (drain) FPSEAIC1.84
real Real_Head_convrain(Len_RealHd)! real part of lookup (crain) FPSEAIC1.85
real Real_Head_dsnow(Len_RealHd) ! real part of lookup (dsnow) FPSEAIC1.86
real Real_Head_convsnow(Len_RealHd)! real part of lookup (csnow) FPSEAIC1.87
real Real_Head_subrate(Len_RealHd)! real part of lookup (subrate) FPSEAIC1.88
real Real_Head_topmelt(Len_RealHd)! real part of lookup (topmelt) FPSEAIC1.89
real Real_Head_botmelt(Len_RealHd)! real part of lookup (botmelt) FPSEAIC1.90
real dynamic_rain(ncols, nrowst) ! large scale rain field FPSEAIC1.91
real conv_rain(ncols,nrowst) ! convective rain field FPSEAIC1.92
real dynamic_snow(ncols, nrowst) ! large scale snow field FPSEAIC1.93
real conv_snow(ncols,nrowst) ! convective snow field FPSEAIC1.94
real fieldint(ncols,nrowst) ! intermediate field FPSEAIC1.95
real total_snow_rate(ncols,nrowst)! total snow rate field FPSEAIC1.96
real sublimation_rate(ncols,nrowst) ! sublimation rate FPSEAIC1.97
real topmelt(ncols,nrowst) ! top melt FPSEAIC1.98
real bottommelt(ncols,nrowst) ! bottom melt FPSEAIC1.99
FPSEAIC1.100
! declaration of local scalars FPSEAIC1.101
FPSEAIC1.102
integer ivt ! loop index over validity times FPSEAIC1.103
integer iadd ! loop index over additional times FPSEAIC1.104
integer IVTOffHr ! offset of validity time from reference FPSEAIC1.105
integer IOutUnit ! output unit FPSEAIC1.106
FPSEAIC1.107
logical ldebug ! T => output debugging info (set in 0.) FPSEAIC1.108
logical l_leads ! T => using minleadsfrac FPSEAIC1.109
! F => using minicefrac FPSEAIC1.110
logical lcalcprev ! T => field has already been found for FPSEAIC1.111
! additional time FPSEAIC1.112
FPSEAIC1.113
character * 256 cmessage ! error message FPSEAIC1.114
FPSEAIC1.115
! declaration of externals FPSEAIC1.116
external read_leads_flds, read_accum_flds, write_one_field FPSEAIC1.117
FPSEAIC1.118
!---------------------------------------------------------------------- FPSEAIC1.119
! 0. Preliminaries FPSEAIC1.120
!---------------------------------------------------------------------- FPSEAIC1.121
CSub = 'sea_ice' ! subroutine name for error messages FPSEAIC1.122
FPSEAIC1.123
ldebug = l_sea_ice_dbg ! set by debug input control file FPSEAIC1.124
FPSEAIC1.125
!---------------------------------------------------------------------- FPSEAIC1.126
! 1. start loop over validity times FPSEAIC1.127
!---------------------------------------------------------------------- FPSEAIC1.128
do ivt = 1, NoValidTimes FPSEAIC1.129
FPSEAIC1.130
IVTOffHr = IValidOffHr(ivt) FPSEAIC1.131
IOutUnit = IOutUnitOff(ivt) + UnitSeaIceOut FPSEAIC1.132
FPSEAIC1.133
!---------------------------------------------------------------------- FPSEAIC1.134
! 2. Read in large scale rain amount FPSEAIC1.135
!---------------------------------------------------------------------- FPSEAIC1.136
lcalcprev = .false. FPSEAIC1.137
if ( ivt .gt. 1 ) then FPSEAIC1.138
do iadd = 1,NoAddTimesPreferred FPSEAIC1.139
if ( IVTOffHr .eq. INewOffHrPreferred(iadd) ) then FPSEAIC1.140
lcalcprev = .true. FPSEAIC1.141
endif FPSEAIC1.142
enddo FPSEAIC1.143
endif FPSEAIC1.144
if ( .not. lcalcprev ) then FPSEAIC1.145
call read_accum_flds(StCdrain, IVTOffHr, FPSEAIC1.146
# ldebug, Int_Head_drain, FPSEAIC1.147
# Real_Head_drain, FPSEAIC1.148
# ncols, nrowst, FPSEAIC1.149
# dynamic_rain, FPSEAIC1.150
*CALL ARGPPX FPSEAIC1.151
# icode) FPSEAIC1.152
FPSEAIC1.153
if ( icode .gt. 0 ) then FPSEAIC1.154
write(UnErr,*)CErr,CSub, FPSEAIC1.155
# ' step 2. unable to read dynamic rain' FPSEAIC1.156
icode = 1017 FPSEAIC1.157
go to 9999 FPSEAIC1.158
end if FPSEAIC1.159
!---------------------------------------------------------------------- FPSEAIC1.160
! 3. Read in convective rain field FPSEAIC1.161
!---------------------------------------------------------------------- FPSEAIC1.162
call read_accum_flds(StCconvrain, IVTOffHr, FPSEAIC1.163
# ldebug, Int_Head_convrain, FPSEAIC1.164
# Real_Head_convrain, FPSEAIC1.165
# ncols, nrowst, FPSEAIC1.166
# conv_rain, FPSEAIC1.167
*CALL ARGPPX FPSEAIC1.168
# icode) FPSEAIC1.169
FPSEAIC1.170
if ( icode .gt. 0 ) then FPSEAIC1.171
write(UnErr,*)CErr,CSub, FPSEAIC1.172
# ' step 3. unable to read convective rain' FPSEAIC1.173
icode = 1018 FPSEAIC1.174
go to 9999 FPSEAIC1.175
end if FPSEAIC1.176
!---------------------------------------------------------------------- FPSEAIC1.177
! 4. Start Snowfall Rate Calculation (SNO = DRAIN + CRAIN) FPSEAIC1.178
!---------------------------------------------------------------------- FPSEAIC1.179
call FieldAdd(ncols, nrowst, rmdi, FPSEAIC1.180
# dynamic_rain, conv_rain, FPSEAIC1.181
# total_snow_rate, FPSEAIC1.182
# icode, cmessage) FPSEAIC1.183
!---------------------------------------------------------------------- FPSEAIC1.184
! 5. Read in large scale snow amount FPSEAIC1.185
!---------------------------------------------------------------------- FPSEAIC1.186
call read_accum_flds(StCdsnow, IVTOffHr, FPSEAIC1.187
# ldebug, Int_Head_dsnow, FPSEAIC1.188
# Real_Head_dsnow, FPSEAIC1.189
# ncols, nrowst, FPSEAIC1.190
# dynamic_snow, FPSEAIC1.191
*CALL ARGPPX FPSEAIC1.192
# icode) FPSEAIC1.193
FPSEAIC1.194
if ( icode .gt. 0 ) then FPSEAIC1.195
write(UnErr,*)CErr,CSub, FPSEAIC1.196
# ' step 5. unable to read large scale snow field' FPSEAIC1.197
icode = 1019 FPSEAIC1.198
go to 9999 FPSEAIC1.199
end if FPSEAIC1.200
!---------------------------------------------------------------------- FPSEAIC1.201
! 6. Continue SNO calculation (SNO = SNO + dynamic_snow) FPSEAIC1.202
!---------------------------------------------------------------------- FPSEAIC1.203
call FieldAdd(ncols, nrowst, rmdi, FPSEAIC1.204
# total_snow_rate, dynamic_snow, FPSEAIC1.205
# fieldint, FPSEAIC1.206
# icode, cmessage) FPSEAIC1.207
FPSEAIC1.208
!---------------------------------------------------------------------- FPSEAIC1.209
! 7. Read in convective snow field FPSEAIC1.210
!---------------------------------------------------------------------- FPSEAIC1.211
call read_accum_flds(StCconvsnow, IVTOffHr, FPSEAIC1.212
# ldebug, Int_Head_convsnow, FPSEAIC1.213
# Real_Head_convsnow, FPSEAIC1.214
# ncols, nrowst, FPSEAIC1.215
# conv_snow, FPSEAIC1.216
*CALL ARGPPX FPSEAIC1.217
# icode) FPSEAIC1.218
FPSEAIC1.219
if ( icode .gt. 0 ) then FPSEAIC1.220
write(UnErr,*)CErr,CSub, FPSEAIC1.221
# ' step 7. unable to read convective snow field' FPSEAIC1.222
icode = 1020 FPSEAIC1.223
go to 9999 FPSEAIC1.224
end if FPSEAIC1.225
!---------------------------------------------------------------------- FPSEAIC1.226
! 8. Final SNO calculation (SNO = SNO + conv_snow) FPSEAIC1.227
!---------------------------------------------------------------------- FPSEAIC1.228
call FieldAdd(ncols, nrowst, rmdi, FPSEAIC1.229
# fieldint, conv_snow, FPSEAIC1.230
# total_snow_rate, FPSEAIC1.231
# icode, cmessage) FPSEAIC1.232
!---------------------------------------------------------------------- FPSEAIC1.233
! 9. Write out Total Snow Rate FPSEAIC1.234
!---------------------------------------------------------------------- FPSEAIC1.235
call write_one_field ( FPSEAIC1.236
*CALL AFIELDS FPSEAIC1.237
# OutStCSNO, FFSNO, PPSNO, IVTOffHr, FPSEAIC1.238
# Int_Head_convsnow, Real_Head_convsnow, IOutUnit, FPSEAIC1.239
# ldebug, ITGrid, nrowst, FPSEAIC1.240
# Total_snow_rate, icode) FPSEAIC1.241
if ( icode .gt. 0 ) then FPSEAIC1.242
write(UnErr,*)CErr,CSub, FPSEAIC1.243
# ' step 9. unable to write SNO field' FPSEAIC1.244
icode = 1110 FPSEAIC1.245
go to 9999 FPSEAIC1.246
end if FPSEAIC1.247
else FPSEAIC1.248
call add_hours( FPSEAIC1.249
*CALL AREFTIM FPSEAIC1.250
*CALL AVALTIM FPSEAIC1.251
# IVTOffHr) FPSEAIC1.252
call amend_times ( FPSEAIC1.253
*CALL AVALTIM FPSEAIC1.254
# Int_Head_convsnow,Len_IntHd ) FPSEAIC1.255
call write_one_field ( FPSEAIC1.256
*CALL AFIELDS FPSEAIC1.257
# OutStCSNO, FFSNO, PPSNO, IVTOffHr, FPSEAIC1.258
# Int_Head_convsnow, Real_Head_convsnow, IOutUnit, FPSEAIC1.259
# ldebug, ITGrid, nrowst, FPSEAIC1.260
# Total_snow_rate, icode) FPSEAIC1.261
if ( icode .gt. 0 ) then FPSEAIC1.262
write(UnErr,*)CErr,CSub, FPSEAIC1.263
# ' step 9. unable to write SNO field' FPSEAIC1.264
icode = 1110 FPSEAIC1.265
go to 9999 FPSEAIC1.266
end if FPSEAIC1.267
endif ! .not. lcalcprev FPSEAIC1.268
!---------------------------------------------------------------------- FPSEAIC1.269
! 10. Read in Sublimation Rate FPSEAIC1.270
!---------------------------------------------------------------------- FPSEAIC1.271
l_leads = .false. ! set to use minicefrac FPSEAIC1.272
call read_leads_flds(StCSublim,StCAICE, FPSEAIC1.273
# IVTOffHr, ldebug, FPSEAIC1.274
# l_leads,Int_Head_subrate, FPSEAIC1.275
# Real_Head_subrate, ncols, nrowst, FPSEAIC1.276
# sublimation_rate, FPSEAIC1.277
*CALL ARGPPX FPSEAIC1.278
# icode) FPSEAIC1.279
FPSEAIC1.280
if ( icode .gt. 0 ) then FPSEAIC1.281
write(UnErr,*)CErr,CSub, FPSEAIC1.282
# ' step 10. unable to read sublimation rate' FPSEAIC1.283
icode = 1021 FPSEAIC1.284
go to 9999 FPSEAIC1.285
end if FPSEAIC1.286
!---------------------------------------------------------------------- FPSEAIC1.287
! 11. Write out Sublimation rate FPSEAIC1.288
!---------------------------------------------------------------------- FPSEAIC1.289
call write_one_field ( FPSEAIC1.290
*CALL AFIELDS FPSEAIC1.291
# OutStCSUB, FFSUB, PPSUB, IVTOffHr, FPSEAIC1.292
# Int_Head_subrate, Real_Head_subrate, IOutUnit, FPSEAIC1.293
# ldebug, ITGrid, nrowst, FPSEAIC1.294
# sublimation_rate, icode) FPSEAIC1.295
if ( icode .gt. 0 ) then FPSEAIC1.296
write(UnErr,*)CErr,CSub, FPSEAIC1.297
# ' step 11. unable to write sublimation rate' FPSEAIC1.298
icode = 1111 FPSEAIC1.299
go to 9999 FPSEAIC1.300
end if FPSEAIC1.301
!---------------------------------------------------------------------- FPSEAIC1.302
! 12. Read in Topmelt Rate FPSEAIC1.303
!---------------------------------------------------------------------- FPSEAIC1.304
l_leads = .false. ! set to use minicefrac FPSEAIC1.305
call read_leads_flds(StCTopmelt,StCAICE, FPSEAIC1.306
# IVTOffHr, ldebug, FPSEAIC1.307
# l_leads,Int_Head_topmelt, FPSEAIC1.308
# Real_Head_topmelt, ncols, nrowst, FPSEAIC1.309
# topmelt, FPSEAIC1.310
*CALL ARGPPX FPSEAIC1.311
# icode) FPSEAIC1.312
FPSEAIC1.313
if ( icode .gt. 0 ) then FPSEAIC1.314
write(UnErr,*)CErr,CSub, FPSEAIC1.315
# ' step 12. unable to read topmelt rate' FPSEAIC1.316
icode = 1022 FPSEAIC1.317
go to 9999 FPSEAIC1.318
end if FPSEAIC1.319
FPSEAIC1.320
!---------------------------------------------------------------------- FPSEAIC1.321
! 13. Write out Topmelt rate FPSEAIC1.322
!---------------------------------------------------------------------- FPSEAIC1.323
call write_one_field ( FPSEAIC1.324
*CALL AFIELDS FPSEAIC1.325
# OutStCTOP, FFTOP, PPTOP, IVTOffHr, FPSEAIC1.326
# Int_Head_topmelt, Real_Head_topmelt, IOutUnit, FPSEAIC1.327
# ldebug, ITGrid, nrowst, FPSEAIC1.328
# topmelt, icode) FPSEAIC1.329
if ( icode .gt. 0 ) then FPSEAIC1.330
write(UnErr,*)CErr,CSub, FPSEAIC1.331
# ' step 13. unable to write topmelt rate' FPSEAIC1.332
icode = 1112 FPSEAIC1.333
go to 9999 FPSEAIC1.334
end if FPSEAIC1.335
FPSEAIC1.336
!---------------------------------------------------------------------- FPSEAIC1.337
! 14. Read in Botmelt Rate FPSEAIC1.338
!---------------------------------------------------------------------- FPSEAIC1.339
l_leads = .false. ! set to use minicefrac FPSEAIC1.340
call read_leads_flds(StCBotmelt,StCAICE, FPSEAIC1.341
# IVTOffHr, ldebug, FPSEAIC1.342
# l_leads,Int_Head_botmelt, FPSEAIC1.343
# Real_Head_botmelt, ncols, nrowst, FPSEAIC1.344
# bottommelt, FPSEAIC1.345
*CALL ARGPPX FPSEAIC1.346
# icode) FPSEAIC1.347
FPSEAIC1.348
if ( icode .gt. 0 ) then FPSEAIC1.349
write(UnErr,*)CErr,CSub, FPSEAIC1.350
# ' step 14. unable to read botmelt rate' FPSEAIC1.351
icode = 1023 FPSEAIC1.352
go to 9999 FPSEAIC1.353
end if FPSEAIC1.354
FPSEAIC1.355
!---------------------------------------------------------------------- FPSEAIC1.356
! 15. Write out Botmelt rate FPSEAIC1.357
!---------------------------------------------------------------------- FPSEAIC1.358
call write_one_field ( FPSEAIC1.359
*CALL AFIELDS FPSEAIC1.360
# OutStCBOT, FFBOT, PPBOT, IVTOffHr, FPSEAIC1.361
# Int_Head_botmelt, Real_Head_botmelt, IOutUnit, FPSEAIC1.362
# ldebug, ITGrid, nrowst, FPSEAIC1.363
# bottommelt, icode) FPSEAIC1.364
if ( icode .gt. 0 ) then FPSEAIC1.365
write(UnErr,*)CErr,CSub, FPSEAIC1.366
# ' step 15. unable to write botmelt rate' FPSEAIC1.367
icode = 1113 FPSEAIC1.368
go to 9999 FPSEAIC1.369
end if FPSEAIC1.370
FPSEAIC1.371
!---------------------------------------------------------------------- FPSEAIC1.372
! 16. end loop over validity times FPSEAIC1.373
!---------------------------------------------------------------------- FPSEAIC1.374
enddo ! ivt FPSEAIC1.375
FPSEAIC1.376
9999 continue FPSEAIC1.377
return FPSEAIC1.378
end FPSEAIC1.379
!---------------------------------------------------------------------- FPSEAIC1.380
*ENDIF FPSEAIC1.381