*IF DEF,RECON CONVLOO1.2
C ******************************COPYRIGHT****************************** GTS2F400.1315
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.1316
C GTS2F400.1317
C Use, duplication or disclosure of this code is subject to the GTS2F400.1318
C restrictions as set forth in the contract. GTS2F400.1319
C GTS2F400.1320
C Meteorological Office GTS2F400.1321
C London Road GTS2F400.1322
C BRACKNELL GTS2F400.1323
C Berkshire UK GTS2F400.1324
C RG12 2SZ GTS2F400.1325
C GTS2F400.1326
C If no contract has been raised with this copy of the code, the use, GTS2F400.1327
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.1328
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.1329
C Modelling at the above address. GTS2F400.1330
C ******************************COPYRIGHT****************************** GTS2F400.1331
C GTS2F400.1332
CLL SUBROUTINE CONVLOOK---------------------------------------- CONVLOO1.3
CLL CONVLOO1.4
CLL Written by A. Dickinson CONVLOO1.5
CLL CONVLOO1.6
CLL Model Modification history from model version 3.0: CONVLOO1.7
CLL version Date CONVLOO1.8
CLL 3.2 19/04/93 Code for new real missing data indicator. TJ050593.58
CLL Author: T.Johns Reviewer: A.Dickinson TJ050593.59
CLL 3.2 06/05/93 Set LOOKUP(30) (=LBNREC) to zero explicitly to AD060593.1
CLL be consistent with diagnostic lookups. R. Rawlins AD060593.2
CLL 3.3 29/10/93 Resets lookup entries so that dump files can be GO291093.2
CLL processed as PP-files. GO291093.3
CLL Author: D.M.Goddard GO291093.4
CLL 3.4 14/04/94 Corrections to atmosphere and ocean lookup GDG5F304.8
CLL records to allow PP processing GDG5F304.9
CLL Author: D.M.Goddard GDG5F304.10
CLL UDG4F304.139
CLL 3.4 19/07/94 Extra inputs added to namelist LOOK in order to UDG4F304.140
CLL allow user to define how the user prognostics are UDG4F304.141
CLL initialised. UDG4F304.142
CLL Author D.M.Goddard UDG4F304.143
! 3.5 24/04/95 Use subroutine STASH_PROC to set up addressing UDG2F305.124
! field lengths and number of levels rather than UDG2F305.125
! namelist LOOK. UDG2F305.126
! Author D.M.Goddard UDG2F305.127
! 3.5 13/03/95 Correct lookup(17) for rotated grids and set UDG1F305.151
! rlookup(58) to allow correct PP processing of dumps. UDG1F305.152
! on rotated grids UDG1F305.153
! Author D.M.Goddard UDG1F305.154
! 4.0 11/09/95 Pass grid type information up to CONTROL via UDG1F400.285
! argument GRID_TYPE. UDG1F400.286
! Author D.M. Goddard. UDG1F400.287
! 4.0 11/10/95 Update code for user prognostics for UDG7F400.219
! submodels project. UDG7F400.220
! Author D.M. Goddard. UDG7F400.221
! 4.1 03/04/96 New argument DUMP_PACK ; Use to set up LOOKUP(21) GDR2F401.19
! D. Robinson GDR2F401.20
CLL 4.1 31/05/96 Code to calc. zeroth lat and lat. spacing for UIE2F401.298
CLL data on a c grid. UIE2F401.299
CLL Author I.Edmond Reviewer D. Goddard UIE2F401.300
CLL 4.2 12/11/96 Logical L_OCOMP (CNTLOCN): allow both compressed USI0F402.1
CLL and uncompressed ocean dumps. SI USI0F402.2
CLL 4.3 19/5/97 Allow for pseudo-levels. W.Ingram AWI1F403.105
! 4.3 12/03/97 Corrects indexing of arrays used to hold UDG3F403.1
! information about user prognostic UDG3F403.2
! initialisation in reconfiguration. UDG3F403.3
! Author D.M.Goddard UDG3F403.4
CLL CONVLOO1.9
CLL Logical component number: S1 CONVLOO1.10
CLL CONVLOO1.11
CLL Purpose: CONVLOO1.12
CLL Sets up LOOKUP records for target file. CONVLOO1.13
CLL Extra info inserted into LOOKUP records from CONVLOO1.17
CLL PP_XREF file on unit 1 or user's STASH master file CONVLOO1.18
CLL on unit 2. CONVLOO1.19
CLL CONVLOO1.20
CLL Documentation: CONVLOO1.21
CLL UM Documentation papers S1 and F3 CONVLOO1.22
CLL------------------------------------------------------------ CONVLOO1.23
C*L Arguments:------------------------------------------------- CONVLOO1.24
SUBROUTINE CONVLOOK(VERT_ARG,N_TYPES_IN,PP_NUM_IN, 1,8UDG7F400.222
& LEN_FIXHD_OUT,FIXHD_OUT,HORIZ_GRID_TYPE,IPROJ, UDG7F400.223
& LEN_REALHD_OUT,REALHD_OUT,PP_ITEMC_IN, UDG7F400.224
& OZONE_LEVELS_IN, UDG7F400.225
& LEN2_LEVDEPC_OUT,LEN1_LEVDEPC_OUT,LEVDEPC_OUT, UDG7F400.226
& LEN1_LOOKUP_OUT,LEN2_LOOKUP_OUT, UDG7F400.227
& LOOKUP_OUT,RLOOKUP_OUT, UDG7F400.228
& LEN1_LOOKUP_IN,LEN2_LOOKUP_IN, UDG7F400.229
& LOOKUP_IN,RLOOKUP_IN, UDG7F400.230
& ROW_LENGTH_OUT,P_ROWS_OUT, UDG7F400.231
& P_LEVELS_OUT,Q_LEVELS_OUT, UDG7F400.232
& ST_LEVELS_OUT,SM_LEVELS_OUT, UJS1F401.270
& BL_LEVELS_OUT,OZONE_LEVELS_OUT, UJS1F401.271
& U_ROWS_OUT,U_FIELD_OUT,P_FIELD_OUT,AREA_OUT, UDG7F400.234
& P_LEVELS_IN,Q_LEVELS_IN, UJS1F401.272
& ST_LEVELS_IN,SM_LEVELS_IN,SRCE_OUT, UJS1F401.273
& UPRC_OUT,UPAF_OUT,UPAA_OUT, UDG7F400.236
& POINTS_PER_OCEAN_LEVEL,GRID_TYPE,DUMP_PACK, GDR2F401.21
*CALL ARGPPX 
UDG7F400.238
& LAND_POINTS_OUT,LEN_DATA_OUT,OCEAN,LCAL360, UDG7F400.239
& C_GRID_IN,C_GRID_OUT, UIE2F401.301
& LOZONE_ZONAL) UDG7F400.240
! Subroutine arguments UDG2F305.134
! Scalar arguments with intent(in): UDG2F305.135
CONVLOO1.37
IMPLICIT NONE CONVLOO1.38
CONVLOO1.39
INTEGER CONVLOO1.40
* LEN_FIXHD_OUT, !IN Length of fixed length header (output) CONVLOO1.41
* LEN_REALHD_OUT, !IN Length of Real header (output) CONVLOO1.42
* LEN2_LEVDEPC_OUT !IN 2nd dim of lev dep constants (output) CONVLOO1.43
*,LEN1_LEVDEPC_OUT, !IN 1st dim of lev dep constants (output) CONVLOO1.44
* LEN1_LOOKUP_OUT !IN 1st dim of lookup headers (output) CONVLOO1.45
*,LEN2_LOOKUP_OUT, !IN 2nd dim of lookup headers (output) CONVLOO1.46
* LEN1_LOOKUP_IN !IN 1st dim of lookup headers (input) CONVLOO1.47
*,LEN2_LOOKUP_IN, !IN 2nd dim of lookup headers (input) CONVLOO1.48
* ROW_LENGTH_OUT !IN No of points E-W (output) CONVLOO1.49
*,P_ROWS_OUT !IN No of p-points N-S (output) CONVLOO1.50
*,P_LEVELS_OUT !IN No of levels (output) CONVLOO1.51
*,Q_LEVELS_OUT, !IN No of wet levels (output) CONVLOO1.52
& ST_LEVELS_OUT, !IN No of soil temperature levels (output) UJS1F401.274
& SM_LEVELS_OUT !IN No of soil moisture levels (output) UJS1F401.275
*,BL_LEVELS_OUT, !IN No of b.l. levels (output) CONVLOO1.54
* OZONE_LEVELS_OUT, !IN No of ozone levels (output) CONVLOO1.55
* OZONE_LEVELS_IN, !IN No of ozone levels (input) CONVLOO1.56
* U_ROWS_OUT !IN No of uv-points N-S (output) CONVLOO1.57
*,U_FIELD_OUT !IN No of uv-points along a level (output) CONVLOO1.58
*,P_FIELD_OUT, !IN No of p-points along a level (output) CONVLOO1.59
* P_LEVELS_IN !IN No of levels (input) CONVLOO1.60
*,Q_LEVELS_IN !IN No of wet levels (input) CONVLOO1.61
&,ST_LEVELS_IN !IN No of soil temperature levels (input) UJS1F401.276
&,SM_LEVELS_IN !IN No of soil moisture levels (input) UJS1F401.277
*,LAND_POINTS_OUT !IN No of land points (output) CONVLOO1.63
*,LEN_DATA_OUT !OUT Length of data (output) UDG2F305.136
*,IPROJ !IN Projection number CONVLOO1.65
*,HORIZ_GRID_TYPE !IN Horizontal grid type CONVLOO1.66
*,N_TYPES_IN !IN No of different field types CONVLOO1.67
*,PP_NUM_IN(*) !IN No of fields per type CONVLOO1.68
*,PP_ITEMC_IN(*) !IN Item code of each type CONVLOO1.69
CONVLOO1.70
INTEGER FIXHD_OUT(LEN_FIXHD_OUT) UDG2F305.137
INTEGER LOOKUP_OUT(LEN1_LOOKUP_OUT,LEN2_LOOKUP_OUT) UDG2F305.138
INTEGER LOOKUP_IN(LEN1_LOOKUP_in,LEN2_LOOKUP_IN) UDG2F305.139
INTEGER SRCE_OUT(LEN2_LOOKUP_OUT) UDG2F305.140
!OUT S from NAMELIST ITEM UDG2F305.141
INTEGER AREA_OUT(LEN2_LOOKUP_OUT) UDG2F305.142
!OUT A from NAMELIST ITEM UDG2F305.143
REAL UPRC_OUT(LEN2_LOOKUP_OUT) UDG7F400.241
!OUT USER_PROG_RCONST from N'LIST ITEM UDG7F400.242
CHARACTER*80 UPAF_OUT(LEN2_LOOKUP_OUT) UDG7F400.243
!OUT USER_PROG_ANCIL_FILE UDG7F400.244
INTEGER UPAA_OUT(LEN2_LOOKUP_OUT) UDG7F400.245
!OUT USER_PROG_ANCIL_ITEMC "" "" UDG7F400.246
INTEGER START_ADDRESS UDG2F305.144
!OUT Address calculated using STASH_PROC UDG2F305.145
INTEGER LENGTH !OUT Length calculated using STASH_PROC UDG2F305.146
INTEGER N_LEVELS !OUT Number of levels calc STASH_PROC UDG2F305.147
INTEGER N_PLEVELS ! & of pseudo-levels AWI1F403.106
INTEGER POINTS_PER_OCEAN_LEVEL(99) UDG2F305.148
!Number of pointe per ocean level UDG2F305.149
INTEGER GRID_TYPE(LEN2_LOOKUP_OUT) UDG1F400.288
!Grid type:- 1=p-grid, UDG1F400.289
! 2=u-grid, UDG1F400.290
! 3=ocean velocity points UDG1F400.291
! 4=zonal mean. UDG1F400.292
INTEGER DUMP_PACK ! Packing indicator for dumps GDR2F401.22
! 1 : Get from PPXREF file GDR2F401.23
! 2 : Prognostics - Do not pack GDR2F401.24
! : Diagnostics - Get from PPXREF GDR2F401.25
! 3 : Do not pack any fields GDR2F401.26
UDG2F305.150
LOGICAL VERT_ARG !Vertical interpolation switch UDG2F305.151
LOGICAL C_GRID_IN !IN=T, Arakawa 'C' grid input UIE2F401.302
LOGICAL C_GRID_OUT !IN=T, Arakawa 'C' grid output UIE2F401.303
LOGICAL OCEAN !Ocean processing switch T=on UDG2F305.152
LOGICAL LCAL360 !T= 360 day calender: UDG2F305.153
!F= Gregorian calender UDG2F305.154
LOGICAL LOZONE_ZONAL !T= Zonal ozone field UDG2F305.155
!F= Full ozone field UDG2F305.156
UDG2F305.157
REAL REALHD_OUT(LEN_REALHD_OUT) UDG2F305.158
REAL LEVDEPC_OUT(LEN1_LEVDEPC_OUT,LEN2_LEVDEPC_OUT) UDG2F305.159
REAL RLOOKUP_OUT(LEN1_LOOKUP_OUT,LEN2_LOOKUP_OUT) UDG2F305.160
REAL RLOOKUP_IN(LEN1_LOOKUP_IN,LEN2_LOOKUP_IN) UDG2F305.161
UDG2F305.162
CONVLOO1.93
C Comdecks: ------------------------------------------------------------ CONVLOO1.94
*CALL CSUBMODL UDG2F305.174
*CALL CPPXREF UDG2F305.176
*CALL PPXLOOK UDG2F305.177
*CALL NRECON UDG2F305.178
*CALL C_ITEMS UDG2F305.179
*CALL CNTLOCN USI0F402.3
*CALL C_MDI CONVLOO1.96
CONVLOO1.97
C Local arrays:--------------------------------------------------------- CONVLOO1.98
INTEGER CONVLOO1.99
* LOOKUP(64) CONVLOO1.100
*,AREA(LEN2_LOOKUP_OUT) CONVLOO1.101
*,PP_XREF(PPXREF_CODELEN) !PPXREF codes for a given section/item CONVLOO1.102
*,LEN_OCEAN(LEN2_LOOKUP_OUT) CONVLOO1.103
&,WHOLE ! Whole value of LOOKUP(21) GDR2F401.27
! LOOKUP(21) = N5N4N3N2N1 : See UMDP F3 GDR2F401.28
&,N1 ! Packing Indicator in LOOKUP(21) GDR2F401.29
&,N2 ! Compression Indicator in LOOKUP(21) GDR2F401.30
&,N3 ! Compression Method in LOOKUP(21) GDR2F401.31
GDR2F401.32
REAL CONVLOO1.106
* RLOOKUP(64) CONVLOO1.107
&,LEVEL(LEN1_LEVDEPC_OUT) GDG5F304.11
&,DEPTH GDG5F304.12
CONVLOO1.108
C External subroutines called:------------------------------------------ CONVLOO1.109
EXTERNAL EXPPXC,EXPPXI,ABORT_IO UDG2F305.180
C*---------------------------------------------------------------------- CONVLOO1.111
C*L Local variables:--------------------------------------------------- CONVLOO1.112
INTEGER CONVLOO1.113
* SECTION !STASH section code CONVLOO1.114
*,ITEM_CODE !STASH item code CONVLOO1.115
INTEGER MODEL !Internal model number UDG2F305.181
INTEGER AREA_TEMP !Stores AREA_OUT(K) as scalar in loop UDG2F305.182
INTEGER SRCE_TEMP !Stores SRCE_OUT(K) as scalar in loop UDG2F305.183
REAL UPRC_TEMP UDG3F403.5
CHARACTER*80 UPAF_TEMP UDG3F403.6
INTEGER UPAA_TEMP UDG3F403.7
INTEGER K_IN !Stores SRCE_OUT(K) as scalar in loop UDG2F305.184
INTEGER K_OUT !Stores SRCE_OUT(K) as scalar in loop UDG2F305.185
INTEGER I,J,K,JJ !DO loop indices UDG2F305.186
INTEGER ICOUNT !Counter used to compute LOOKUP(40) UDG2F305.187
INTEGER ICT !Counter used to calculate ocean lvls UDG2F305.188
INTEGER PPXREF_GRID_TYPE UDG1F400.293
!Holds grid type extracted from PPXREF UDG1F400.294
INTEGER JCOUNT !Counter used to fill array IPROGPSN UDG7F400.247
INTEGER ICODE !Error code UDG2F305.190
CHARACTER*80 CMESSAGE !Error message UDG2F305.191
UDG2F305.192
INTEGER ITEM_NAMELIST(LEN2_LOOKUP_OUT) UDG7F400.251
INTEGER SRCE_NAMELIST(LEN2_LOOKUP_OUT) UDG7F400.252
INTEGER AREA_NAMELIST(LEN2_LOOKUP_OUT) UDG7F400.253
REAL UPRC_NAMELIST(LEN2_LOOKUP_OUT) UDG7F400.254
CHARACTER*80 UPAF_NAMELIST(MAX_LEN2_LOOKUP_OUT) UDG7F400.255
INTEGER UPAA_NAMELIST(LEN2_LOOKUP_OUT) UDG7F400.256
INTEGER EXPPXI !Function to extract integer UDG2F305.193
! from ppxref file UDG2F305.194
CHARACTER*36 EXPPXC !Function to extract character string UDG2F305.195
! from ppxref file UDG2F305.196
INTEGER IPROGPSN(LEN2_LOOKUP_OUT) UDG7F400.248
!Position in prognostic list of field UDG7F400.249
UDG7F400.250
UDG2F305.197
! 1: Initialise arrays holding NAMELIST info UDG2F305.198
DO K=1,LEN2_LOOKUP_OUT UDG2F305.199
ITEM_NAMELIST(K)=IMDI UDG2F305.200
AREA_NAMELIST(K)=1 UDG2F305.201
SRCE_NAMELIST(K)=1 UDG2F305.202
UPRC_NAMELIST(K)=RMDI UDG2F305.204
UPAF_NAMELIST(K)=' ' UDG2F305.205
UPAA_NAMELIST(K)=IMDI UDG2F305.206
END DO UDG2F305.207
UDG2F305.208
! 2: Loop through NAMELIST input updating variables UDG2F305.209
DO J=1,LEN2_LOOKUP_OUT UDG2F305.210
READ(5,ITEMS,END=953,ERR=954) UDG3F402.777
ITEM_NAMELIST(J)=ITEM UDG2F305.212
AREA_NAMELIST(J)=DOMAIN GDG0F401.465
SRCE_NAMELIST(J)=SOURCE GDG0F401.466
UPRC_NAMELIST(J)=USER_PROG_RCONST UDG2F305.216
UPAF_NAMELIST(J)=USER_PROG_ANCIL_FILE UDG2F305.217
UPAA_NAMELIST(J)=USER_PROG_ANCIL_ITEMC UDG2F305.218
END DO UDG2F305.219
953 CONTINUE UDG2F305.220
954 CONTINUE UDG3F402.778
UDG3F402.779
UDG2F305.221
! 3: Initialise LOOKUP array UDG2F305.222
UDG2F305.223
! 3.1: Initialise time information UDG2F305.224
DO I=1,12 UDG2F305.225
LOOKUP(I)=LOOKUP_IN(I,1) UDG2F305.226
END DO UDG2F305.227
UDG2F305.228
! 3.2 Initialise integer elements UDG2F305.229
DO I=13,45 UDG2F305.230
LOOKUP(I)=IMDI UDG2F305.231
ENDDO UDG2F305.232
UDG2F305.233
! 3.3 Initialise real elements UDG2F305.234
DO I=46,64 UDG2F305.235
RLOOKUP(I)=RMDI UDG2F305.236
ENDDO UDG2F305.237
UDG2F305.238
K_OUT=1 UDG2F305.239
UDG2F305.240
! 4: Calculate ocean levels from level dependent constants UDG2F305.241
UDG2F305.242
IF(OCEAN)THEN UDG2F305.243
DEPTH=0 UDG2F305.244
DO J=1,LEN1_LEVDEPC_OUT UDG2F305.245
DEPTH=DEPTH+LEVDEPC_OUT(J,1)/2 UDG2F305.246
LEVEL(J)=DEPTH UDG2F305.247
DEPTH=DEPTH+LEVDEPC_OUT(J,1)/2 UDG2F305.248
END DO UDG2F305.249
END IF UDG2F305.250
UDG2F305.251
! 5: Loop through prognostic items and initialise LOOKUP_OUT UDG2F305.252
! UDG2F305.253
JCOUNT = 0 UDG7F400.257
DO J=1,N_INTERNAL_MODEL UDG2F305.254
DO JJ=1,NProgItems(J) UDG2F305.255
JCOUNT = JCOUNT + 1 UDG7F400.258
UDG2F305.256
! 5.1: Extract addressing and number of levels from COMMON block UDG2F305.257
ITEM_CODE = ProgItems(J,JJ) UDG2F305.258
N_LEVELS = Recondat(J,ITEM_CODE,1) UDG2F305.259
LENGTH = Recondat(J,ITEM_CODE,2) UDG2F305.260
START_ADDRESS = Recondat(J,ITEM_CODE,3) UDG2F305.261
N_PLEVELS = Recondat(J,ITEM_CODE,4) AWI1F403.107
UDG2F305.262
! 5.2: Check NAMELIST for additional input UDG2F305.263
AREA_TEMP = 1 UDG2F305.264
SRCE_TEMP = 1 UDG2F305.265
DO K=1,LEN2_LOOKUP_OUT UDG2F305.266
IF(ITEM_CODE.EQ.ITEM_NAMELIST(K))THEN UDG2F305.267
AREA_TEMP = AREA_NAMELIST(K) UDG2F305.268
SRCE_TEMP = SRCE_NAMELIST(K) UDG2F305.269
UPRC_TEMP = UPRC_NAMELIST(K) UDG3F403.8
UPAF_TEMP = UPAF_NAMELIST(K) UDG3F403.9
UPAA_TEMP = UPAA_NAMELIST(K) UDG3F403.10
ENDIF UDG2F305.270
END DO UDG2F305.271
UDG2F305.272
! 5.3: Expand over number of levels UDG2F305.273
ICOUNT=0 UDG2F305.274
DO K=K_OUT,K_OUT+N_LEVELS*N_PLEVELS-1 AWI1F403.108
LEN_OCEAN(K) = LENGTH/(N_LEVELS*N_PLEVELS) AWI1F403.109
AREA_OUT(K) = AREA_TEMP UDG2F305.277
SRCE_OUT(K) = SRCE_TEMP UDG2F305.278
UPRC_OUT(K) = UPRC_TEMP UDG3F403.11
UPAF_OUT(K) = UPAF_TEMP UDG3F403.12
UPAA_OUT(K) = UPAA_TEMP UDG3F403.13
IPROGPSN(K) = JCOUNT UDG7F400.262
UDG2F305.279
! 5.3.1: Initialise LOOKUP_OUT UDG2F305.280
DO I=1,45 UDG2F305.281
LOOKUP_OUT(I,K)=LOOKUP(I) UDG2F305.282
END DO UDG2F305.283
DO I=46,64 UDG2F305.284
RLOOKUP_OUT(I,K)=RLOOKUP(I) UDG2F305.285
END DO UDG2F305.286
LOOKUP_OUT(42,K)=ITEM_CODE UDG2F305.287
LOOKUP_OUT(45,K)=INTERNAL_MODEL_LIST(J) UDG2F305.288
UDG2F305.289
! 5.3.2: Set addressing information UDG2F305.290
IF(OCEAN.AND.N_LEVELS.GT.1) THEN USI0F402.4
IF (L_OCOMP) THEN USI0F402.5
LOOKUP_OUT(15,K)=POINTS_PER_OCEAN_LEVEL(K-K_OUT+1) UDG2F305.292
ELSE USI0F402.6
LOOKUP_OUT(15,K)=LENGTH/(N_LEVELS*N_PLEVELS) AWI1F403.110
ENDIF USI0F402.8
USI0F402.9
USI0F402.10
USI0F402.11
USI0F402.12
USI0F402.13
ELSE UDG2F305.293
LOOKUP_OUT(15,K)=LENGTH/(N_LEVELS*N_PLEVELS) AWI1F403.111
END IF UDG2F305.295
LOOKUP_OUT(40,K)=START_ADDRESS+ICOUNT UDG2F305.296
ICOUNT=ICOUNT+LOOKUP_OUT(15,K) UDG2F305.297
UDG2F305.298
! 5.3.3: Calculate levels from level dependent constants UDG2F305.299
! Set levels for multi-level fields only UDG2F305.300
! Levels not set for single level fields UDG2F305.301
IF(N_LEVELS.GT.1)THEN UDG2F305.302
IF(.NOT.OCEAN)THEN UDG2F305.303
LOOKUP_OUT(33,K)=MOD(K-K_OUT,N_LEVELS)+1 AWI1F403.112
RLOOKUP_OUT(52,K)=LEVDEPC_OUT(LOOKUP_OUT(33,K),2) AWI1F403.113
RLOOKUP_OUT(54,K)=LEVDEPC_OUT(LOOKUP_OUT(33,K),1) AWI1F403.114
ELSE UDG2F305.307
ICT=0 UDG2F305.308
DO I=2,LEN2_LOOKUP_OUT UDG2F305.309
IF(LOOKUP_OUT(42,ICT+1).EQ.LOOKUP_OUT(42,I))THEN UDG2F305.310
IF(I-ICT.EQ.2)RLOOKUP_OUT(52,ICT+1)=LEVEL(1) UDG2F305.311
RLOOKUP_OUT(52,I)=LEVEL(I-ICT) UDG2F305.312
ELSE UDG2F305.313
ICT=I-1 UDG2F305.314
END IF UDG2F305.315
END DO UDG2F305.316
END IF UDG2F305.317
END IF UDG2F305.318
END DO UDG2F305.319
K_OUT=K_OUT+(N_LEVELS*N_PLEVELS) AWI1F403.115
AWI1F403.116
UDG1F400.295
! 5.4: Extract grid code from ppxref file UDG1F400.296
SECTION = 0 !Prognostics all in section 0 UDG1F400.297
MODEL = INTERNAL_MODEL_LIST(J) UDG1F400.298
PPXREF_GRID_TYPE=EXPPXI(MODEL,SECTION,ITEM_CODE,ppx_grid_type, UDG1F400.299
*CALL ARGPPX UDG1F400.300
& ICODE,CMESSAGE) UDG1F400.301
IF(PPXREF_GRID_TYPE.GT.10.AND.PPXREF_GRID_TYPE.LT.14)THEN UDG1F400.302
GRID_TYPE(JCOUNT) = 2 UDG1F400.303
ELSE IF((PPXREF_GRID_TYPE.EQ.18).OR. UIE2F401.304
& (PPXREF_GRID_TYPE.EQ.19))THEN UIE2F401.305
GRID_TYPE(JCOUNT) = 2 UIE2F401.306
ELSE IF(PPXREF_GRID_TYPE.EQ.37)THEN UDG1F400.304
GRID_TYPE(JCOUNT) = 3 UDG1F400.305
ELSE IF(LOZONE_ZONAL.AND.ITEM_CODE.EQ.60)THEN UDG1F400.306
GRID_TYPE(JCOUNT) = 4 UDG1F400.307
ELSE UDG1F400.308
GRID_TYPE(JCOUNT) = 1 UDG1F400.309
END IF UDG1F400.310
END DO UDG2F305.321
END DO UDG2F305.322
UDG2F305.323
C------------------------------------------------------------------- CONVLOO1.369
C Initialise LOOKUP fields from PPXREF CONVLOO1.370
C------------------------------------------------------------------- CONVLOO1.371
CONVLOO1.372
DO K=1,LEN2_LOOKUP_OUT CONVLOO1.373
ITEM_CODE=MOD(LOOKUP_OUT(42,K),1000) CONVLOO1.374
SECTION=(LOOKUP_OUT(42,K)-ITEM_CODE)/1000 CONVLOO1.375
MODEL=LOOKUP_OUT(45,K) UDG2F305.324
IF(FIXHD_OUT(4).LT.100) THEN GDG5F304.37
LOOKUP_OUT(16,K)=1 GDG5F304.38
LOOKUP_OUT(17,K)=HORIZ_GRID_TYPE UDG1F305.155
ELSE GDG5F304.39
LOOKUP_OUT(16,K)=101 !100 added for non-standard polar axis GDG5F304.40
LOOKUP_OUT(17,K)=HORIZ_GRID_TYPE-100 UDG1F305.156
ENDIF GDG5F304.41
LOOKUP_OUT(20,K)=0 ! No extra data GO291093.11
LOOKUP_OUT(22,K)=2 ! Header release number currently 2 GO291093.12
LOOKUP_OUT(23,K)=EXPPXI(MODEL,SECTION,ITEM_CODE,ppx_field_code, UDG2F305.325
*CALL ARGPPX UDG2F305.326
& ICODE,CMESSAGE) UDG2F305.327
LOOKUP_OUT(26,K)=EXPPXI(MODEL,SECTION,ITEM_CODE,ppx_lbvc_code, UDG2F305.328
*CALL ARGPPX UDG2F305.329
& ICODE,CMESSAGE) UDG2F305.330
LOOKUP_OUT(29,K)=0 UDG2F305.331
LOOKUP_OUT(30,K)=0 AD060593.3
LOOKUP_OUT(31,K)=IPROJ CONVLOO1.386
LOOKUP_OUT(32,K)=EXPPXI(MODEL,SECTION,ITEM_CODE, UDG2F305.332
& ppx_meto8_fieldcode, UDG2F305.333
*CALL ARGPPX UDG2F305.334
& ICODE,CMESSAGE) UDG2F305.335
IF(LOOKUP_OUT(33,K).EQ.IMDI)THEN CONVLOO1.388
LOOKUP_OUT(33,K)=EXPPXI(MODEL,SECTION,ITEM_CODE, UDG2F305.336
& ppx_meto8_levelcode, UDG2F305.337
*CALL ARGPPX UDG2F305.338
& ICODE,CMESSAGE) UDG2F305.339
ENDIF CONVLOO1.390
CONVLOO1.391
LOOKUP_OUT(38,K)=1111 CONVLOO1.392
IF(LOOKUP_OUT(39,K).EQ.IMDI) CONVLOO1.393
&LOOKUP_OUT(39,K)=EXPPXI(MODEL,SECTION,ITEM_CODE,ppx_data_type, UDG2F305.340
*CALL ARGPPX UDG2F305.341
& ICODE,CMESSAGE) UDG2F305.342
IF(LOOKUP_OUT(21,K).EQ.IMDI)THEN CONVLOO1.395
LOOKUP_OUT(21,K)=EXPPXI(MODEL,SECTION,ITEM_CODE,ppx_dump_packing, UDG2F305.343
*CALL ARGPPX UDG2F305.344
& ICODE,CMESSAGE) UDG2F305.345
IF (DUMP_PACK.eq.2 .or. DUMP_PACK.eq.3 ) THEN GDR2F401.33
! Do not pack data ; Override packing indicator from PPXREF GDR2F401.34
N1 = 0 ! No packing GDR2F401.35
LOOKUP_OUT(21,K) = (LOOKUP_OUT(21,K)/10)*10 + N1 GDR2F401.36
ENDIF GDR2F401.37
ENDIF CONVLOO1.397
RLOOKUP_OUT(64,K)=1.0 GDG5F304.43
ENDDO CONVLOO1.398
CONVLOO1.399
C------------------------------------------------------------------- CONVLOO1.400
C Change LOOKUP to allow for change in horizontal dimensions CONVLOO1.401
C------------------------------------------------------------------- CONVLOO1.402
CONVLOO1.403
DO K=1,LEN2_LOOKUP_OUT CONVLOO1.405
CONVLOO1.406
ITEM_CODE=MOD(LOOKUP_OUT(42,K),1000) CONVLOO1.407
SECTION=(LOOKUP_OUT(42,K)-ITEM_CODE)/1000 CONVLOO1.408
MODEL=LOOKUP_OUT(45,K) UDG2F305.346
UDG2F305.347
IF(AREA_OUT(K).EQ.1)THEN UDG2F305.348
UDG2F305.349
C Get N2 and N3 from whole value of LBPACK UDG2F305.350
WHOLE=LOOKUP_OUT(21,K) UDG2F305.351
N2=MOD(INT(WHOLE/10),10) UDG2F305.352
N3=MOD(INT(WHOLE/100),10) UDG2F305.353
UDG2F305.354
IF(N2.EQ.2.AND.N3.EQ.1) THEN UDG2F305.355
UDG2F305.356
LOOKUP_OUT(18,K)=0 UDG2F305.357
LOOKUP_OUT(19,K)=0 UDG2F305.358
UDG2F305.359
ELSEIF(N2.EQ.1.AND.N3.EQ.1) THEN UDG2F305.360
UDG2F305.361
LOOKUP_OUT(18,K)=0 UDG2F305.362
LOOKUP_OUT(19,K)=0 UDG2F305.363
UDG2F305.364
ELSE UDG2F305.365
UDG2F305.366
PPXREF_GRID_TYPE=EXPPXI(MODEL,SECTION,ITEM_CODE,ppx_grid_type, UDG1F400.311
*CALL ARGPPX UDG2F305.368
& ICODE,CMESSAGE) UDG2F305.369
IF(GRID_TYPE(IPROGPSN(K)).EQ.2.OR. UDG1F400.312
& GRID_TYPE(IPROGPSN(K)).EQ.3)THEN UDG1F400.313
UDG2F305.371
IF(PPXREF_GRID_TYPE.EQ.18)THEN UIE2F401.307
! u_rows_out is the same size as p_rows_out on the c grid. UIE2F401.308
LOOKUP_OUT(18,K)=U_ROWS_OUT UIE2F401.309
ELSE UIE2F401.310
! u has one less row on B grid. UIE2F401.311
LOOKUP_OUT(18,K)=P_ROWS_OUT-1 UIE2F401.312
ENDIF UIE2F401.313
LOOKUP_OUT(19,K)=ROW_LENGTH_OUT UDG2F305.373
UDG2F305.374
ELSE UDG2F305.375
UDG2F305.376
LOOKUP_OUT(18,K)=P_ROWS_OUT UDG2F305.377
IF(LOZONE_ZONAL.AND.ITEM_CODE.EQ.60)THEN UDG2F305.378
LOOKUP_OUT(19,K)=1 UDG2F305.379
ELSE UDG2F305.380
LOOKUP_OUT(19,K)=ROW_LENGTH_OUT UDG2F305.381
ENDIF UDG2F305.382
UDG2F305.383
ENDIF UDG2F305.384
UDG2F305.385
ENDIF UDG2F305.386
CONVLOO1.459
RLOOKUP_OUT(56,K)=REALHD_OUT(5) CONVLOO1.460
RLOOKUP_OUT(57,K)=REALHD_OUT(6) CONVLOO1.461
RLOOKUP_OUT(58,K)=0. UDG1F305.157
IF(OCEAN)THEN GDG5F304.50
RLOOKUP_OUT(60,K)=REALHD_OUT(2) GDG5F304.51
RLOOKUP_OUT(59,K)=REALHD_OUT(3)-REALHD_OUT(2) GDG5F304.52
ELSE GDG5F304.53
IF(FIXHD_OUT(3).EQ.5) THEN UIE2F401.341
! Reverse rows (data on p points) for new dynamics grid/VAR UIE2F401.342
! when fixhd_out indicates a radial grid. UIE2F401.343
RLOOKUP_OUT(60,K)=REALHD_OUT(2) UIE2F401.344
RLOOKUP_OUT(59,K)=REALHD_OUT(3)-(REALHD_OUT(2)*P_ROWS_OUT) UIE2F401.345
ELSE UIE2F401.346
RLOOKUP_OUT(60,K)=-REALHD_OUT(2) GDG5F304.54
RLOOKUP_OUT(59,K)=REALHD_OUT(3)+REALHD_OUT(2) GDG5F304.55
END IF UIE2F401.347
ENDIF GDG5F304.56
RLOOKUP_OUT(61,K)=REALHD_OUT(4)-REALHD_OUT(1) CONVLOO1.464
IF(LOOKUP_OUT(19,K).EQ.1)THEN CONVLOO1.465
RLOOKUP_OUT(62,K)=360. CONVLOO1.466
ELSE CONVLOO1.467
RLOOKUP_OUT(62,K)=REALHD_OUT(1) CONVLOO1.468
ENDIF CONVLOO1.469
IF(GRID_TYPE(IPROGPSN(K)).EQ.2)THEN UDG1F400.314
RLOOKUP_OUT(59,K)=REALHD_OUT(3)+REALHD_OUT(2)*.5 CONVLOO1.472
RLOOKUP_OUT(61,K)=REALHD_OUT(4)-REALHD_OUT(1)*.5 CONVLOO1.473
IF(PPXREF_GRID_TYPE.EQ.18) THEN UIE2F401.314
! If data on u points on a c grid calc. zeroth lat and lat. spaci UIE2F401.315
IF(FIXHD_OUT(3).EQ.5) THEN UIE2F401.316
! Reverse u rows for new dynamics grid/VAR when fixhd_out UIE2F401.317
! indicates a radial grid. UIE2F401.318
RLOOKUP_OUT(59,K)=REALHD_OUT(3)-(REALHD_OUT(2)*U_ROWS_OUT) UIE2F401.319
RLOOKUP_OUT(61,K)=REALHD_OUT(4)-REALHD_OUT(1)*.5 UIE2F401.320
ELSE UIE2F401.321
! Otherwise calc. zeroth lat and lat. spacing for UM c grid. UIE2F401.322
RLOOKUP_OUT(59,K)=REALHD_OUT(3)+REALHD_OUT(2) UIE2F401.323
RLOOKUP_OUT(61,K)=REALHD_OUT(4)-REALHD_OUT(1)*.5 UIE2F401.324
END IF UIE2F401.325
ELSE IF(PPXREF_GRID_TYPE.EQ.19) THEN UIE2F401.326
! If data on v points on a c grid calc. zeroth lat and lat. spaci UIE2F401.327
IF(FIXHD_OUT(3).EQ.5) THEN UIE2F401.328
! Reverse v rows for new dynamics grid/VAR when fixhd_out UIE2F401.329
! indicates a radial grid. UIE2F401.330
RLOOKUP_OUT(59,K)=REALHD_OUT(3) - (REALHD_OUT(2) * UIE2F401.331
& P_ROWS_OUT) + REALHD_OUT(2)* 0.5 UIE2F401.332
RLOOKUP_OUT(61,K)=REALHD_OUT(4)-REALHD_OUT(1) UIE2F401.333
ELSE UIE2F401.334
! Otherwise calc. zeroth lat and lat. spacing for UM c grid. UIE2F401.335
RLOOKUP_OUT(59,K)=REALHD_OUT(3)+REALHD_OUT(2)*.5 UIE2F401.336
RLOOKUP_OUT(61,K)=REALHD_OUT(4)-REALHD_OUT(1) UIE2F401.337
END IF UIE2F401.338
UIE2F401.339
END IF UIE2F401.340
ELSE IF(GRID_TYPE(IPROGPSN(K)).EQ.3)THEN UDG1F400.315
RLOOKUP_OUT(59,K)=REALHD_OUT(3)-REALHD_OUT(2)*.5 GDG5F304.58
RLOOKUP_OUT(61,K)=REALHD_OUT(4)-REALHD_OUT(1)*.5 GDG5F304.59
ENDIF CONVLOO1.474
CONVLOO1.475
ENDIF CONVLOO1.476
CONVLOO1.477
! Set lookup 13 from LCAL360. prefromed in UI prior to vn 3.5 UDG2F305.389
IF(LCAL360)THEN UDG2F305.390
LOOKUP_OUT(13,K)=2 UDG2F305.391
ELSE UDG2F305.392
LOOKUP_OUT(13,K)=1 UDG2F305.393
ENDIF UDG2F305.394
UDG2F305.395
CONVLOO1.485
ENDDO CONVLOO1.486
CONVLOO1.494
RETURN CONVLOO1.495
END CONVLOO1.496
*ENDIF CONVLOO1.497