*IF DEF,FLUXPROC FPREFFDS.2
C ******************************COPYRIGHT****************************** FPREFFDS.3
C (c) CROWN COPYRIGHT 1998, METEOROLOGICAL OFFICE, All Rights Reserved. FPREFFDS.4
C FPREFFDS.5
C Use, duplication or disclosure of this code is subject to the FPREFFDS.6
C restrictions as set forth in the contract. FPREFFDS.7
C FPREFFDS.8
C Meteorological Office FPREFFDS.9
C London Road FPREFFDS.10
C BRACKNELL FPREFFDS.11
C Berkshire UK FPREFFDS.12
C RG12 2SZ FPREFFDS.13
C FPREFFDS.14
C If no contract has been raised with this copy of the code, the use, FPREFFDS.15
C duplication or disclosure of it is strictly prohibited. Permission FPREFFDS.16
C to do so must first be obtained in writing from the Head of Numerical FPREFFDS.17
C Modelling at the above address. FPREFFDS.18
C ******************************COPYRIGHT****************************** FPREFFDS.19
C FPREFFDS.20
C Programming standard: Unified Model Documentation Paper No 3 FPREFFDS.21
C Version No 1 15/1/90 FPREFFDS.22
C History: FPREFFDS.23
C version date change FPREFFDS.24
C 4.5 03/09/98 New code FPREFFDS.25
C FPREFFDS.26
! Author: M. J. Bell FPREFFDS.27
!---------------------------------------------------------------------- FPREFFDS.28
! contains routines: reference FPREFFDS.29
! FPREFFDS.30
! Purpose: Flux processing routine. FPREFFDS.31
! To produce a pp file containing: FPREFFDS.32
! Reference Sea Surface temperature FPREFFDS.33
! Reference Sea Surface Salinity FPREFFDS.34
! Reference Ice Depth FPREFFDS.35
! for the times required. FPREFFDS.36
! Change to not output data if climatology FPREFFDS.37
! doesn't exist (S. Spall) FPREFFDS.38
!---------------------------------------------------------------------- FPREFFDS.39
subroutine reference( 1,12FPREFFDS.40
*CALL AFIELDS 
FPREFFDS.41
*CALL ARGPPX FPREFFDS.42
# icode ) FPREFFDS.43
FPREFFDS.44
implicit none FPREFFDS.45
FPREFFDS.46
! declaration of argument list FPREFFDS.47
FPREFFDS.48
! array dimensions, lsms, interpolation coeffs etc. : all intent IN FPREFFDS.49
*CALL CFIELDS FPREFFDS.50
FPREFFDS.51
integer icode ! IN/OUT error code ; > 0 => fatal error detected FPREFFDS.52
FPREFFDS.53
! declaration of parameters FPREFFDS.54
*CALL CSUBMODL FPREFFDS.55
*CALL CPPXREF FPREFFDS.56
*CALL PPXLOOK FPREFFDS.57
*CALL CFDCODES FPREFFDS.58
*CALL PLOOKUPS FPREFFDS.59
FPREFFDS.60
! declaration of globals used FPREFFDS.61
*CALL CLOOKADD FPREFFDS.62
*CALL CUNITNOS FPREFFDS.63
*CALL CMESS FPREFFDS.64
*CALL C_MDI FPREFFDS.65
*CALL CVALOFF FPREFFDS.66
*CALL CDEBUG FPREFFDS.67
*CALL C_0_DG_C FPREFFDS.68
FPREFFDS.69
! declaration of local arrays FPREFFDS.70
integer Int_Head_SST(Len_IntHd) ! integer part of lookup table FPREFFDS.71
integer Int_Head_SSS(Len_IntHd) ! integer part of lookup table FPREFFDS.72
integer Int_Head_HICE(Len_IntHd) ! integer part of lookup table FPREFFDS.73
integer Int_Head_ICEFRAC(Len_IntHd) ! integer part of lookup table FPREFFDS.74
real Real_Head_SST(Len_RealHd) ! real part of lookup table FPREFFDS.75
real Real_Head_SSS(Len_RealHd) ! real part of lookup table FPREFFDS.76
real Real_Head_HICE(Len_RealHd) ! real part of lookup table FPREFFDS.77
real Real_Head_ICEFRAC(Len_RealHd) ! real part of lookup table FPREFFDS.78
real ref_sea_surface_temp(ncols, nrowst) ! ref SST FPREFFDS.79
real ref_sea_surface_salin(ncols, nrowst)! ref SSS FPREFFDS.80
real ref_ice_depth(ncols,nrowst) ! reference ice depth FPREFFDS.81
real ice_depth(ncols,nrowst) ! ice depth FPREFFDS.82
real icefrac(ncols,nrowst) ! ice fraction FPREFFDS.83
FPREFFDS.84
! declaration of local scalars FPREFFDS.85
FPREFFDS.86
integer ivt ! loop index over validity times FPREFFDS.87
integer IVTOffHr ! offset of validity time from reference FPREFFDS.88
integer IOutUnit ! output unit FPREFFDS.89
FPREFFDS.90
logical ldebug ! T => output debugging info (set in 0.) FPREFFDS.91
FPREFFDS.92
real Real_Add_value ! real value to add field (of SSTs) FPREFFDS.93
real salinity_factor ! to convert SSS from g/kg to kg/kg FPREFFDS.94
real salinity_offset ! to take 0.035 from all salinity values FPREFFDS.95
FPREFFDS.96
parameter ( salinity_factor = 0.001 ) FPREFFDS.97
parameter ( salinity_offset = -0.035 ) FPREFFDS.98
FPREFFDS.99
character * 256 cmessage ! error message FPREFFDS.100
FPREFFDS.101
FPREFFDS.102
! declaration of externals FPREFFDS.103
external read_fields, write_one_field FPREFFDS.104
FPREFFDS.105
!---------------------------------------------------------------------- FPREFFDS.106
! 0. Preliminaries FPREFFDS.107
!---------------------------------------------------------------------- FPREFFDS.108
CSub = 'reference' ! subroutine name for error messages FPREFFDS.109
FPREFFDS.110
ldebug = l_references_dbg ! set by debug input control file FPREFFDS.111
FPREFFDS.112
!---------------------------------------------------------------------- FPREFFDS.113
! 1. start loop over validity times FPREFFDS.114
!---------------------------------------------------------------------- FPREFFDS.115
do ivt = 1, NoValidTimes FPREFFDS.116
FPREFFDS.117
IVTOffHr = IValidOffHr(ivt) FPREFFDS.118
IOutUnit = IOutUnitOff(ivt) + UnitReferencesOut FPREFFDS.119
FPREFFDS.120
!---------------------------------------------------------------------- FPREFFDS.121
! 2. read in reference sea surface temperature FPREFFDS.122
!---------------------------------------------------------------------- FPREFFDS.123
call read_fields(StCSST, IVTOffHr, FPREFFDS.124
# ldebug, Int_Head_SST, Real_Head_SST, FPREFFDS.125
# ncols, nrowst, FPREFFDS.126
# ref_sea_surface_temp, FPREFFDS.127
*CALL ARGPPX FPREFFDS.128
# icode) FPREFFDS.129
FPREFFDS.130
if ( icode .gt. 0 ) then FPREFFDS.131
write(UnErr,*)CErr,CSub, FPREFFDS.132
# ' step 2. unable to read reference SST' FPREFFDS.133
icode = 1013 FPREFFDS.134
go to 9999 FPREFFDS.135
end if FPREFFDS.136
FPREFFDS.137
! 2.1 Change field from Kelvin to Celsius FPREFFDS.138
Real_Head_SST(BDATUM - Len_IntHd) = - ZERODEGC FPREFFDS.139
if ( Real_Head_SST(BDATUM - Len_IntHd) .ne. rmdi .and. FPREFFDS.140
# Real_Head_SST(BDATUM - Len_IntHd) .ne. 0.0 ) then FPREFFDS.141
Real_Add_value = Real_Head_SST(BDATUM - Len_IntHd) FPREFFDS.142
call ScalarAdd(ncols, nrowst, rmdi, FPREFFDS.143
# Real_Add_value, FPREFFDS.144
# ref_sea_surface_temp, FPREFFDS.145
# ref_sea_surface_temp, icode, cmessage) FPREFFDS.146
endif FPREFFDS.147
FPREFFDS.148
! 2.2 Reset SSTs less than -1.8 deg C to -1.8 deg C FPREFFDS.149
call set_sst(ncols, nrowst, FPREFFDS.150
# ref_sea_surface_temp, rmdi, FPREFFDS.151
# ref_sea_surface_temp) FPREFFDS.152
FPREFFDS.153
!---------------------------------------------------------------------- FPREFFDS.154
! 3. Write out reference SST FPREFFDS.155
!---------------------------------------------------------------------- FPREFFDS.156
call write_one_field ( FPREFFDS.157
*CALL AFIELDS FPREFFDS.158
# OutStCSST, FFSST, PPSST, IVTOffHr, FPREFFDS.159
# Int_Head_SST, Real_Head_SST, IOutUnit, FPREFFDS.160
# ldebug, ITGrid, nrowst, FPREFFDS.161
# ref_sea_surface_temp, icode) FPREFFDS.162
if ( icode .gt. 0 ) then FPREFFDS.163
write(UnErr,*)CErr,CSub, FPREFFDS.164
# ' step 3. unable to write reference SST' FPREFFDS.165
icode = 1107 FPREFFDS.166
go to 9999 FPREFFDS.167
end if FPREFFDS.168
FPREFFDS.169
!---------------------------------------------------------------------- FPREFFDS.170
! 4. read in reference sea surface salinity from climatology FPREFFDS.171
!---------------------------------------------------------------------- FPREFFDS.172
if (LClimate) then FPREFFDS.173
FPREFFDS.174
! 4.1 read_climate field by calling read_climate field FPREFFDS.175
call read_climate_field(StCSSS, IVTOffHr, FPREFFDS.176
# ldebug, Int_Head_SSS, Real_Head_SSS, FPREFFDS.177
# ncols, nrowst, FPREFFDS.178
# ref_sea_surface_salin, FPREFFDS.179
*CALL ARGPPX FPREFFDS.180
# icode) FPREFFDS.181
FPREFFDS.182
if ( icode .le. 0) then FPREFFDS.183
write(UnStd,*)CStd//CSub//'4. climate field extracted ', FPREFFDS.184
# ' for stash code =', StCSSS, '; IVTOffHr = ', IVTOffHr FPREFFDS.185
else FPREFFDS.186
FPREFFDS.187
write(UnErr,*)CErr//CSub// FPREFFDS.188
# '4. failed to retrieve climate field ', FPREFFDS.189
# ' for stash code =', StCSSS, '; IVTOffHr = ', IVTOffHr FPREFFDS.190
icode = 1014 FPREFFDS.191
goto 9999 FPREFFDS.192
end if FPREFFDS.193
FPREFFDS.194
! 4.2 Convert salinity units from g/kg to kg/kg FPREFFDS.195
call ScalarMult (ncols, nrowst, rmdi, FPREFFDS.196
# salinity_factor, FPREFFDS.197
# ref_sea_surface_salin, FPREFFDS.198
# ref_sea_surface_salin, FPREFFDS.199
# icode, cmessage) FPREFFDS.200
FPREFFDS.201
! 4.3 Subtract 0.035 from each salinity element in field FPREFFDS.202
call ScalarAdd FPREFFDS.203
# (ncols, nrowst, rmdi, FPREFFDS.204
# salinity_offset, ref_sea_surface_salin, FPREFFDS.205
# ref_sea_surface_salin, FPREFFDS.206
# icode, cmessage) FPREFFDS.207
FPREFFDS.208
call write_one_field ( FPREFFDS.209
*CALL AFIELDS FPREFFDS.210
# OutStCSSS, FFSSS, PPSSS, IVTOffHr, FPREFFDS.211
# Int_Head_SSS, Real_Head_SSS, IOutUnit, FPREFFDS.212
# ldebug, ITGrid, nrowst, FPREFFDS.213
# ref_sea_surface_salin, icode) FPREFFDS.214
if ( icode .gt. 0 ) then FPREFFDS.215
write(UnErr,*)CErr,CSub, FPREFFDS.216
# ' step 4. unable to write reference SSS' FPREFFDS.217
icode = 1108 FPREFFDS.218
go to 9999 FPREFFDS.219
end if FPREFFDS.220
FPREFFDS.221
end if ! LClimate FPREFFDS.222
FPREFFDS.223
!---------------------------------------------------------------------- FPREFFDS.224
! 5. read in reference ice depth from climatology FPREFFDS.225
!---------------------------------------------------------------------- FPREFFDS.226
if (LClimate) then FPREFFDS.227
FPREFFDS.228
! 5.1 read_climate field by calling read_climate field FPREFFDS.229
call read_climate_field(StCHICE, IVTOffHr, FPREFFDS.230
# ldebug, Int_Head_HICE, Real_Head_HICE, FPREFFDS.231
# ncols, nrowst, FPREFFDS.232
# ref_ice_depth, FPREFFDS.233
*CALL ARGPPX FPREFFDS.234
# icode) FPREFFDS.235
FPREFFDS.236
if ( icode .le. 0) then FPREFFDS.237
write(UnStd,*)CStd//CSub//'5. climate field extracted ', FPREFFDS.238
# ' for stash code =', StCHICE, '; IVTOffHr = ', IVTOffHr FPREFFDS.239
else FPREFFDS.240
FPREFFDS.241
write(UnErr,*)CErr//CSub// FPREFFDS.242
# '5. failed to retrieve climate field ', FPREFFDS.243
# ' for stash code =', StCHICE, '; IVTOffHr = ', IVTOffHr FPREFFDS.244
icode = 1015 FPREFFDS.245
goto 9999 FPREFFDS.246
end if FPREFFDS.247
FPREFFDS.248
!---------------------------------------------------------------------- FPREFFDS.249
! 6. Read in ice fraction FPREFFDS.250
!---------------------------------------------------------------------- FPREFFDS.251
call read_fields(StCAICE, IVTOffHr, FPREFFDS.252
# ldebug, Int_Head_ICEFRAC, Real_Head_ICEFRAC, FPREFFDS.253
# ncols, nrowst, FPREFFDS.254
# icefrac, FPREFFDS.255
*CALL ARGPPX FPREFFDS.256
# icode) FPREFFDS.257
FPREFFDS.258
if ( icode .le. 0) then FPREFFDS.259
write(UnStd,*)CStd//CSub//'6. ice fraction extracted ', FPREFFDS.260
# ' for stash code =', StCAICE, '; IVTOffHr = ', IVTOffHr FPREFFDS.261
else FPREFFDS.262
FPREFFDS.263
write(UnErr,*)CErr//CSub// FPREFFDS.264
# '6. failed to retrieve ice fraction field ', FPREFFDS.265
# ' for stash code =', StCAICE, '; IVTOffHr = ', IVTOffHr FPREFFDS.266
icode = 1016 FPREFFDS.267
goto 9999 FPREFFDS.268
end if FPREFFDS.269
FPREFFDS.270
!---------------------------------------------------------------------- FPREFFDS.271
! 7. Use FieldMult to calculate HICE FPREFFDS.272
!---------------------------------------------------------------------- FPREFFDS.273
call FieldMult (ncols, nrowst, rmdi, FPREFFDS.274
# ref_ice_depth, icefrac, FPREFFDS.275
# ice_depth, FPREFFDS.276
# icode, cmessage) FPREFFDS.277
!---------------------------------------------------------------------- FPREFFDS.278
! 8. Write out HICE FPREFFDS.279
!---------------------------------------------------------------------- FPREFFDS.280
call write_one_field ( FPREFFDS.281
*CALL AFIELDS FPREFFDS.282
# OutStCHICE, FFHICE, PPHICE, IVTOffHr, FPREFFDS.283
# Int_Head_HICE, Real_Head_HICE, IOutUnit, FPREFFDS.284
# ldebug, ITGrid, nrowst, FPREFFDS.285
# ice_depth, icode) FPREFFDS.286
if ( icode .gt. 0 ) then FPREFFDS.287
write(UnErr,*)CErr,CSub, FPREFFDS.288
# ' step 8. unable to write ice_depth' FPREFFDS.289
icode = 1109 FPREFFDS.290
go to 9999 FPREFFDS.291
end if FPREFFDS.292
FPREFFDS.293
end if ! LClimate FPREFFDS.294
FPREFFDS.295
!---------------------------------------------------------------------- FPREFFDS.296
! 9. end loop over validity times FPREFFDS.297
!---------------------------------------------------------------------- FPREFFDS.298
enddo ! ivt FPREFFDS.299
FPREFFDS.300
9999 continue FPREFFDS.301
return FPREFFDS.302
end FPREFFDS.303
!---------------------------------------------------------------------- FPREFFDS.304
*ENDIF FPREFFDS.305