subroutine heat( 1,12FPHEAT1.37
*CALL AFIELDS 
FPHEAT1.38
*CALL ARGPPX FPHEAT1.39
# icode ) FPHEAT1.40
FPHEAT1.41
implicit none FPHEAT1.42
FPHEAT1.43
! declaration of argument list FPHEAT1.44
FPHEAT1.45
! array dimensions, lsms, interpolation coeffs etc. : all intent IN FPHEAT1.46
*CALL CFIELDS FPHEAT1.47
FPHEAT1.48
integer icode ! IN/OUT error code ; > 0 => fatal error detected FPHEAT1.49
FPHEAT1.50
! declaration of parameters FPHEAT1.51
*CALL CSUBMODL FPHEAT1.52
*CALL CPPXREF FPHEAT1.53
*CALL PPXLOOK FPHEAT1.54
*CALL CFDCODES FPHEAT1.55
*CALL PLOOKUPS FPHEAT1.56
FPHEAT1.57
real lhevap ! latent heat of evaporation FPHEAT1.58
parameter ( lhevap = 2.25E6) FPHEAT1.59
FPHEAT1.60
! declaration of globals used FPHEAT1.61
*CALL CUNITNOS FPHEAT1.62
*CALL C_MDI FPHEAT1.63
*CALL CMESS FPHEAT1.64
*CALL CVALOFF FPHEAT1.65
*CALL CDEBUG FPHEAT1.66
FPHEAT1.67
! declaration of local arrays FPHEAT1.68
integer Int_Head_SW1(Len_IntHd) ! integer part of lookup table FPHEAT1.69
integer Int_Head_SW(Len_IntHd) ! integer part of lookup table FPHEAT1.70
integer Int_Head_LW(Len_IntHd) ! integer part of lookup table FPHEAT1.71
integer Int_Head_EVAP(Len_IntHd) ! integer part of lookup table FPHEAT1.72
integer Int_Head_SH(Len_IntHd) ! integer part of lookup table FPHEAT1.73
real Real_Head_SW1(Len_RealHd) ! real part of lookup table FPHEAT1.74
real Real_Head_SW(Len_RealHd) ! real part of lookup table FPHEAT1.75
real Real_Head_LW(Len_RealHd) ! real part of lookup table FPHEAT1.76
real Real_Head_EVAP(Len_RealHd) ! real part of lookup table FPHEAT1.77
real Real_Head_SH(Len_RealHd) ! real part of lookup table FPHEAT1.78
real SW_radiation_band1(ncols, nrowst)! short wave flux (band 1) FPHEAT1.79
real SW_radiation(ncols, nrowst) ! short wave flux FPHEAT1.80
real LW_radiation(ncols, nrowst) ! long_wave_radiation FPHEAT1.81
real evaporation(ncols, nrowst) ! evaporation FPHEAT1.82
real sensible_heat(ncols, nrowst) ! sensible heat FPHEAT1.83
real latent_heat(ncols,nrowst) ! latent heat FPHEAT1.84
real non_pen_heat(ncols,nrowst) ! net non-penetrating heat FPHEAT1.85
real fieldint(ncols,nrowst) ! intermediate field FPHEAT1.86
! declaration of local scalars FPHEAT1.87
FPHEAT1.88
integer ivt ! loop index over validity times FPHEAT1.89
integer IVTOffHr ! offset of validity time from reference FPHEAT1.90
integer IOutUnit ! output unit FPHEAT1.91
FPHEAT1.92
logical ldebug ! T => output debugging info (set in 0.) FPHEAT1.93
logical l_leads ! T => using minleadsfrac FPHEAT1.94
! F => using minicefrac FPHEAT1.95
FPHEAT1.96
character * 256 cmessage ! error message FPHEAT1.97
FPHEAT1.98
! declaration of externals FPHEAT1.99
external read_leads_flds, write_one_field, FPHEAT1.100
# ScalarMult,FieldSub,FieldAdd FPHEAT1.101
FPHEAT1.102
!---------------------------------------------------------------------- FPHEAT1.103
! 0. Preliminaries FPHEAT1.104
!---------------------------------------------------------------------- FPHEAT1.105
CSub = 'heat' ! subroutine name for error messages FPHEAT1.106
FPHEAT1.107
ldebug = l_heat_dbg ! set by debug input control file FPHEAT1.108
FPHEAT1.109
!---------------------------------------------------------------------- FPHEAT1.110
! 1. start loop over validity times FPHEAT1.111
!---------------------------------------------------------------------- FPHEAT1.112
do ivt = 1, NoValidTimes FPHEAT1.113
FPHEAT1.114
IVTOffHr = IValidOffHr(ivt) FPHEAT1.115
IOutUnit = IOutUnitOff(ivt) + UnitHeatOut FPHEAT1.116
FPHEAT1.117
!---------------------------------------------------------------------- FPHEAT1.118
! 2. Read in net down short wave flux over open sea (band 1) FPHEAT1.119
!---------------------------------------------------------------------- FPHEAT1.120
l_leads = .true. ! set to use minleadsfrac FPHEAT1.121
call read_leads_flds(StCSW1,StCAICE, FPHEAT1.122
# IVTOffHr, ldebug, FPHEAT1.123
# l_leads,Int_Head_SW1, FPHEAT1.124
# Real_Head_SW1, ncols, nrowst, FPHEAT1.125
# SW_radiation_band1, FPHEAT1.126
*CALL ARGPPX FPHEAT1.127
# icode) FPHEAT1.128
FPHEAT1.129
if ( icode .gt. 0 ) then FPHEAT1.130
write(UnErr,*)CErr,CSub, FPHEAT1.131
# ' step 2. unable to read SW Radiation Flux (band 1)' FPHEAT1.132
icode = 1001 FPHEAT1.133
go to 9999 FPHEAT1.134
end if FPHEAT1.135
FPHEAT1.136
! 2.2 Write out solar radiation FPHEAT1.137
call write_one_field ( FPHEAT1.138
*CALL AFIELDS FPHEAT1.139
# OutStCSOL, FFSOL, PPSOL, IVTOffHr, FPHEAT1.140
# Int_Head_SW1, Real_Head_SW1, IOutUnit, FPHEAT1.141
# ldebug, ITGrid, nrowst, FPHEAT1.142
# SW_radiation_band1, icode) FPHEAT1.143
if ( icode .gt. 0 ) then FPHEAT1.144
write(UnErr,*)CErr,CSub, FPHEAT1.145
# ' step 2. unable to write penetrating ' FPHEAT1.146
# ,'solar radiation (SOL)' FPHEAT1.147
icode = 1101 FPHEAT1.148
go to 9999 FPHEAT1.149
end if FPHEAT1.150
FPHEAT1.151
!---------------------------------------------------------------------- FPHEAT1.152
! 3. Read in fields to calculate net non penetrating heat FPHEAT1.153
!---------------------------------------------------------------------- FPHEAT1.154
! 3.1 Read net down short wave readiation FPHEAT1.155
call read_leads_flds(StCSW,StCAICE, FPHEAT1.156
# IVTOffHr, ldebug, FPHEAT1.157
# l_leads,Int_Head_SW, FPHEAT1.158
# Real_Head_SW, ncols, nrowst, FPHEAT1.159
# SW_radiation, FPHEAT1.160
*CALL ARGPPX FPHEAT1.161
# icode) FPHEAT1.162
FPHEAT1.163
if ( icode .gt. 0 ) then FPHEAT1.164
write(UnErr,*)CErr,CSub, FPHEAT1.165
# ' step 3. unable to read SW Radiation Flux' FPHEAT1.166
icode = 1002 FPHEAT1.167
go to 9999 FPHEAT1.168
end if FPHEAT1.169
! 3.2 Use Field Sub to work out first component of HTN FPHEAT1.170
call FieldSub (ncols, nrowst, rmdi, FPHEAT1.171
# SW_radiation, SW_radiation_band1, FPHEAT1.172
# fieldint, FPHEAT1.173
# icode, cmessage) FPHEAT1.174
! 3.3 Read net down long wave flux FPHEAT1.175
call read_leads_flds(StCLongWave,StCAICE, FPHEAT1.176
# IVTOffHr, ldebug, FPHEAT1.177
# l_leads,Int_Head_LW, FPHEAT1.178
# Real_Head_LW, ncols, nrowst, FPHEAT1.179
# LW_radiation, FPHEAT1.180
*CALL ARGPPX FPHEAT1.181
# icode) FPHEAT1.182
FPHEAT1.183
if ( icode .gt. 0 ) then FPHEAT1.184
write(UnErr,*)CErr,CSub, FPHEAT1.185
# ' step 3. unable to read LW Radiation Flux' FPHEAT1.186
icode = 1003 FPHEAT1.187
go to 9999 FPHEAT1.188
end if FPHEAT1.189
FPHEAT1.190
! 3.4 Use FieldAdd to do HTN = fieldint + LW_radiation FPHEAT1.191
call FieldAdd (ncols, nrowst, rmdi, FPHEAT1.192
# fieldint, LW_radiation, FPHEAT1.193
# non_pen_heat, FPHEAT1.194
# icode, cmessage) FPHEAT1.195
FPHEAT1.196
! 3.5 Read evaporation from sea FPHEAT1.197
call read_leads_flds(StCEvaporation,StCAICE, FPHEAT1.198
# IVTOffHr, ldebug, FPHEAT1.199
# l_leads,Int_Head_EVAP, FPHEAT1.200
# Real_Head_EVAP, ncols, nrowst, FPHEAT1.201
# evaporation, FPHEAT1.202
*CALL ARGPPX FPHEAT1.203
# icode) FPHEAT1.204
FPHEAT1.205
if ( icode .gt. 0 ) then FPHEAT1.206
write(UnErr,*)CErr,CSub, FPHEAT1.207
# ' step 3. unable to read evaporation from sea' FPHEAT1.208
icode = 1004 FPHEAT1.209
go to 9999 FPHEAT1.210
end if FPHEAT1.211
FPHEAT1.212
! 3.6 Use ScalarMult and FieldSub to work out latent heat FPHEAT1.213
! and subtract it from HTN FPHEAT1.214
call ScalarMult (ncols, nrowst, rmdi, FPHEAT1.215
# lhevap, evaporation, FPHEAT1.216
# latent_heat, FPHEAT1.217
# icode, cmessage) FPHEAT1.218
call FieldSub (ncols, nrowst, rmdi, FPHEAT1.219
# non_pen_heat, latent_heat, FPHEAT1.220
# fieldint, FPHEAT1.221
# icode, cmessage) FPHEAT1.222
FPHEAT1.223
! 3.7 Read Sensible Heat Flux FPHEAT1.224
call read_leads_flds(StCSensibleHeat,StCAICE, FPHEAT1.225
# IVTOffHr, ldebug, FPHEAT1.226
# l_leads,Int_Head_SH, FPHEAT1.227
# Real_Head_SH, ncols, nrowst, FPHEAT1.228
# sensible_heat, FPHEAT1.229
*CALL ARGPPX FPHEAT1.230
# icode) FPHEAT1.231
FPHEAT1.232
if ( icode .gt. 0 ) then FPHEAT1.233
write(UnErr,*)CErr,CSub, FPHEAT1.234
# ' step 3. unable to read sensible heat flux' FPHEAT1.235
icode = 1005 FPHEAT1.236
go to 9999 FPHEAT1.237
end if FPHEAT1.238
FPHEAT1.239
! 3.8 Use FieldSub to calculate final HTN FPHEAT1.240
call FieldSub (ncols, nrowst, rmdi, FPHEAT1.241
# fieldint, sensible_heat, FPHEAT1.242
# non_pen_heat, FPHEAT1.243
# icode, cmessage) FPHEAT1.244
FPHEAT1.245
! 3.9 Write out net non penetrating heat FPHEAT1.246
call write_one_field ( FPHEAT1.247
*CALL AFIELDS FPHEAT1.248
# OutStCHTN, FFHTN, PPHTN, IVTOffHr, FPHEAT1.249
# Int_Head_SH, Real_Head_SH, IOutUnit, FPHEAT1.250
# ldebug, ITGrid, nrowst, FPHEAT1.251
# non_pen_heat, icode) FPHEAT1.252
if ( icode .gt. 0 ) then FPHEAT1.253
write(UnErr,*)CErr,CSub, FPHEAT1.254
# ' step 3. unable to write net non penetrating heat' FPHEAT1.255
icode = 1102 FPHEAT1.256
go to 9999 FPHEAT1.257
end if FPHEAT1.258
FPHEAT1.259
!---------------------------------------------------------------------- FPHEAT1.260
! 4. end loop over validity times FPHEAT1.261
!---------------------------------------------------------------------- FPHEAT1.262
enddo ! ivt FPHEAT1.263
FPHEAT1.264
9999 continue FPHEAT1.265
return FPHEAT1.266
end FPHEAT1.267
!---------------------------------------------------------------------- FPHEAT1.268
*ENDIF FPHEAT1.269