*IF DEF,FLUXPROC FPMOIST1.2
C ******************************COPYRIGHT****************************** FPMOIST1.3
C (c) CROWN COPYRIGHT 1998, METEOROLOGICAL OFFICE, All Rights Reserved. FPMOIST1.4
C FPMOIST1.5
C Use, duplication or disclosure of this code is subject to the FPMOIST1.6
C restrictions as set forth in the contract. FPMOIST1.7
C FPMOIST1.8
C Meteorological Office FPMOIST1.9
C London Road FPMOIST1.10
C BRACKNELL FPMOIST1.11
C Berkshire UK FPMOIST1.12
C RG12 2SZ FPMOIST1.13
C FPMOIST1.14
C If no contract has been raised with this copy of the code, the use, FPMOIST1.15
C duplication or disclosure of it is strictly prohibited. Permission FPMOIST1.16
C to do so must first be obtained in writing from the Head of Numerical FPMOIST1.17
C Modelling at the above address. FPMOIST1.18
C ******************************COPYRIGHT****************************** FPMOIST1.19
C FPMOIST1.20
C Programming standard: Unified Model Documentation Paper No 3 FPMOIST1.21
C Version No 1 15/1/90 FPMOIST1.22
C History: FPMOIST1.23
C version date change FPMOIST1.24
C 4.5 03/09/98 New code FPMOIST1.25
C FPMOIST1.26
! Author: M. J. Bell FPMOIST1.27
!---------------------------------------------------------------------- FPMOIST1.28
! contains routines: moisture FPMOIST1.29
! FPMOIST1.30
! Purpose: Flux processing routine. FPMOIST1.31
! To produce a pp file containing: FPMOIST1.32
! Precipitation less evapration :- FPMOIST1.33
! calculated from input rainfall and snowfall fields. FPMOIST1.34
!---------------------------------------------------------------------- FPMOIST1.35
subroutine moisture( 1,13FPMOIST1.36
*CALL AFIELDS 
FPMOIST1.37
*CALL ARGPPX FPMOIST1.38
# icode ) FPMOIST1.39
FPMOIST1.40
implicit none FPMOIST1.41
FPMOIST1.42
! declaration of argument list FPMOIST1.43
FPMOIST1.44
! array dimensions, lsms, interpolation coeffs etc. : all intent IN FPMOIST1.45
*CALL CFIELDS FPMOIST1.46
FPMOIST1.47
integer icode ! IN/OUT error code ; > 0 => fatal error detected FPMOIST1.48
FPMOIST1.49
! declaration of parameters FPMOIST1.50
*CALL CSUBMODL FPMOIST1.51
*CALL CPPXREF FPMOIST1.52
*CALL PPXLOOK FPMOIST1.53
*CALL CFDCODES FPMOIST1.54
*CALL PLOOKUPS FPMOIST1.55
FPMOIST1.56
! declaration of globals used FPMOIST1.57
*CALL CUNITNOS FPMOIST1.58
*CALL CMESS FPMOIST1.59
*CALL C_MDI FPMOIST1.60
*CALL CVALOFF FPMOIST1.61
*CALL CDEBUG FPMOIST1.62
*CALL CREFTIM FPMOIST1.63
*CALL CVALTIM FPMOIST1.64
FPMOIST1.65
! declaration of local arrays FPMOIST1.66
integer Int_Head_evap(Len_IntHd) ! integer part of lookup FPMOIST1.67
! (evap) FPMOIST1.68
integer Int_Head_drain(Len_IntHd) ! integer part of lookup FPMOIST1.69
! (drain) FPMOIST1.70
integer Int_Head_convrain(Len_IntHd)! integer part of lookup FPMOIST1.71
! (crain) FPMOIST1.72
integer Int_Head_dsnow(Len_IntHd) ! integer part of lookup FPMOIST1.73
! (dsnow) FPMOIST1.74
integer Int_Head_convsnow(Len_IntHd)! integer part of lookup FPMOIST1.75
! (csnow) FPMOIST1.76
real Real_Head_evap(Len_RealHd) ! real part of lookup (evap) FPMOIST1.77
real Real_Head_drain(Len_RealHd) ! real part of lookup (drain) FPMOIST1.78
real Real_Head_convrain(Len_RealHd)! real part of lookup (crain) FPMOIST1.79
real Real_Head_dsnow(Len_RealHd) ! real part of lookup (dsnow) FPMOIST1.80
real Real_Head_convsnow(Len_RealHd)! real part of lookup (csnow) FPMOIST1.81
real evaporation(ncols, nrowst) ! evaporation field FPMOIST1.82
real dynamic_rain(ncols, nrowst) ! large scale rain field FPMOIST1.83
real conv_rain(ncols,nrowst) ! convective rain field FPMOIST1.84
real dynamic_snow(ncols, nrowst) ! large scale snow field FPMOIST1.85
real conv_snow(ncols,nrowst) ! convective snow field FPMOIST1.86
real Precip_less_evap(ncols,nrowst)! PLE field FPMOIST1.87
real fieldint(ncols,nrowst) ! intermediate field FPMOIST1.88
FPMOIST1.89
! declaration of local scalars FPMOIST1.90
FPMOIST1.91
integer ivt ! loop index over validity times FPMOIST1.92
integer iadd ! loop index over additional times FPMOIST1.93
integer IVTOffHr ! offset of validity time from reference FPMOIST1.94
integer IOutUnit ! output unit FPMOIST1.95
FPMOIST1.96
logical ldebug ! T => output debugging info (set in 0.) FPMOIST1.97
logical l_leads ! T => using minleadsfrac FPMOIST1.98
! F => using minicefrac FPMOIST1.99
logical lcalcprev ! T => field has already been found for FPMOIST1.100
! additional time FPMOIST1.101
FPMOIST1.102
character * 256 cmessage ! error message FPMOIST1.103
FPMOIST1.104
! declaration of externals FPMOIST1.105
external read_leads_flds, read_accum_flds, write_one_field FPMOIST1.106
FPMOIST1.107
!---------------------------------------------------------------------- FPMOIST1.108
! 0. Preliminaries FPMOIST1.109
!---------------------------------------------------------------------- FPMOIST1.110
CSub = 'moisture' ! subroutine name for error messages FPMOIST1.111
FPMOIST1.112
ldebug = l_moisture_dbg ! set by debug input control file FPMOIST1.113
FPMOIST1.114
!---------------------------------------------------------------------- FPMOIST1.115
! 1. start loop over validity times FPMOIST1.116
!---------------------------------------------------------------------- FPMOIST1.117
do ivt = 1, NoValidTimes FPMOIST1.118
FPMOIST1.119
IVTOffHr = IValidOffHr(ivt) FPMOIST1.120
IOutUnit = IOutUnitOff(ivt) + UnitMoistureOut FPMOIST1.121
FPMOIST1.122
!---------------------------------------------------------------------- FPMOIST1.123
! 2. Read in evaporation field FPMOIST1.124
!---------------------------------------------------------------------- FPMOIST1.125
lcalcprev = .false. FPMOIST1.126
if ( ivt .gt. 1 ) then FPMOIST1.127
do iadd = 1,NoAddTimesPreferred FPMOIST1.128
if ( IVTOffHr .eq. INewOffHrPreferred(iadd) ) then FPMOIST1.129
lcalcprev = .true. FPMOIST1.130
endif FPMOIST1.131
enddo FPMOIST1.132
endif FPMOIST1.133
if ( .not. lcalcprev ) then FPMOIST1.134
l_leads = .true. ! set to true to use minleadsfrac FPMOIST1.135
call read_leads_flds (StCEvaporation,StCAICE, FPMOIST1.136
# IVTOffHr, ldebug, FPMOIST1.137
# l_leads,Int_Head_evap, FPMOIST1.138
# Real_Head_evap, ncols, nrowst, FPMOIST1.139
# evaporation, FPMOIST1.140
*CALL ARGPPX FPMOIST1.141
# icode) FPMOIST1.142
FPMOIST1.143
if ( icode .gt. 0 ) then FPMOIST1.144
write(UnErr,*)CErr,CSub, FPMOIST1.145
# ' step 2. unable to read evaporation field' FPMOIST1.146
icode = 1008 FPMOIST1.147
go to 9999 FPMOIST1.148
end if FPMOIST1.149
FPMOIST1.150
!---------------------------------------------------------------------- FPMOIST1.151
! 3. Read in large scale rain amount FPMOIST1.152
!---------------------------------------------------------------------- FPMOIST1.153
call read_accum_flds(StCdrain, IVTOffHr, FPMOIST1.154
# ldebug, Int_Head_drain, FPMOIST1.155
# Real_Head_drain, FPMOIST1.156
# ncols, nrowst, FPMOIST1.157
# dynamic_rain, FPMOIST1.158
*CALL ARGPPX FPMOIST1.159
# icode) FPMOIST1.160
FPMOIST1.161
if ( icode .gt. 0 ) then FPMOIST1.162
write(UnErr,*)CErr,CSub, FPMOIST1.163
# ' step 3. unable to read dynamic rain' FPMOIST1.164
icode = 1009 FPMOIST1.165
go to 9999 FPMOIST1.166
end if FPMOIST1.167
FPMOIST1.168
!---------------------------------------------------------------------- FPMOIST1.169
! 4. Calculate first part of PLE (dynamic_rain - evaporation) FPMOIST1.170
!---------------------------------------------------------------------- FPMOIST1.171
call FieldSub (ncols, nrowst, rmdi, FPMOIST1.172
# dynamic_rain, evaporation, FPMOIST1.173
# fieldint, FPMOIST1.174
# icode, cmessage) FPMOIST1.175
!---------------------------------------------------------------------- FPMOIST1.176
! 5. Read in covective rain field FPMOIST1.177
!---------------------------------------------------------------------- FPMOIST1.178
call read_accum_flds(StCconvrain, IVTOffHr, FPMOIST1.179
# ldebug, Int_Head_convrain, FPMOIST1.180
# Real_Head_convrain, FPMOIST1.181
# ncols, nrowst, FPMOIST1.182
# conv_rain, FPMOIST1.183
*CALL ARGPPX FPMOIST1.184
# icode) FPMOIST1.185
FPMOIST1.186
if ( icode .gt. 0 ) then FPMOIST1.187
write(UnErr,*)CErr,CSub, FPMOIST1.188
# ' step 5. unable to read convective rain' FPMOIST1.189
icode = 1010 FPMOIST1.190
go to 9999 FPMOIST1.191
end if FPMOIST1.192
FPMOIST1.193
!---------------------------------------------------------------------- FPMOIST1.194
! 6. Continue PLE calculation (PLE = PLE + Conv_Rain) FPMOIST1.195
!---------------------------------------------------------------------- FPMOIST1.196
call FieldAdd(ncols, nrowst, rmdi, FPMOIST1.197
# fieldint, conv_rain, FPMOIST1.198
# Precip_less_evap, FPMOIST1.199
# icode, cmessage) FPMOIST1.200
FPMOIST1.201
!---------------------------------------------------------------------- FPMOIST1.202
! 7. Read in large scale snow amount FPMOIST1.203
!---------------------------------------------------------------------- FPMOIST1.204
call read_accum_flds(StCdsnow, IVTOffHr, FPMOIST1.205
# ldebug, Int_Head_dsnow, FPMOIST1.206
# Real_Head_dsnow, FPMOIST1.207
# ncols, nrowst, FPMOIST1.208
# dynamic_snow, FPMOIST1.209
*CALL ARGPPX FPMOIST1.210
# icode) FPMOIST1.211
FPMOIST1.212
if ( icode .gt. 0 ) then FPMOIST1.213
write(UnErr,*)CErr,CSub, FPMOIST1.214
# ' step 7. unable to read large scale snow field' FPMOIST1.215
icode = 1011 FPMOIST1.216
go to 9999 FPMOIST1.217
end if FPMOIST1.218
FPMOIST1.219
!---------------------------------------------------------------------- FPMOIST1.220
! 8. Continue PLE calculation (PLE = PLE + dynamic_snow) FPMOIST1.221
!---------------------------------------------------------------------- FPMOIST1.222
call FieldAdd(ncols, nrowst, rmdi, FPMOIST1.223
# Precip_less_evap, dynamic_snow, FPMOIST1.224
# fieldint, FPMOIST1.225
# icode, cmessage) FPMOIST1.226
FPMOIST1.227
FPMOIST1.228
!---------------------------------------------------------------------- FPMOIST1.229
! 9. Read in convective snow field FPMOIST1.230
!---------------------------------------------------------------------- FPMOIST1.231
call read_accum_flds(StCconvsnow, IVTOffHr, FPMOIST1.232
# ldebug, Int_Head_convsnow, FPMOIST1.233
# Real_Head_convsnow, FPMOIST1.234
# ncols, nrowst, FPMOIST1.235
# conv_snow, FPMOIST1.236
*CALL ARGPPX FPMOIST1.237
# icode) FPMOIST1.238
FPMOIST1.239
if ( icode .gt. 0 ) then FPMOIST1.240
write(UnErr,*)CErr,CSub, FPMOIST1.241
# ' step 9. unable to read convective snow field' FPMOIST1.242
icode = 1012 FPMOIST1.243
go to 9999 FPMOIST1.244
end if FPMOIST1.245
FPMOIST1.246
!---------------------------------------------------------------------- FPMOIST1.247
! 10. Final PLE calculation (PLE = PLE + conv_snow) FPMOIST1.248
!---------------------------------------------------------------------- FPMOIST1.249
call FieldAdd(ncols, nrowst, rmdi, FPMOIST1.250
# fieldint, conv_snow, FPMOIST1.251
# Precip_less_evap, FPMOIST1.252
# icode, cmessage) FPMOIST1.253
!---------------------------------------------------------------------- FPMOIST1.254
! 11. Write out Precipitation less Evaporation FPMOIST1.255
!---------------------------------------------------------------------- FPMOIST1.256
call write_one_field ( FPMOIST1.257
*CALL AFIELDS FPMOIST1.258
# OutStCPLE, FFPLE, PPPLE, IVTOffHr, FPMOIST1.259
# Int_Head_convsnow, Real_Head_convsnow, IOutUnit, FPMOIST1.260
# ldebug, ITGrid, nrowst, FPMOIST1.261
# Precip_less_evap, icode) FPMOIST1.262
if ( icode .gt. 0 ) then FPMOIST1.263
write(UnErr,*)CErr,CSub, FPMOIST1.264
# ' step 11. unable to write PLE field' FPMOIST1.265
icode = 1106 FPMOIST1.266
go to 9999 FPMOIST1.267
end if FPMOIST1.268
else FPMOIST1.269
call add_hours( FPMOIST1.270
*CALL AREFTIM FPMOIST1.271
*CALL AVALTIM FPMOIST1.272
# IVTOffHr) FPMOIST1.273
call amend_times ( FPMOIST1.274
*CALL AVALTIM FPMOIST1.275
# Int_Head_convsnow,Len_IntHd ) FPMOIST1.276
call write_one_field ( FPMOIST1.277
*CALL AFIELDS FPMOIST1.278
# OutStCPLE, FFPLE, PPPLE, IVTOffHr, FPMOIST1.279
# Int_Head_convsnow, Real_Head_convsnow, IOutUnit, FPMOIST1.280
# ldebug, ITGrid, nrowst, FPMOIST1.281
# Precip_less_evap, icode) FPMOIST1.282
if ( icode .gt. 0 ) then FPMOIST1.283
write(UnErr,*)CErr,CSub, FPMOIST1.284
# ' step 11. unable to write PLE field' FPMOIST1.285
icode = 1106 FPMOIST1.286
go to 9999 FPMOIST1.287
end if FPMOIST1.288
endif ! .not. lcalcprev FPMOIST1.289
!---------------------------------------------------------------------- FPMOIST1.290
! 12. end loop over validity times FPMOIST1.291
!---------------------------------------------------------------------- FPMOIST1.292
enddo ! ivt FPMOIST1.293
FPMOIST1.294
9999 continue FPMOIST1.295
return FPMOIST1.296
end FPMOIST1.297
!---------------------------------------------------------------------- FPMOIST1.298
*ENDIF FPMOIST1.299