*IF DEF,FLUXPROC FPRDFLDS.2
C ******************************COPYRIGHT****************************** FPRDFLDS.3
C (c) CROWN COPYRIGHT 1998, METEOROLOGICAL OFFICE, All Rights Reserved. FPRDFLDS.4
C FPRDFLDS.5
C Use, duplication or disclosure of this code is subject to the FPRDFLDS.6
C restrictions as set forth in the contract. FPRDFLDS.7
C FPRDFLDS.8
C Meteorological Office FPRDFLDS.9
C London Road FPRDFLDS.10
C BRACKNELL FPRDFLDS.11
C Berkshire UK FPRDFLDS.12
C RG12 2SZ FPRDFLDS.13
C FPRDFLDS.14
C If no contract has been raised with this copy of the code, the use, FPRDFLDS.15
C duplication or disclosure of it is strictly prohibited. Permission FPRDFLDS.16
C to do so must first be obtained in writing from the Head of Numerical FPRDFLDS.17
C Modelling at the above address. FPRDFLDS.18
C ******************************COPYRIGHT****************************** FPRDFLDS.19
C FPRDFLDS.20
C Programming standard: Unified Model Documentation Paper No 3 FPRDFLDS.21
C Version No 1 15/1/90 FPRDFLDS.22
C History: FPRDFLDS.23
C version date change FPRDFLDS.24
C 4.5 03/09/98 New code FPRDFLDS.25
C FPRDFLDS.26
! Author: M. J. Bell FPRDFLDS.27
!---------------------------------------------------------------------- FPRDFLDS.28
! contains routines: read_fields FPRDFLDS.29
! FPRDFLDS.30
! Purpose: Flux processing routine. FPRDFLDS.31
! Finds a field according to user's search criteria and FPRDFLDS.32
! returns it and its lookup table by the argument list FPRDFLDS.33
! FPRDFLDS.34
! Uses StCode to read NWP and climate files FPRDFLDS.35
!---------------------------------------------------------------------- FPRDFLDS.36
subroutine read_fields (StCode, IVTOffHr, 3,6FPRDFLDS.37
# ldebug, Int_Head, Real_Head, FPRDFLDS.38
# ncols, nrows, field, FPRDFLDS.39
*CALL ARGPPX 
FPRDFLDS.40
# icode) FPRDFLDS.41
FPRDFLDS.42
implicit none FPRDFLDS.43
FPRDFLDS.44
! declaration of parameters FPRDFLDS.45
*CALL CSUBMODL FPRDFLDS.46
*CALL CPPXREF FPRDFLDS.47
*CALL PPXLOOK FPRDFLDS.48
*CALL CLOOKADD FPRDFLDS.49
*CALL PLOOKUPS FPRDFLDS.50
FPRDFLDS.51
! declaration of argument list FPRDFLDS.52
FPRDFLDS.53
integer StCode ! IN stash code of fields to search for FPRDFLDS.54
FPRDFLDS.55
! Reference date is used with IVTOffHr to define validity FPRDFLDS.56
! time needed FPRDFLDS.57
integer IVTOffHr ! IN offset from validity time in hours FPRDFLDS.58
FPRDFLDS.59
! debug control variable FPRDFLDS.60
logical ldebug ! IN T => output debugging info FPRDFLDS.61
FPRDFLDS.62
! lookup tables FPRDFLDS.63
integer Int_Head(Len_IntHd) ! OUT FPRDFLDS.64
real Real_Head(Len_RealHd) ! OUT FPRDFLDS.65
FPRDFLDS.66
! output field FPRDFLDS.67
integer ncols ! IN number of columns FPRDFLDS.68
integer nrows ! IN number of rows FPRDFLDS.69
real field(ncols,nrows) ! OUT field values FPRDFLDS.70
FPRDFLDS.71
! error code FPRDFLDS.72
integer icode ! IN/OUT error code ; > 0 => fatal error detected FPRDFLDS.73
FPRDFLDS.74
FPRDFLDS.75
! declaration of globals used FPRDFLDS.76
*CALL CUNITNOS FPRDFLDS.77
*CALL CMESS FPRDFLDS.78
FPRDFLDS.79
*CALL CLOOKUPS FPRDFLDS.80
FPRDFLDS.81
*CALL CREFTIM FPRDFLDS.82
*CALL CVALTIM FPRDFLDS.83
FPRDFLDS.84
! declaration of local logical FPRDFLDS.85
FPRDFLDS.86
logical l_climate_field ! Set to false initially FPRDFLDS.87
FPRDFLDS.88
! no local arrays FPRDFLDS.89
FPRDFLDS.90
! declaration of externals FPRDFLDS.91
external add_hours, read_one_field, read_climate_field FPRDFLDS.92
FPRDFLDS.93
!---------------------------------------------------------------------- FPRDFLDS.94
! 0. Preliminaries FPRDFLDS.95
CSub = 'read_fields' ! subroutine name for error messages FPRDFLDS.96
l_climate_field = .false. FPRDFLDS.97
! 1. calculate validity time of NWP data required FPRDFLDS.98
FPRDFLDS.99
call add_hours( FPRDFLDS.100
*CALL AREFTIM FPRDFLDS.101
*CALL AVALTIM FPRDFLDS.102
# IVTOffHr) FPRDFLDS.103
FPRDFLDS.104
!---------------------------------------------------------------------- FPRDFLDS.105
! 2. Extract field from preferred file if available FPRDFLDS.106
!---------------------------------------------------------------------- FPRDFLDS.107
if ( LPreferred ) then FPRDFLDS.108
! 2.1 try to read preferred field FPRDFLDS.109
call read_one_field (UnitPreferred, ITEM_CODE, Stcode, FPRDFLDS.110
*CALL AVALTIM FPRDFLDS.111
# Len_FixHd, FixHdPreferred,Len1_Lookup, FPRDFLDS.112
# Len2_ActualPreferred, LookupPreferred, LookFldNoPreferred, FPRDFLDS.113
# ldebug, l_climate_field, FPRDFLDS.114
# Len_IntHd, Len_RealHd, Int_Head, Real_Head, FPRDFLDS.115
# ncols, nrows, field, FPRDFLDS.116
*CALL ARGPPX FPRDFLDS.117
# icode) FPRDFLDS.118
FPRDFLDS.119
if ( icode .le. 0) then FPRDFLDS.120
FPRDFLDS.121
! 2.2 if successful, issue standard message and exit routine FPRDFLDS.122
write(UnStd,*)CStd//CSub//'NWP preferred field stash code ', FPRDFLDS.123
# StCode, '; IVTOffHr = ', IVTOffHr, ' extracted' FPRDFLDS.124
! 2.2.1 Write times to integer header FPRDFLDS.125
call amend_times ( FPRDFLDS.126
*CALL AVALTIM FPRDFLDS.127
# Int_Head,Len_IntHd ) FPRDFLDS.128
go to 9999 FPRDFLDS.129
else FPRDFLDS.130
FPRDFLDS.131
! 2.3 else write warning message and reset icode FPRDFLDS.132
write(UnWarn,*)CWarn//CSub//'NWP preferred field stash code ', FPRDFLDS.133
# StCode, '; IVTOffHr = ', IVTOffHr, ' not found' FPRDFLDS.134
end if FPRDFLDS.135
icode = 0 ! reset icode FPRDFLDS.136
FPRDFLDS.137
end if ! LPreferred FPRDFLDS.138
FPRDFLDS.139
!---------------------------------------------------------------------- FPRDFLDS.140
! 3. Otherwise extract field from preferred file if available FPRDFLDS.141
!---------------------------------------------------------------------- FPRDFLDS.142
if ( LPrevious ) then FPRDFLDS.143
FPRDFLDS.144
! 3.1 try to read previous field FPRDFLDS.145
call read_one_field (UnitPrevious, ITEM_CODE, Stcode, FPRDFLDS.146
*CALL AVALTIM FPRDFLDS.147
# Len_FixHd, FixHdPrevious,Len1_Lookup, FPRDFLDS.148
# Len2_ActualPrevious, LookupPrevious, LookFldNoPrevious, FPRDFLDS.149
# ldebug, l_climate_field, FPRDFLDS.150
# Len_IntHd, Len_RealHd, Int_Head, Real_Head, FPRDFLDS.151
# ncols, nrows, field, FPRDFLDS.152
*CALL ARGPPX FPRDFLDS.153
# icode) FPRDFLDS.154
FPRDFLDS.155
FPRDFLDS.156
if ( icode .le. 0) then FPRDFLDS.157
FPRDFLDS.158
! 3.2 if successful, issue standard message and exit routine FPRDFLDS.159
write(UnStd,*)CStd//CSub//'NWP previous field stash code ', FPRDFLDS.160
# Stcode, '; IVTOffHr = ', IVTOffHr, ' extracted' FPRDFLDS.161
! 3.2.1 Write times to integer header FPRDFLDS.162
call amend_times ( FPRDFLDS.163
*CALL AVALTIM FPRDFLDS.164
# Int_Head,Len_IntHd ) FPRDFLDS.165
go to 9999 FPRDFLDS.166
else FPRDFLDS.167
FPRDFLDS.168
! 3.3 else write warning message and reset icode FPRDFLDS.169
write(UnWarn,*)CWarn//CSub//'NWP previous field stash code ', FPRDFLDS.170
# StCode, '; IVTOffHr = ', IVTOffHr, ' not found' FPRDFLDS.171
end if FPRDFLDS.172
icode = 0 ! reset icode FPRDFLDS.173
FPRDFLDS.174
end if ! LPrevious FPRDFLDS.175
FPRDFLDS.176
!---------------------------------------------------------------------- FPRDFLDS.177
! 4. Otherwise extract field from climate file if available FPRDFLDS.178
!---------------------------------------------------------------------- FPRDFLDS.179
if ( LClimate ) then FPRDFLDS.180
call read_climate_field(StCode, IVTOffHr, FPRDFLDS.181
# ldebug, Int_Head, Real_Head, FPRDFLDS.182
# ncols, nrows, field, FPRDFLDS.183
*CALL ARGPPX FPRDFLDS.184
# icode) FPRDFLDS.185
FPRDFLDS.186
if ( icode .le. 0) then FPRDFLDS.187
write(UnStd,*)CStd//CSub//'4. climate field extracted ', FPRDFLDS.188
# ' for stash code =', stcode, '; IVTOffHr = ', IVTOffHr FPRDFLDS.189
go to 9999 FPRDFLDS.190
else FPRDFLDS.191
FPRDFLDS.192
write(UnWarn,*)CWarn//CSub// FPRDFLDS.193
# '4. failed to retrieve climate field ', FPRDFLDS.194
# ' for stash code =', stcode, '; IVTOffHr = ', IVTOffHr FPRDFLDS.195
icode = 0 FPRDFLDS.196
endif ! icode FPRDFLDS.197
endif ! LClimate FPRDFLDS.198
FPRDFLDS.199
!---------------------------------------------------------------------- FPRDFLDS.200
! 5. If no data has been successfully extracted return an error code FPRDFLDS.201
!---------------------------------------------------------------------- FPRDFLDS.202
icode = 5 FPRDFLDS.203
write(UnErr,*)CErr//CSub//'5. failed to extract any data', FPRDFLDS.204
# ' for stash code =', stcode, '; IVTOffHr = ', IVTOffHr FPRDFLDS.205
FPRDFLDS.206
9999 continue FPRDFLDS.207
return FPRDFLDS.208
end FPRDFLDS.209
!---------------------------------------------------------------------- FPRDFLDS.210
*ENDIF FPRDFLDS.211