*IF DEF,FLUXPROC FPRD1HDR.2
C ******************************COPYRIGHT****************************** FPRD1HDR.3
C (c) CROWN COPYRIGHT 1998, METEOROLOGICAL OFFICE, All Rights Reserved. FPRD1HDR.4
C FPRD1HDR.5
C Use, duplication or disclosure of this code is subject to the FPRD1HDR.6
C restrictions as set forth in the contract. FPRD1HDR.7
C FPRD1HDR.8
C Meteorological Office FPRD1HDR.9
C London Road FPRD1HDR.10
C BRACKNELL FPRD1HDR.11
C Berkshire UK FPRD1HDR.12
C RG12 2SZ FPRD1HDR.13
C FPRD1HDR.14
C If no contract has been raised with this copy of the code, the use, FPRD1HDR.15
C duplication or disclosure of it is strictly prohibited. Permission FPRD1HDR.16
C to do so must first be obtained in writing from the Head of Numerical FPRD1HDR.17
C Modelling at the above address. FPRD1HDR.18
C ******************************COPYRIGHT****************************** FPRD1HDR.19
C FPRD1HDR.20
C Programming standard: Unified Model Documentation Paper No 3 FPRD1HDR.21
C Version No 1 15/1/90 FPRD1HDR.22
C History: FPRD1HDR.23
C version date change FPRD1HDR.24
C 4.5 03/09/98 New code FPRD1HDR.25
C FPRD1HDR.26
! Author: M. J. Bell FPRD1HDR.27
!---------------------------------------------------------------------- FPRD1HDR.28
! contains routines: read_one_header FPRD1HDR.29
! FPRD1HDR.30
! Purpose: Flux processing routine. FPRD1HDR.31
! Opens and reads fixed header and lookup table of one file FPRD1HDR.32
!---------------------------------------------------------------------- FPRD1HDR.33
subroutine read_one_header ( InUnit, ICode, 6,5FPRD1HDR.34
# Len_FixHd_P, Len1_Lookup_P, Len2_Lookup_P, FPRD1HDR.35
# Len2_Lookup_Actual, FixHd, FPRD1HDR.36
*CALL ARGPPX 
FPRD1HDR.37
# Lookup) FPRD1HDR.38
FPRD1HDR.39
implicit none FPRD1HDR.40
FPRD1HDR.41
! declaration of argument list FPRD1HDR.42
integer InUnit ! IN input unit number FPRD1HDR.43
integer ICode ! IN/OUT error code ; > 0 => fatal error detected FPRD1HDR.44
FPRD1HDR.45
! dimensions used to declare arrays to be read in FPRD1HDR.46
integer Len_FixHd_P ! IN length of fixed header FPRD1HDR.47
integer Len1_Lookup_P ! IN length of first dimension of Lookup FPRD1HDR.48
integer Len2_Lookup_P ! IN max length of 2nd dimension of Lookup FPRD1HDR.49
FPRD1HDR.50
! fixed header and lookup tables: intent OUT FPRD1HDR.51
integer Len2_Lookup_Actual ! OUT actual 2nd dimension of Lookup FPRD1HDR.52
integer FixHd(Len_FixHd_P) ! OUT fixed header FPRD1HDR.53
integer Lookup(Len1_Lookup_P, Len2_Lookup_P) ! OUT lookup tables FPRD1HDR.54
FPRD1HDR.55
! declaration of globals FPRD1HDR.56
*CALL CSUBMODL FPRD1HDR.57
*CALL CPPXREF FPRD1HDR.58
*CALL PPXLOOK FPRD1HDR.59
*CALL CMESS FPRD1HDR.60
*CALL CENVIRON FPRD1HDR.61
FPRD1HDR.62
! declaration of local arrays FPRD1HDR.63
FPRD1HDR.64
! lengths of headers in fields file (local arrays) FPRD1HDR.65
! (this declares LEN1_LOOKUP_OBS, LEN2_LOOKUP_OBS) FPRD1HDR.66
*CALL DUMP_LEN FPRD1HDR.67
FPRD1HDR.68
! declaration of local scalars FPRD1HDR.69
integer Len_data ! length of data in file FPRD1HDR.70
character*256 CMessage ! error messages FPRD1HDR.71
FPRD1HDR.72
external READ_FLH, GET_DIM, setpos, get_lookup FPRD1HDR.73
FPRD1HDR.74
!---------------------------------------------------------------------- FPRD1HDR.75
! 0. Preliminaries FPRD1HDR.76
CSub = 'read_one_header' ! subroutine name for error messages FPRD1HDR.77
CMessage = ' ' FPRD1HDR.78
FPRD1HDR.79
! 1 open file FPRD1HDR.80
call file_open(InUnit, CEnv(InUnit), LEnv(InUnit), 0, 0, icode) FPRD1HDR.81
FPRD1HDR.82
if (icode .gt. 0) then FPRD1HDR.83
write(UnWarn,*)CWarn,CSub, FPRD1HDR.84
# ' step 1. failed to open file with environment name ', FPRD1HDR.85
# CEnv(InUnit) FPRD1HDR.86
icode = 27 FPRD1HDR.87
go to 9999 FPRD1HDR.88
end if FPRD1HDR.89
FPRD1HDR.90
! 2. Read fixed header FPRD1HDR.91
CALL READ_FLH(InUnit,FIXHD,LEN_FIXHD_P,ICODE,CMESSAGE) FPRD1HDR.92
FPRD1HDR.93
if ( icode .gt. 0) then FPRD1HDR.94
write(UnErr,*)CErr,CSub, FPRD1HDR.95
# ' step 2. unable to read fixed header; cmessage is ', FPRD1HDR.96
# cmessage FPRD1HDR.97
icode = 28 FPRD1HDR.98
go to 9999 FPRD1HDR.99
end if FPRD1HDR.100
FPRD1HDR.101
! 3. get dimensions from lookup table, check them and set actual FPRD1HDR.102
! 2nd dimension of lookup table FPRD1HDR.103
FPRD1HDR.104
! 3.0 get dimensions from lookup table FPRD1HDR.105
LEN_FIXHD = LEN_FIXHD_P FPRD1HDR.106
CALL GET_DIM(FIXHD, FPRD1HDR.107
*CALL DUMP_AR2 FPRD1HDR.108
# Len_data) FPRD1HDR.109
FPRD1HDR.110
! 3.1 Set to zero any dimensions of headers which are less than zero FPRD1HDR.111
! (readhead etc. fail if this is not done) FPRD1HDR.112
FPRD1HDR.113
if ( LEN1_COLDEPC .lt. 0) LEN1_COLDEPC = 0 FPRD1HDR.114
if ( LEN2_COLDEPC .lt. 0) LEN2_COLDEPC = 0 FPRD1HDR.115
if ( LEN1_FLDDEPC .lt. 0) LEN1_FLDDEPC = 0 FPRD1HDR.116
if ( LEN2_FLDDEPC .lt. 0) LEN2_FLDDEPC = 0 FPRD1HDR.117
if ( LEN_EXTCNST .lt. 0) LEN_EXTCNST = 0 FPRD1HDR.118
if ( LEN_DUMPHIST .lt. 0) LEN_DUMPHIST = 0 FPRD1HDR.119
if ( LEN_CFI1 .lt. 0) LEN_CFI1 = 0 FPRD1HDR.120
if ( LEN_CFI2 .lt. 0) LEN_CFI2 = 0 FPRD1HDR.121
if ( LEN_CFI3 .lt. 0) LEN_CFI3 = 0 FPRD1HDR.122
FPRD1HDR.123
! 3.2 check lookup 2nd dimensions are not too large FPRD1HDR.124
if ( Len2_Lookup_P .lt. Len2_Lookup_Obs ) then FPRD1HDR.125
write(UnErr,*)CErr,CSub, FPRD1HDR.126
# ' step 3.2 lookup table is not big enough; Len2_Lookup_P = ', FPRD1HDR.127
# Len2_Lookup_P,'; Len2_Lookup = ', Len2_Lookup_Obs FPRD1HDR.128
icode = 29 FPRD1HDR.129
go to 9999 FPRD1HDR.130
end if FPRD1HDR.131
FPRD1HDR.132
! 3.3 check first dimensions of lookup tables match FPRD1HDR.133
if ( Len1_Lookup_P .ne. Len1_Lookup_Obs ) then FPRD1HDR.134
write(UnErr,*)CErr,CSub, FPRD1HDR.135
# ' step 3.3 lookup first dimensions do not match ;', FPRD1HDR.136
# ' Len1_Lookup_P = ', Len1_Lookup_P,'; Len1_Lookup = ', FPRD1HDR.137
# Len1_Lookup_Obs FPRD1HDR.138
icode = 30 FPRD1HDR.139
go to 9999 FPRD1HDR.140
end if FPRD1HDR.141
FPRD1HDR.142
! 3.4 set actual 2nd dimension of lookup table FPRD1HDR.143
Len2_Lookup_Actual = Len2_Lookup_Obs FPRD1HDR.144
FPRD1HDR.145
! 4. set position to start of file to re-read the header FPRD1HDR.146
call setpos(InUnit, 0, icode) FPRD1HDR.147
FPRD1HDR.148
if ( icode .gt. 0) then FPRD1HDR.149
write(UnErr,*)CErr,CSub, FPRD1HDR.150
# ' step 4. setpos failed; icode = ', icode FPRD1HDR.151
icode = 31 FPRD1HDR.152
go to 9999 FPRD1HDR.153
end if FPRD1HDR.154
FPRD1HDR.155
! 5. get the lookup header FPRD1HDR.156
FPRD1HDR.157
call get_lookup(InUnit, icode, FPRD1HDR.158
*CALL DUMP_AR2 FPRD1HDR.159
*CALL ARGPPX FPRD1HDR.160
# Len_data, LOOKUP) FPRD1HDR.161
FPRD1HDR.162
if ( icode .gt. 0) then FPRD1HDR.163
write(UnErr,*)CErr,CSub, FPRD1HDR.164
# ' step 5. failed read lookup table ' FPRD1HDR.165
go to 9999 FPRD1HDR.166
end if FPRD1HDR.167
FPRD1HDR.168
9999 continue FPRD1HDR.169
return FPRD1HDR.170
end FPRD1HDR.171
!---------------------------------------------------------------------- FPRD1HDR.172
*ENDIF FPRD1HDR.173