*IF DEF,C84_1A,OR,DEF,FLDOP UIE3F404.41
C ******************************COPYRIGHT****************************** GTS2F400.7471
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.7472
C GTS2F400.7473
C Use, duplication or disclosure of this code is subject to the GTS2F400.7474
C restrictions as set forth in the contract. GTS2F400.7475
C GTS2F400.7476
C Meteorological Office GTS2F400.7477
C London Road GTS2F400.7478
C BRACKNELL GTS2F400.7479
C Berkshire UK GTS2F400.7480
C RG12 2SZ GTS2F400.7481
C GTS2F400.7482
C If no contract has been raised with this copy of the code, the use, GTS2F400.7483
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.7484
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.7485
C Modelling at the above address. GTS2F400.7486
C ******************************COPYRIGHT****************************** GTS2F400.7487
C GTS2F400.7488
CLL SUBROUTINE PPHEAD------------------------------------------ PPHEAD1A.3
CLL PPHEAD1A.4
CLL Creates a 64 word PP header from the the following:- PPHEAD1A.5
CLL 1) PP_XREF (PP cross-reference array record for this sect/item) PPHEAD1A.6
CLL 2) FIXED length header PPHEAD1A.7
CLL 3) INTEGER constants array PPHEAD1A.8
CLL 4) REAL constants array PPHEAD1A.9
CLL 5) Some input arguments PPHEAD1A.10
CLL PPHEAD1A.11
CLL Tested under compiler CFT77 PPHEAD1A.12
CLL Tested under OS version 5.1 PPHEAD1A.13
CLL PPHEAD1A.14
CLL T.Johns <- programmer of some or all of previous code or changes PPHEAD1A.15
CLL PPHEAD1A.16
CLL Model Modification history from model version 3.0: PPHEAD1A.17
CLL version Date PPHEAD1A.18
CLL 3.2 13/07/93 Changed CHARACTER*(*) to CHARACTER*(80) for TS150793.117
CLL portability. Author Tracey Smith. TS150793.118
CLL 3.2 27/05/93 Code for new real missing data indicator. (TCJ) TJ050593.127
CLL 3.5 05/06/95 Remove PP_XREF from argument list and call GKR0F305.843
CLL EXPPXI instead, for submodels work. K Rogers GKR0F305.844
CLL 4.0 12/09/95 LBUSER(3) [PP_INT_HEAD(LBUSER3)] set to 0. GAB1F400.13
CLL LBCODE set to 31300 + 20 (for Gregorian calendar) GAB1F400.14
CLL or 31300 + 23 (for any other calendar type), if GAB1F400.15
CLL the field is a timeseries. GAB1F400.16
CLL BRLEV, BHRLEV, BULEV[BRSVD1] and BHULEV[BRSVD2] GAB1F400.17
CLL contain lower level boundary and upper level bndry GAB1F400.18
CLL information. Above changes agreed by the WGDUM in GAB1F400.19
CLL first half of 1994. Code for new LBEXP experiment GAB1F400.20
CLL name encoding. Also removed RUN_INDIC_OP from arg GAB1F400.21
CLL list as it is called from CHISTORY (Andy Brady) GAB1F400.22
CLL 4.0 12/10/95 Set Lookup(model_code) to internal model ident. RTHB GRB1F400.92
CLL 4.1 18/04/96 RUN_ID now declared in CHISTORY. RTHBarnes. WRB1F401.693
CLL 4.1 Apr. 96 Rationalise *CALLs S.J.Swarbrick GSS1F401.53
!LL 4.3 14/02/97 Correct bug where ocean models can try to access GPB0F403.26
!LL uninitialised BKH array P.Burton GPB0F403.27
!LL 4.5 14/05/98 Put the correct data type into PP header GPB0F405.100
!LL P.Burton GPB0F405.101
!LL 4.5 14/10/97 Set correct packing type for platform GDG1F405.1
!LL Author D.M. Goddard GDG1F405.2
!LL 4.5 02/09/98 Set Projection No for High Res Global. D. Robinson. GDR8F405.49
CLL PPHEAD1A.19
CLL Programming standard: U M DOC Paper NO. 4, PPHEAD1A.20
CLL PPHEAD1A.21
CLL Logical components covered: D40 PPHEAD1A.22
CLL PPHEAD1A.23
CLL Project TASK: C4 PPHEAD1A.24
CLL PPHEAD1A.25
CLL External documentation C4 PPHEAD1A.26
CLL PPHEAD1A.27
CLLEND------------------------------------------------------------- PPHEAD1A.28
PPHEAD1A.29
C PPHEAD1A.30
C*L INTERFACE and ARGUMENTS:------------------------------------------ PPHEAD1A.31
SUBROUTINE PP_HEAD( 5,9GKR0F305.845
*CALL ARGPPX 
GKR0F305.846
* im_ident,FIXHD,INTHD,REALHD, GKR0F305.847
1 LEN_FIXHD,LEN_INTHD,LEN_REALHD,IE,IS,GR, PPHEAD1A.34
2 lfullfield,LEVEL,pseudo_level, GKR0F305.848
3 samples,start,start_or_verif_time,end_or_data_time,pp_len, PPHEAD1A.36
4 extraw,PP_INT_HEAD,PP_REAL_HEAD,N_COLS_OUT,NUM_WORDS, PPHEAD1A.37
5 LEN_BUF_WORDS,N_ROWS_OUT,NROW_IN,SROW_IN,WCOL_IN,ECOL_IN, PPHEAD1A.38
5 lbproc_comp, PPHEAD1A.39
6 sample_prd,FCST_PRD,COMP_ACCRCY,PACKING_TYPE, GAB1F400.23
7 st_grid,IWA,AK,BK,AKH,BKH,T_levels,LevIndex,ROTATE,ELF, GAB1F400.24
8 OCEAN,OCN_DZ,OCN_KM, PPHEAD1A.42
9 ICODE,CMESSAGE) PPHEAD1A.43
C*---------------------------------------------------------------- PPHEAD1A.44
IMPLICIT NONE PPHEAD1A.45
PPHEAD1A.46
PPHEAD1A.47
CHARACTER*(80) CMESSAGE !OUT OUT MESSAGE FROM ROUTINE TS150793.119
C PPHEAD1A.49
LOGICAL PPHEAD1A.50
* start ! IN flag to control update for verif/start time GO261093.63
*, OCEAN !IN TRUE if processing an ocean diagnostic PPHEAD1A.53
*, lfullfield !IN TRUE if output field on full horiz domain PPHEAD1A.54
C PPHEAD1A.55
INTEGER PPHEAD1A.56
* start_or_verif_time(7) ! IN verif time/start time for means etc PPHEAD1A.57
*, end_or_data_time(7) ! IN data time/end time for means etc PPHEAD1A.58
*, samples ! IN no of samples in period (timeseries) PPHEAD1A.59
C PPHEAD1A.60
INTEGER PPHEAD1A.61
* ICODE !IN Return code from the routine PPHEAD1A.62
*, im_ident !IN Internal model identifier GKR0F305.849
*, PP_LEN !IN Length of the lookup table PPHEAD1A.63
*, LEN_FIXHD !IN Length of the Fixed Length constants PPHEAD1A.64
*, LEN_INTHD !IN Length of the Integer Constants PPHEAD1A.65
*, LEN_REALHD !IN Length of the Real Constants PPHEAD1A.66
*, FIXHD(LEN_FIXHD) !IN Array of Fixed Constants PPHEAD1A.67
*, INTHD(LEN_INTHD) !IN Array of Integer Constants PPHEAD1A.68
*, OCN_KM !IN number of ocean model levels PPHEAD1A.69
C PPHEAD1A.70
INTEGER PPHEAD1A.71
* st_grid !IN STASH horizontal grid type PPHEAD1A.72
*, T_levels !IN No of model Press/Temp levels GAB1F400.25
*, LevIndex !IN level index GAB1F400.26
*, N_ROWS_OUT !IN PPHORIZ_OUT=N_ROWS_OUT*N_COLS_OUT+extra PPHEAD1A.73
*, N_COLS_OUT !IN PPHORIZ_OUT=N_COLS_OUT*N_ROWS_OUT+extra PPHEAD1A.74
*, NROW_IN,SROW_IN !IN The most nrthrly/southerly row. PPHEAD1A.75
*, WCOL_IN,ECOL_IN !IN The most westerly/easterly column PPHEAD1A.76
*, pseudo_level !IN Output PP pseudo-level PPHEAD1A.77
*, NUM_OUT !IN Number of compressed (32 BIT) words PPHEAD1A.78
*, COMP_ACCRCY !IN PACKING ACCURACY IN POWER OF 2 PPHEAD1A.79
*, PACKING_TYPE !IN 0 = No packing, 1 = WGDOS, 3 = GRIB GO261093.64
INTEGER PPHEAD1A.80
* U_ROWS !IN NO OF U,V, ROWS PPHEAD1A.81
*, P_ROWS !IN PRESS/TEMP ROWS PPHEAD1A.82
*, NUM_WORDS !IN Number of 64 Bit words to hold DATA PPHEAD1A.83
&, extraw !IN Number of extra-data words PPHEAD1A.84
*, LEN_BUF_WORDS !IN Number of 64 Bit words (rounded to 512) PPHEAD1A.85
*, IWA !IN Start word address. PPHEAD1A.86
*, IE !IN Item Number PPHEAD1A.87
*, IS !IN Section Number PPHEAD1A.88
*, GR !IN Grid point code PPHEAD1A.89
*, FCST_PRD !IN Forecast period PPHEAD1A.90
*, LBPROC_COMP(14) !IN Subcomponents(0/1) to make up LBPROC PPHEAD1A.92
*, PP_INT_HEAD(PP_LEN) !OUT Integer Lookup table PPHEAD1A.94
C PPHEAD1A.95
REAL PPHEAD1A.96
* PP_REAL_HEAD(PP_LEN)!OUT Real Lookup table PPHEAD1A.97
*, REALHD(LEN_REALHD) !IN Real header PPHEAD1A.98
*, LEVEL !IN Output PP level(REAL) PPHEAD1A.99
*, sample_prd !IN Sampling period in hours for time mean PPHEAD1A.100
*, AK(T_levels) !IN Hybrid coord Ak at full level GAB1F400.27
*, BK(T_levels) !IN Hybrid coord Bk at full level GAB1F400.28
*, AKH(T_levels+1) !IN Hybrid coord Ak at half level GAB1F400.29
*, BKH(T_levels+1) !IN Hybrid coord Bk at half level GAB1F400.30
*, OCN_DZ(OCN_KM) !IN ocean depths at KM levels PPHEAD1A.103
C PPHEAD1A.104
C*--------------------------------------------------------------------- PPHEAD1A.105
*CALL CLOOKADD PPHEAD1A.106
*CALL STPARAM PPHEAD1A.107
*CALL CSUBMODL GKR0F305.850
*CALL CPPXREF PPHEAD1A.108
*CALL PPXLOOK ! Contains *CALL VERSION GSS1F401.54
*CALL C_MDI TJ050593.128
*CALL CHSUNITS GAB1F400.31
*CALL CNTLALL GAB1F400.32
*CALL CHISTORY GAB1F400.33
GKR0F305.853
EXTERNAL EXPPXI GKR0F305.854
EXTERNAL EXPT_ENC GAB1F400.34
GKR0F305.855
C*L WORKSPACE USAGE:------------------------------------------------- PPHEAD1A.109
C DEFINE LOCAL WORKSPACE ARRAYS: None PPHEAD1A.110
C PPHEAD1A.111
C*--------------------------------------------------------------------- PPHEAD1A.112
C DEFINE LOCAL VARIABLES PPHEAD1A.113
REAL PPHEAD1A.114
* ocn_depth ! depth of ocean at level PPHEAD1A.115
*, ocn_depth_h ! depth of ocean at half level GAB1F400.35
INTEGER PPHEAD1A.116
* PP_LBFC ! M08 Level code PPHEAD1A.117
*, PP_LBTYP ! M08 Field type code PPHEAD1A.118
*, PP_LBLEV ! M08 Field level code PPHEAD1A.119
*, PP_IPROJ ! M08 Projection number PPHEAD1A.120
*, PP_LBVC ! Vertical coord type PPHEAD1A.121
*, II ! Local Counter PPHEAD1A.122
*, int_level ! integer value of level PPHEAD1A.123
*, K ! local counter PPHEAD1A.124
*, IA,IB,IC ! Component codes to make up LBTIM PPHEAD1A.125
*, mean_code ! spatial averaging code derived from GR PPHEAD1A.126
*, lvcode ! lv code GKR0F305.856
*, EXPPXI ! Function to extract ppxref info GKR0F305.857
*, EXPTCODE ! integer coded experiment name GAB1F400.36
PPHEAD1A.127
LOGICAL PPHEAD1A.128
* ELF, PPHEAD1A.129
* ROTATE PPHEAD1A.130
C PPHEAD1A.131
CLL Construct PP header PPHEAD1A.132
C PPHEAD1A.133
C Timestamps ---------------------------------------------------------- PPHEAD1A.134
C PPHEAD1A.135
CL PPHEAD1A.136
CL Set up time info dependent on start flag. PPHEAD1A.137
CL For all but time series start will be TRUE so all time information PPHEAD1A.138
CL will be set up from FIXHD in effect, but for time series start PPHEAD1A.139
CL will be set up by TEMPORAL and passed in, so that dump headers are PPHEAD1A.140
CL set correctly for such fields. PPHEAD1A.141
CL Note: end_or_data_time will be updated from current model time in PPHEAD1A.142
CL FIXHD(28-34) for time means/accumulations etc. PPHEAD1A.143
CL PPHEAD1A.144
IF (start) THEN ! start timestep so update start time PPHEAD1A.145
PP_INT_HEAD(LBYR)=start_or_verif_time(1) PPHEAD1A.146
PP_INT_HEAD(LBMON)=start_or_verif_time(2) PPHEAD1A.147
PP_INT_HEAD(LBDAT)=start_or_verif_time(3) PPHEAD1A.148
PP_INT_HEAD(LBHR)=start_or_verif_time(4) PPHEAD1A.149
PP_INT_HEAD(LBMIN)=start_or_verif_time(5) PPHEAD1A.150
PP_INT_HEAD(LBDAY)=start_or_verif_time(7) PPHEAD1A.151
ENDIF PPHEAD1A.152
PP_INT_HEAD(LBYRD)=end_or_data_time(1) PPHEAD1A.153
PP_INT_HEAD(LBMOND)=end_or_data_time(2) PPHEAD1A.154
PP_INT_HEAD(LBDATD)=end_or_data_time(3) PPHEAD1A.155
PP_INT_HEAD(LBHRD)=end_or_data_time(4) PPHEAD1A.156
PP_INT_HEAD(LBMIND)=end_or_data_time(5) PPHEAD1A.157
PP_INT_HEAD(LBDAYD)=end_or_data_time(7) PPHEAD1A.158
C PPHEAD1A.159
C Secondary time information ------------------------------------------ PPHEAD1A.160
C PPHEAD1A.161
C LBTIM is 100*IA+10*IB+IC - this encodes the time processing type PPHEAD1A.162
C PPHEAD1A.163
IA=INT(sample_prd) ! Sampling period in whole hours PPHEAD1A.164
IF(sample_prd.eq.0.0) THEN ! NB: may be a fraction of an hour PPHEAD1A.165
IB=1 ! Forecast field PPHEAD1A.166
ELSE PPHEAD1A.167
IF (IA.EQ.0) THEN PPHEAD1A.168
IA=1 ! 0 < sample_prd < 1 counts as 1 hour PPHEAD1A.169
ENDIF PPHEAD1A.170
IB=2 ! Time mean or accumulation PPHEAD1A.171
ENDIF PPHEAD1A.172
IC=FIXHD(8) ! Calendar (1: Gregorian, 2: 360 day) PPHEAD1A.173
C PPHEAD1A.174
PP_INT_HEAD(LBTIM)=100*IA+10*IB+IC PPHEAD1A.175
PP_INT_HEAD(LBFT)=FCST_PRD PPHEAD1A.176
C PPHEAD1A.177
C Data length --------------------------------------------------------- PPHEAD1A.178
C PPHEAD1A.179
PP_INT_HEAD(LBLREC)=NUM_WORDS PPHEAD1A.180
C PPHEAD1A.181
C Grid code (determined from dump fixed-length header) ---------------- PPHEAD1A.182
C PPHEAD1A.183
IF (samples.EQ.0) THEN GAB1F400.40
C Field is not a timeseries GAB1F400.41
IF(FIXHD(4).LT.100) THEN GAB1F400.42
PP_INT_HEAD(LBCODE)=1 ! Regular lat/long grid GAB1F400.43
ELSE GAB1F400.44
PP_INT_HEAD(LBCODE)=101 ! lat/long grid non-std polar axis GAB1F400.45
ENDIF GAB1F400.46
ELSE PPHEAD1A.186
C Field is a timeseries GAB1F400.47
PP_INT_HEAD(LBCODE)=31300 GAB1F400.48
IF (FIXHD(8).EQ.1) THEN GAB1F400.49
C Calendar -- 1: Gregorian GAB1F400.50
PP_INT_HEAD(LBCODE)=PP_INT_HEAD(LBCODE)+20 GAB1F400.51
ELSEIF (FIXHD(8).EQ.2) THEN GAB1F400.52
C Calendar -- 360 day (Model Calendar) GAB1F400.53
PP_INT_HEAD(LBCODE)=PP_INT_HEAD(LBCODE)+23 GAB1F400.54
ELSE GAB1F400.55
C Unknown calendar. Fail. GAB1F400.56
ICODE=2 GAB1F400.57
CMESSAGE='PPHEAD: unknown calender type in fixhd(8)' GJC0F405.35
ENDIF GAB1F400.59
ENDIF PPHEAD1A.188
C PPHEAD1A.189
C Hemispheric subregion indicator ------------------------------------- PPHEAD1A.190
C PPHEAD1A.191
IF (samples.GT.0 .OR. .NOT.lfullfield) THEN PPHEAD1A.192
C Field is a timeseries/trajectory or subdomain of the full model area PPHEAD1A.193
PP_INT_HEAD(LBHEM)=3 PPHEAD1A.194
ELSEIF (FIXHD(4).LT.100) THEN PPHEAD1A.195
C Otherwise, use the value for the full model area encoded in the dump PPHEAD1A.196
PP_INT_HEAD(LBHEM)=FIXHD(4) PPHEAD1A.197
ELSE PPHEAD1A.198
PP_INT_HEAD(LBHEM)=FIXHD(4)-100 PPHEAD1A.199
ENDIF PPHEAD1A.200
C PPHEAD1A.201
C Field dimensions (rows x cols) -------------------------------------- PPHEAD1A.202
C PPHEAD1A.203
PP_INT_HEAD(LBROW)=N_ROWS_OUT PPHEAD1A.204
PP_INT_HEAD(LBNPT)=N_COLS_OUT PPHEAD1A.205
C PPHEAD1A.206
C 'Extra data' length (now accomodates timeseries sampling data) ------ PPHEAD1A.207
C PPHEAD1A.208
PP_INT_HEAD(LBEXT)=extraw PPHEAD1A.209
C PPHEAD1A.210
C Packing method indicator (new definition introduced at vn2.8)-------- PPHEAD1A.211
*IF DEF,CRAY,AND,DEF,T3E GDG1F405.3
IF(PACKING_TYPE.EQ.1)THEN ! WGDOS packing GDG1F405.4
PP_INT_HEAD(LBPACK)=03001 GDG1F405.5
ELSEIF(PACKING_TYPE.EQ.3)THEN ! GRIB packing GDG1F405.6
PP_INT_HEAD(LBPACK)=04003 GDG1F405.7
ELSEIF(PACKING_TYPE.EQ.0)THEN ! No packing GDG1F405.8
PP_INT_HEAD(LBPACK)=03000 GDG1F405.9
ELSE GDG1F405.10
ICODE=1 GDG1F405.11
CMESSAGE='PPHEAD Packing type undefined' GDG1F405.12
PP_INT_HEAD(LBPACK)=03000 GDG1F405.13
ENDIF GDG1F405.14
*ENDIF GDG1F405.15
*IF DEF,CRAY,AND,-DEF,T3E GDG1F405.16
IF(PACKING_TYPE.EQ.1)THEN ! WGDOS packing GDG1F405.17
PP_INT_HEAD(LBPACK)=02001 GDG1F405.18
ELSEIF(PACKING_TYPE.EQ.3)THEN ! GRIB packing GDG1F405.19
PP_INT_HEAD(LBPACK)=04003 GDG1F405.20
ELSEIF(PACKING_TYPE.EQ.0)THEN ! No packing GDG1F405.21
PP_INT_HEAD(LBPACK)=02000 GDG1F405.22
ELSE GDG1F405.23
ICODE=1 GDG1F405.24
CMESSAGE='PPHEAD Packing type undefined' GDG1F405.25
PP_INT_HEAD(LBPACK)=02000 GDG1F405.26
ENDIF GDG1F405.27
*ENDIF GDG1F405.28
*IF -DEF,CRAY PXPPHEAD.1
IF(PACKING_TYPE.EQ.1)THEN ! WGDOS packing GDG1F405.30
PP_INT_HEAD(LBPACK)=00001 GDG1F405.31
ELSEIF(PACKING_TYPE.EQ.3)THEN ! GRIB packing GDG1F405.32
PP_INT_HEAD(LBPACK)=00003 GDG1F405.33
ELSEIF(PACKING_TYPE.EQ.0)THEN ! No packing GDG1F405.34
PP_INT_HEAD(LBPACK)=00000 GDG1F405.35
ELSE GDG1F405.36
ICODE=1 GDG1F405.37
CMESSAGE='PPHEAD Packing type undefined' GDG1F405.38
PP_INT_HEAD(LBPACK)=00000 GDG1F405.39
ENDIF GDG1F405.40
*ENDIF GDG1F405.41
C PPHEAD1A.219
C PP header release no ------------------------------------------------ PPHEAD1A.220
C PPHEAD1A.221
PP_INT_HEAD(LBREL)=2 PPHEAD1A.222
C PPHEAD1A.223
C Primary fieldcode (some hardwiring for ELF winds) ------------------- PPHEAD1A.224
C Secondary fieldcode not used currently PPHEAD1A.225
C PPHEAD1A.226
PP_LBFC=EXPPXI(im_ident, is, ie, ppx_field_code, GKR0F305.858
*CALL ARGPPX GKR0F305.859
& icode, cmessage) GKR0F305.860
IF(ELF.AND..NOT.ROTATE) THEN ! ELF winds are in x,y direction PPHEAD1A.228
IF(PP_LBFC.EQ.56) PP_LBFC=48 PPHEAD1A.229
IF(PP_LBFC.EQ.57) PP_LBFC=49 PPHEAD1A.230
ENDIF PPHEAD1A.231
PP_INT_HEAD(LBFC)=PP_LBFC PPHEAD1A.232
PP_INT_HEAD(LBCFC)=0 PPHEAD1A.233
C PPHEAD1A.234
C Processing code (encodes several things in one field) --------------- PPHEAD1A.235
C PPHEAD1A.236
PP_INT_HEAD(LBPROC)=0 PPHEAD1A.237
DO II=14,1,-1 PPHEAD1A.238
PP_INT_HEAD(LBPROC)=PP_INT_HEAD(LBPROC)*2+LBPROC_COMP(II) PPHEAD1A.239
ENDDO PPHEAD1A.240
C PPHEAD1A.241
C Vertical coordinate type -------------------------------------------- PPHEAD1A.242
C Vertical coordinate type for reference level not coded PPHEAD1A.243
C PPHEAD1A.244
PP_LBVC=EXPPXI(im_ident, is, ie, ppx_lbvc_code, GKR0F305.861
*CALL ARGPPX GKR0F305.862
& icode, cmessage) GKR0F305.863
PP_INT_HEAD(LBVC)=PP_LBVC PPHEAD1A.246
PP_INT_HEAD(LBRVC)=0 PPHEAD1A.247
C PPHEAD1A.248
C Experiment number coded from EXPT_ID and JOB_ID for non GAB1F400.60
C operational set to RUN_INDIC_OP for operational use. GAB1F400.61
C PPHEAD1A.250
IF (MODEL_STATUS.NE.'Operational') THEN GAB1F400.62
RUN_ID(1:4)=EXPT_ID GAB1F400.63
RUN_ID(5:5)=JOB_ID GAB1F400.64
C Function EXPT_ENC will encode the run_id into a unique integer GAB1F400.65
CALL EXPT_ENC(RUN_ID,EXPTCODE,ICODE,CMESSAGE) GAB1F400.66
C We do not return here. We wait until the end of the subroutine. GAB1F400.67
PP_INT_HEAD(LBEXP)=EXPTCODE ! LBEXP GAB1F400.68
ELSE GAB1F400.69
PP_INT_HEAD(LBEXP)=RUN_INDIC_OP ! LBEXP (ITAB) GAB1F400.70
ENDIF GAB1F400.71
C PPHEAD1A.252
C Direct access dataset start address and no of records --------------- PPHEAD1A.253
C PPHEAD1A.254
PP_INT_HEAD(LBEGIN)=IWA PPHEAD1A.255
PP_INT_HEAD(LBNREC)=LEN_BUF_WORDS PPHEAD1A.256
C PPHEAD1A.257
C Operational fieldsfile projection no, fieldtype + level codes ------- PPHEAD1A.258
C These are hardwired according to model resolution PPHEAD1A.259
C PPHEAD1A.260
IF(INTHD(6).EQ.192) THEN PPHEAD1A.261
PP_IPROJ=802 PPHEAD1A.262
ELSE IF(INTHD(6).EQ.288) THEN PPHEAD1A.263
PP_IPROJ=800 PPHEAD1A.264
ELSE IF(INTHD(6).EQ.96) THEN PPHEAD1A.265
PP_IPROJ=870 PPHEAD1A.266
ELSE IF(INTHD(6).EQ.432) THEN GDR8F405.50
PP_IPROJ=800 GDR8F405.51
ELSE PPHEAD1A.267
PP_IPROJ=900 PPHEAD1A.268
ENDIF PPHEAD1A.269
PP_LBTYP=EXPPXI(im_ident, is, ie, ppx_meto8_fieldcode, GKR0F305.864
*CALL ARGPPX GKR0F305.865
& icode, cmessage) GKR0F305.866
lvcode=EXPPXI(im_ident, is, ie, ppx_lv_code, GAB1F400.72
*CALL ARGPPX GAB1F400.73
& icode, cmessage) GAB1F400.74
IF(LEVEL.EQ.-1.0) THEN PPHEAD1A.271
PP_LBLEV=EXPPXI(im_ident, is, ie, ppx_meto8_levelcode, GKR0F305.867
*CALL ARGPPX GKR0F305.868
& icode, cmessage) ! levelcode 9999 or 8888 GKR0F305.869
ELSE PPHEAD1A.276
IF (im_ident .eq. atmos_im) THEN GPB0F403.28
IF (lvcode.eq.ppx_half_level.and.BKH(LevIndex).eq.1.0) THEN GPB0F403.29
! NB: If BK indicates surface hybrid level, reset LBLEV to correspond GPB0F403.30
PP_LBLEV=ppx_meto8_surf GPB0F403.31
ELSE GPB0F403.32
PP_LBLEV=LEVEL+0.00001 GPB0F403.33
ENDIF GPB0F403.34
ELSE GPB0F403.35
PP_LBLEV=LEVEL+0.00001 GPB0F403.36
ENDIF GPB0F403.37
ENDIF PPHEAD1A.278
PP_INT_HEAD(LBPROJ)=PP_IPROJ PPHEAD1A.279
PP_INT_HEAD(LBTYP)=PP_LBTYP PPHEAD1A.280
PP_INT_HEAD(LBLEV)=PP_LBLEV PPHEAD1A.281
C PPHEAD1A.282
C Reserved slots for future expansion --------------------------------- PPHEAD1A.283
C PPHEAD1A.284
PP_INT_HEAD(LBRSVD1)=0 PPHEAD1A.285
PP_INT_HEAD(LBRSVD2)=0 PPHEAD1A.286
PP_INT_HEAD(LBRSVD3)=0 PPHEAD1A.287
PP_INT_HEAD(LBRSVD4)=0 PPHEAD1A.288
C PPHEAD1A.289
C Spare for user's use ------------------------------------------------ PPHEAD1A.290
C PPHEAD1A.291
PP_INT_HEAD(LBSRCE)=1111 PPHEAD1A.292
C PPHEAD1A.293
! Data type - extract from PPXREF GPB0F405.102
PP_INT_HEAD(DATA_TYPE)=EXPPXI(im_ident, is, ie, ppx_data_type, GPB0F405.103
*CALL ARGPPX GPB0F405.104
& icode, cmessage) GPB0F405.105
C PPHEAD1A.297
C Address within dump or PP file -------------------------------------- PPHEAD1A.298
C PPHEAD1A.299
PP_INT_HEAD(NADDR)=IWA PPHEAD1A.300
C PPHEAD1A.301
C LBUSER3 is not currently used (ie set to 0). GAB1F400.76
C PPHEAD1A.303
PP_INT_HEAD(LBUSER3)=0 GAB1F400.77
C PPHEAD1A.305
C STASH section/item code --------------------------------------------- PPHEAD1A.306
C PPHEAD1A.307
PP_INT_HEAD(ITEM_CODE)=IS*1000+IE PPHEAD1A.308
C PPHEAD1A.309
C STASH pseudo-level (for fields which have pseudo-levels defined) ---- PPHEAD1A.310
C PPHEAD1A.311
PP_INT_HEAD(LBPLEV)=pseudo_level PPHEAD1A.312
C PPHEAD1A.313
C Spare for user's use ------------------------------------------------ PPHEAD1A.314
C PPHEAD1A.315
PP_INT_HEAD(LBUSER6)=0 PPHEAD1A.316
PP_INT_HEAD(MODEL_CODE) = im_ident GRB1F400.93
C PPHEAD1A.318
C Reserved for future PP package use ---------------------------------- PPHEAD1A.319
C PPHEAD1A.320
PP_REAL_HEAD(BRSVD3)=0.0 PPHEAD1A.323
PP_REAL_HEAD(BRSVD4)=0.0 PPHEAD1A.324
PP_REAL_HEAD(BDATUM)=0.0 PPHEAD1A.325
PP_REAL_HEAD(BACC)=COMP_ACCRCY ! packing accuracy stored as real PPHEAD1A.326
C PPHEAD1A.327
C Vertical grid description ------------------------------------------- PPHEAD1A.328
C Level and reference level PPHEAD1A.329
C PPHEAD1A.330
IF(PP_LBVC.GE.126.AND.PP_LBVC.LE.139) THEN ! Special codes GAB1F400.78
C (surf botttom, GAB1F400.79
C top all zero) GAB1F400.80
PP_REAL_HEAD(BLEV)=0.0 PPHEAD1A.333
PP_REAL_HEAD(BHLEV)=0.0 PPHEAD1A.334
PP_REAL_HEAD(BRLEV)=0.0 GAB1F400.81
PP_REAL_HEAD(BHRLEV)=0.0 GAB1F400.82
PP_REAL_HEAD(BULEV)=0.0 GAB1F400.83
PP_REAL_HEAD(BHULEV)=0.0 GAB1F400.84
ELSEIF(PP_LBVC.EQ.9) THEN ! Hybrid/ETA levels GAB1F400.85
lvcode=EXPPXI(im_ident, is, ie, ppx_lv_code, GAB1F400.86
*CALL ARGPPX GAB1F400.87
& icode, cmessage) GAB1F400.88
IF (lvcode.EQ.ppx_half_level) THEN ! model levels GAB1F400.89
PP_REAL_HEAD(BLEV)=BKH(LevIndex) GAB1F400.90
PP_REAL_HEAD(BHLEV)=AKH(LevIndex) GAB1F400.91
IF(LevIndex.eq.1) THEN GAB1F400.92
C This case for surface eta diags. Halflevel below GAB1F400.93
C surface does not exist. GAB1F400.94
PP_REAL_HEAD(BRLEV)=BKH(LevIndex) GAB1F400.95
PP_REAL_HEAD(BHRLEV)=AKH(LevIndex) GAB1F400.96
ELSE GAB1F400.97
PP_REAL_HEAD(BRLEV)=BK(LevIndex-1) GAB1F400.98
PP_REAL_HEAD(BHRLEV)=AK(LevIndex-1) GAB1F400.99
ENDIF GAB1F400.100
IF(LevIndex.eq.T_levels+1) THEN GAB1F400.101
C This case for eta diags at top of atmosphere. GAB1F400.102
C Half level above toa does not exist. GAB1F400.103
PP_REAL_HEAD(BULEV)=BKH(LevIndex) GAB1F400.104
PP_REAL_HEAD(BHULEV)=AKH(LevIndex) GAB1F400.105
ELSE GAB1F400.106
PP_REAL_HEAD(BULEV)=BK(LevIndex) GAB1F400.107
PP_REAL_HEAD(BHULEV)=AK(LevIndex) GAB1F400.108
ENDIF GAB1F400.109
ELSE ! half levels GAB1F400.110
PP_REAL_HEAD(BLEV)=BK(LevIndex) GAB1F400.111
PP_REAL_HEAD(BHLEV)=AK(LevIndex) GAB1F400.112
PP_REAL_HEAD(BRLEV)=BKH(LevIndex) GAB1F400.113
PP_REAL_HEAD(BHRLEV)=AKH(LevIndex) GAB1F400.114
PP_REAL_HEAD(BULEV)=BKH(LevIndex+1) GAB1F400.115
PP_REAL_HEAD(BHULEV)=AKH(LevIndex+1) GAB1F400.116
ENDIF GAB1F400.117
ELSEIF (PP_LBVC.EQ.2.AND.OCEAN) THEN ! Depth levels GAB1F400.118
PP_REAL_HEAD(BHRLEV)=0.0 GAB1F400.119
PP_REAL_HEAD(BHULEV)=0.0 GAB1F400.120
int_level=level PPHEAD1A.340
lvcode=EXPPXI(im_ident, is, ie, ppx_lv_code, GKR0F305.870
*CALL ARGPPX GKR0F305.871
& icode, cmessage) GKR0F305.872
C ocn_depth defined for ocean full levels (e.g. temperature), and GAB1F400.121
C ocn_depth_h for ocean half-levels (e.g. vertical velocity) GAB1F400.122
ocn_depth=0.5*OCN_DZ(1) GAB1F400.123
ocn_depth_h=0. GAB1F400.124
IF (int_level.GT.1) THEN GAB1F400.125
DO K=2,int_level GAB1F400.126
C Loop over levels calculating half levels as we go. GAB1F400.127
ocn_depth=ocn_depth+0.5*(OCN_DZ(K-1)+OCN_DZ(K)) GAB1F400.128
GAB1F400.129
ocn_depth_h=ocn_depth_h+OCN_DZ(K-1) GAB1F400.130
END DO GAB1F400.131
ENDIF GAB1F400.132
IF (lvcode.EQ.ppx_half_level) THEN GAB1F400.133
PP_REAL_HEAD(BLEV)=ocn_depth_h GAB1F400.134
PP_REAL_HEAD(BRLEV)=ocn_depth GAB1F400.135
IF (int_level.EQ.1) THEN GAB1F400.136
PP_REAL_HEAD(BULEV)=0.0 ! This level would be a GAB1F400.137
C half level above the ocean. GAB1F400.138
C Set to zero. GAB1F400.139
ELSE GAB1F400.140
PP_REAL_HEAD(BULEV)=ocn_depth_h-0.5*OCN_DZ(int_level-1) GAB1F400.141
ENDIF GAB1F400.142
ELSE GAB1F400.143
PP_REAL_HEAD(BLEV)=ocn_depth GAB1F400.144
PP_REAL_HEAD(BRLEV)=ocn_depth_h+OCN_DZ(int_level) GAB1F400.145
PP_REAL_HEAD(BULEV)=ocn_depth_h GAB1F400.146
ENDIF GAB1F400.147
GAB1F400.148
PP_REAL_HEAD(BHLEV)=0.0 PPHEAD1A.357
ELSE PPHEAD1A.358
PP_REAL_HEAD(BLEV)=LEVEL PPHEAD1A.359
PP_REAL_HEAD(BHLEV)=0.0 PPHEAD1A.360
PP_REAL_HEAD(BRLEV)=0.0 ! The boundary levels GAB1F400.149
PP_REAL_HEAD(BHRLEV)=0.0 ! are not known GAB1F400.150
PP_REAL_HEAD(BULEV)=0.0 ! for pressure GAB1F400.151
PP_REAL_HEAD(BHULEV)=0.0 ! levels. GAB1F400.152
ENDIF PPHEAD1A.361
C PPHEAD1A.364
C Horizontal grid description ----------------------------------------- PPHEAD1A.365
C Position of pole (from dump fixed-length header) PPHEAD1A.366
C Grid orientation (hardwired 0.0) PPHEAD1A.367
C Origin and spacing of grid (depends on output grid type) PPHEAD1A.368
C PPHEAD1A.369
PP_REAL_HEAD(BPLAT)=REALHD(5) PPHEAD1A.370
PP_REAL_HEAD(BPLON)=REALHD(6) PPHEAD1A.371
PP_REAL_HEAD(BGOR)=0.0 PPHEAD1A.372
IF (samples.GT.0) THEN ! Indicates a timeseries/trajectory PPHEAD1A.373
PP_REAL_HEAD(BZX)=0.0 PPHEAD1A.374
PP_REAL_HEAD(BDX)=0.0 PPHEAD1A.375
PP_REAL_HEAD(BZY)=0.0 PPHEAD1A.376
PP_REAL_HEAD(BDY)=0.0 PPHEAD1A.377
ELSE PPHEAD1A.378
IF (OCEAN) THEN ! set BZY,BZX,BDY,BDX for ocean PPHEAD1A.379
IF (st_grid.EQ.st_uv_grid .OR. st_grid.EQ.st_zu_grid PPHEAD1A.380
& .OR. st_grid.EQ.st_mu_grid) THEN PPHEAD1A.381
PP_REAL_HEAD(BZY)=REALHD(3)-REALHD(2)/2.0 PPHEAD1A.382
PP_REAL_HEAD(BZX)=REALHD(4)-REALHD(1)/2.0 PPHEAD1A.383
ELSEIF (st_grid.EQ.st_tp_grid .OR. st_grid.EQ.st_zt_grid PPHEAD1A.384
& .OR. st_grid.EQ.st_mt_grid .OR. st_grid.EQ.st_scalar) THEN PPHEAD1A.385
PP_REAL_HEAD(BZY)=REALHD(3)-REALHD(2) PPHEAD1A.386
PP_REAL_HEAD(BZX)=REALHD(4)-REALHD(1) PPHEAD1A.387
ELSEIF (st_grid.EQ.st_cu_grid) THEN PPHEAD1A.388
PP_REAL_HEAD(BZY)=REALHD(3)-REALHD(2) PPHEAD1A.389
PP_REAL_HEAD(BZX)=REALHD(4)-REALHD(1)/2.0 PPHEAD1A.390
ELSEIF (st_grid.EQ.st_cv_grid) THEN PPHEAD1A.391
PP_REAL_HEAD(BZY)=REALHD(3)-REALHD(2)/2.0 PPHEAD1A.392
PP_REAL_HEAD(BZX)=REALHD(4)-REALHD(1) PPHEAD1A.393
ENDIF PPHEAD1A.394
IF (REALHD(32).GT.REALHD(29)) THEN ! greater than RMDI PPHEAD1A.395
PP_REAL_HEAD(BDY)=0.0 PPHEAD1A.396
PP_REAL_HEAD(BDX)=REALHD(32) PPHEAD1A.397
ELSE PPHEAD1A.398
PP_REAL_HEAD(BDY)=REALHD(2) PPHEAD1A.399
PP_REAL_HEAD(BDX)=REALHD(1) PPHEAD1A.400
ENDIF PPHEAD1A.401
ELSE ! set BZY,BZX,BDY,BDX for atmos PPHEAD1A.402
IF(st_grid.EQ.st_uv_grid.OR.st_grid.EQ.st_cv_grid .OR. PPHEAD1A.403
& st_grid.EQ.st_zu_grid.OR.st_grid.EQ.st_mu_grid) THEN PPHEAD1A.404
PP_REAL_HEAD(BZY)=REALHD(3)+REALHD(2)/2.0 ! UV pts PPHEAD1A.405
ELSE PPHEAD1A.406
PP_REAL_HEAD(BZY)=REALHD(3)+REALHD(2) ! Zeroth Lat BZY PPHEAD1A.407
ENDIF PPHEAD1A.408
C PPHEAD1A.409
IF(st_grid.EQ.st_uv_grid.OR.st_grid.EQ.st_cu_grid .OR. PPHEAD1A.410
& st_grid.EQ.st_zu_grid.OR.st_grid.EQ.st_mu_grid) THEN PPHEAD1A.411
PP_REAL_HEAD(BZX)=REALHD(4)-REALHD(1)/2.0 !UV points PPHEAD1A.412
ELSE PPHEAD1A.413
PP_REAL_HEAD(BZX)=REALHD(4)-REALHD(1) ! Zeroth Long BZX PPHEAD1A.414
ENDIF PPHEAD1A.415
PP_REAL_HEAD(BDX)=REALHD(1) ! Long intvl BDX PPHEAD1A.416
PP_REAL_HEAD(BDY)=-REALHD(2) ! Lat intvl BDY PPHEAD1A.417
ENDIF PPHEAD1A.418
C PPHEAD1A.419
C Add on offset for fields not starting from the origin PPHEAD1A.420
C PPHEAD1A.421
PP_REAL_HEAD(BZY)=PP_REAL_HEAD(BZY) PPHEAD1A.422
& +(NROW_IN-1)*PP_REAL_HEAD(BDY) PPHEAD1A.423
PP_REAL_HEAD(BZX)=PP_REAL_HEAD(BZX) PPHEAD1A.424
& +(WCOL_IN-1)*PP_REAL_HEAD(BDX) PPHEAD1A.425
IF(PP_REAL_HEAD(BZX).GE.360.0) PPHEAD1A.426
* PP_REAL_HEAD(BZX)=PP_REAL_HEAD(BZX)-360.0 PPHEAD1A.427
C PPHEAD1A.428
C If horizontal averaging has been applied to the output field, PPHEAD1A.429
C set BDX and/or BDY to the full (sub)domain extent which was processed. PPHEAD1A.430
C If the input field was intrinsically non-2D (eg. zonal), assume that PPHEAD1A.431
C the collapsed dimension(s) covered the full model domain. PPHEAD1A.432
C PPHEAD1A.433
mean_code=(GR/block_size)*block_size PPHEAD1A.434
IF (st_grid.EQ.st_zt_grid .OR. st_grid.EQ.st_zu_grid PPHEAD1A.435
& .OR. st_grid.EQ.st_scalar) THEN PPHEAD1A.436
PP_REAL_HEAD(BDX)=REAL(INTHD(6))*PP_REAL_HEAD(BDX) PPHEAD1A.437
ELSEIF (mean_code.EQ.zonal_mean_base .OR. PPHEAD1A.438
& mean_code.EQ.field_mean_base .OR. PPHEAD1A.439
& mean_code.EQ.global_mean_base) THEN PPHEAD1A.440
PP_REAL_HEAD(BDX)=ABS(REAL(ECOL_IN-WCOL_IN))*PP_REAL_HEAD(BDX) GTJ0F401.1
ENDIF PPHEAD1A.442
C PPHEAD1A.443
IF (st_grid.EQ.st_mt_grid .OR. st_grid.EQ.st_mu_grid PPHEAD1A.444
& .OR. st_grid.EQ.st_scalar) THEN PPHEAD1A.445
PP_REAL_HEAD(BDY)=REAL(INTHD(7))*PP_REAL_HEAD(BDY) PPHEAD1A.446
ELSEIF (mean_code.EQ.merid_mean_base .OR. PPHEAD1A.447
& mean_code.EQ.field_mean_base .OR. PPHEAD1A.448
& mean_code.EQ.global_mean_base) THEN PPHEAD1A.449
PP_REAL_HEAD(BDY)=ABS(REAL(NROW_IN-SROW_IN))*PP_REAL_HEAD(BDY) GTJ0F401.2
GTJ0F401.3
ENDIF PPHEAD1A.451
ENDIF PPHEAD1A.452
C PPHEAD1A.453
C Missing data indicator (from PARAMETER) ------------------------------ TJ050593.129
C MKS scaling factor (unity as model uses SI units throughout) PPHEAD1A.455
C PPHEAD1A.456
PP_REAL_HEAD(BMDI)=RMDI TJ050593.130
PP_REAL_HEAD(BMKS)=1.0 PPHEAD1A.458
C PPHEAD1A.459
999 CONTINUE PPHEAD1A.460
RETURN PPHEAD1A.461
END PPHEAD1A.462
*ENDIF PPHEAD1A.463