*IF DEF,FLUXPROC FPPRESS1.2
C ******************************COPYRIGHT****************************** FPPRESS1.3
C (c) CROWN COPYRIGHT 1998, METEOROLOGICAL OFFICE, All Rights Reserved. FPPRESS1.4
C FPPRESS1.5
C Use, duplication or disclosure of this code is subject to the FPPRESS1.6
C restrictions as set forth in the contract. FPPRESS1.7
C FPPRESS1.8
C Meteorological Office FPPRESS1.9
C London Road FPPRESS1.10
C BRACKNELL FPPRESS1.11
C Berkshire UK FPPRESS1.12
C RG12 2SZ FPPRESS1.13
C FPPRESS1.14
C If no contract has been raised with this copy of the code, the use, FPPRESS1.15
C duplication or disclosure of it is strictly prohibited. Permission FPPRESS1.16
C to do so must first be obtained in writing from the Head of Numerical FPPRESS1.17
C Modelling at the above address. FPPRESS1.18
C ******************************COPYRIGHT****************************** FPPRESS1.19
C FPPRESS1.20
C Programming standard: Unified Model Documentation Paper No 3 FPPRESS1.21
C Version No 1 15/1/90 FPPRESS1.22
C History: FPPRESS1.23
C version date change FPPRESS1.24
C 4.5 03/09/98 New code FPPRESS1.25
C FPPRESS1.26
! Author: S. A. Spall FPPRESS1.27
!---------------------------------------------------------------------- FPPRESS1.28
! contains routines: pressure FPPRESS1.29
! FPPRESS1.30
! Purpose: Flux processing routine. FPPRESS1.31
! To produce a pp file containing: FPPRESS1.32
! Sea Surface pressure for the times required FPPRESS1.33
!---------------------------------------------------------------------- FPPRESS1.34
subroutine pressure( 1,2FPPRESS1.35
*CALL AFIELDS 
FPPRESS1.36
*CALL ARGPPX FPPRESS1.37
# icode ) FPPRESS1.38
FPPRESS1.39
implicit none FPPRESS1.40
FPPRESS1.41
! declaration of argument list FPPRESS1.42
FPPRESS1.43
! array dimensions, lsms, interpolation coeffs etc. : all intent IN FPPRESS1.44
*CALL CFIELDS FPPRESS1.45
FPPRESS1.46
integer icode ! IN/OUT error code ; > 0 => fatal error detected FPPRESS1.47
FPPRESS1.48
! declaration of parameters FPPRESS1.49
*CALL CSUBMODL FPPRESS1.50
*CALL CPPXREF FPPRESS1.51
*CALL PPXLOOK FPPRESS1.52
*CALL CFDCODES FPPRESS1.53
*CALL PLOOKUPS FPPRESS1.54
FPPRESS1.55
! declaration of globals used FPPRESS1.56
*CALL CLOOKADD FPPRESS1.57
*CALL CUNITNOS FPPRESS1.58
*CALL CMESS FPPRESS1.59
*CALL C_MDI FPPRESS1.60
*CALL CVALOFF FPPRESS1.61
*CALL CDEBUG FPPRESS1.62
*CALL C_0_DG_C FPPRESS1.63
FPPRESS1.64
! declaration of local arrays FPPRESS1.65
integer Int_Head_SSP(Len_IntHd) ! integer part of lookup table FPPRESS1.66
real Real_Head_SSP(Len_RealHd) ! real part of lookup table FPPRESS1.67
real sea_surface_pressure(ncols, nrowst) ! ref SSP FPPRESS1.68
FPPRESS1.69
! declaration of local scalars FPPRESS1.70
FPPRESS1.71
integer ivt ! loop index over validity times FPPRESS1.72
integer IVTOffHr ! offset of validity time from reference FPPRESS1.73
integer IOutUnit ! output unit FPPRESS1.74
FPPRESS1.75
logical ldebug ! T => output debugging info (set in 0.) FPPRESS1.76
FPPRESS1.77
character * 256 cmessage ! error message FPPRESS1.78
FPPRESS1.79
FPPRESS1.80
! declaration of externals FPPRESS1.81
external read_fields, write_one_field FPPRESS1.82
FPPRESS1.83
!---------------------------------------------------------------------- FPPRESS1.84
! 0. Preliminaries FPPRESS1.85
!---------------------------------------------------------------------- FPPRESS1.86
CSub = 'pressure' ! subroutine name for error messages FPPRESS1.87
FPPRESS1.88
ldebug = l_pressure_dbg ! set by debug input control file FPPRESS1.89
FPPRESS1.90
!---------------------------------------------------------------------- FPPRESS1.91
! 1. start loop over validity times FPPRESS1.92
!---------------------------------------------------------------------- FPPRESS1.93
do ivt = 1, NoValidTimes FPPRESS1.94
FPPRESS1.95
IVTOffHr = IValidOffHr(ivt) FPPRESS1.96
IOutUnit = IOutUnitOff(ivt) + UnitPressureOut FPPRESS1.97
FPPRESS1.98
!---------------------------------------------------------------------- FPPRESS1.99
! 2. read in sea surface pressure FPPRESS1.100
!---------------------------------------------------------------------- FPPRESS1.101
call read_fields(StCSSP, IVTOffHr, FPPRESS1.102
# ldebug, Int_Head_SSP, Real_Head_SSP, FPPRESS1.103
# ncols, nrowst, FPPRESS1.104
# sea_surface_pressure, FPPRESS1.105
*CALL ARGPPX FPPRESS1.106
# icode) FPPRESS1.107
FPPRESS1.108
if ( icode .gt. 0 ) then FPPRESS1.109
write(UnErr,*)CErr,CSub, FPPRESS1.110
# ' step 2. unable to read sea surface pressure' FPPRESS1.111
icode = 1121 FPPRESS1.112
go to 9999 FPPRESS1.113
end if FPPRESS1.114
FPPRESS1.115
!---------------------------------------------------------------------- FPPRESS1.116
! 3. Write out sea surface pressure FPPRESS1.117
!---------------------------------------------------------------------- FPPRESS1.118
call write_one_field ( FPPRESS1.119
*CALL AFIELDS FPPRESS1.120
# OutStCSSP, FFSSP, PPSSP, IVTOffHr, FPPRESS1.121
# Int_Head_SSP, Real_Head_SSP, IOutUnit, FPPRESS1.122
# ldebug, ITGrid, nrowst, FPPRESS1.123
# sea_surface_pressure, icode) FPPRESS1.124
if ( icode .gt. 0 ) then FPPRESS1.125
write(UnErr,*)CErr,CSub, FPPRESS1.126
# ' step 3. unable to write sea surface pressure' FPPRESS1.127
icode = 1122 FPPRESS1.128
go to 9999 FPPRESS1.129
end if FPPRESS1.130
FPPRESS1.131
!---------------------------------------------------------------------- FPPRESS1.132
! 4. end loop over validity times FPPRESS1.133
!---------------------------------------------------------------------- FPPRESS1.134
enddo ! ivt FPPRESS1.135
FPPRESS1.136
9999 continue FPPRESS1.137
return FPPRESS1.138
end FPPRESS1.139
!---------------------------------------------------------------------- FPPRESS1.140
*ENDIF FPPRESS1.141