INTEGER FUNCTION EXPPXI(Im_ident,section,item,element, 100GSS1F400.1258
*CALL ARGPPX 
EXPPX1.7
& ErrorStatus ,CMESSAGE) EXPPX1.8
IMPLICIT NONE EXPPX1.9
! EXPPX1.10
! Description: EXPPX1.11
! Extracts an individual data value from ppxref lookup array PPXI. EXPPX1.12
! EXPPX1.13
! Method: EXPPX1.14
! The required data element is identified by the function arguments EXPPX1.15
! Im_ident, section, item, element. The appropriate row in PPXI is GSS1F400.1259
! found from the 3-d pointer array PPXPTR as PPXPTR(m,s,i). The GSS1F400.1260
! address of the required element in PPXI is then given by GSS1F400.1261
! (row, element). GSS1F400.1262
! EXPPX1.19
! GSS1F400.1263
! GSS1F400.1264
! Current code owner: S.J.Swarbrick GSS1F400.1265
! GSS1F400.1266
! History: GSS1F400.1267
! Version Date Comment GSS1F400.1268
! ======= ==== ======= GSS1F400.1269
! 3.5 Mar. 95 Original code. (S.J.Swarbrick) GSS1F400.1270
! 4.0 Oct. 95 S.J.Swarbrick GSS1F400.1271
! 4.1 June 96 Error checking improved S.J.Swarbrick GSS1F401.59
! GSS1F400.1272
! Code description: GSS1F400.1273
! FORTRAN 77 + common Fortran 90 extensions. GSS1F400.1274
! Written to UM programming standards version 7. GSS1F400.1275
! GSS1F400.1276
! System component covered: GSS1F400.1277
! System task: Sub-Models Project GSS1F400.1278
! GSS1F400.1279
! Global Variables: GSS1F400.1280
*CALL CSUBMODL GSS1F400.1282
*CALL CPPXREF GSS1F400.1283
*CALL PPXLOOK GSS1F400.1285
GSS1F400.1286
! Function arguments: GSS1F400.1287
! Scalar arguments with intent(in): GSS1F400.1289
INTEGER Im_ident ! Internal model identifier (absolute) GSS1F400.1290
INTEGER section ! STASH section no. GSS1F400.1291
INTEGER item ! STASH item no. GSS1F400.1292
INTEGER element ! Position of required value in PPXI row GSS1F400.1293
GSS1F400.1294
! Scalar arguments with intent(out): GSS1F400.1295
CHARACTER*80 CMESSAGE GSS9F402.166
GSS1F400.1297
! Error status: GSS1F400.1298
INTEGER ErrorStatus !+ve = fatal error GSS1F400.1299
GSS1F400.1300
! Local scalars GSS1F400.1301
INTEGER row ! Row no. in PPXI array GSS1F400.1302
INTEGER Im_index ! Internal model index GSS1F400.1303
GSS1F400.1304
!- End of Header --------------------------------------------------- GSS1F400.1308
GSS1F400.1309
ErrorStatus = 0 GSS1F400.1310
IF (Im_ident.LE.0 .OR. section.LT.0 .OR. item.LE.0) THEN GSS1F400.1312
IF (Im_ident.LE.0) WRITE(6,*) 'EXPPXI: INVALID Im_ident' GSS1F400.1313
IF (section .LT.0) WRITE(6,*) 'EXPPXI: INVALID SECTION NO.' GSS1F400.1314
IF (item .LE.0) WRITE(6,*) 'EXPPXI: INVALID ITEM NO.' GSS1F400.1315
WRITE(6,*) GSS1F400.1316
& 'Im_ident ',Im_ident,' section ',section,' item ',item GSS1F400.1317
ErrorStatus=1 GSS1F401.60
CMESSAGE='ERROR EXPPXI: INVALID STASH RECORD ID' GSS1F401.61
ELSE GSS1F401.62
GSS1F400.1319
! Obtain row no. in PPXI array GSS1F400.1320
*IF DEF,RECON GSS1F400.1322
row = PPXPTR(Im_ident,section,item) GSS1F400.1323
*ELSE GSS1F400.1324
Im_index = INTERNAL_MODEL_INDEX(Im_ident) GSS1F400.1325
row = PPXPTR(Im_index,section,item) GSS1F400.1326
IF (row.LE.0) THEN GSS1F400.1327
WRITE(6,*) 'ERROR EXPPXI: INVALID row VALUE: ',row GSS1F400.1328
WRITE(6,*) 'Im_ident,Sec,Item: ',Im_ident,section,item GSS1F400.1329
! ErrorStatus = 1 GSS1F400.1331
! CMESSAGE='ERROR EXPPXI: INVALID row VALUE' GSS1F400.1332
END IF GSS1F400.1333
*ENDIF GSS1F400.1334
GSS1F400.1335
! Obtain required data value GSS1F400.1336
IF (row.GT.0) THEN GSS1F400.1337
EXPPXI = PPXI(row,element) GSS1F400.1338
END IF GSS1F400.1339
END IF GSS1F401.63
RETURN GSS1F401.64
END GSS1F400.1340
GSS1F400.1341
!--------------------------------------------------------------------- GSS1F400.1342
!+ Character Function to extract names from lookup array PPXC GSS1F400.1343
! GSS1F400.1344
! Function Interface: GSS1F400.1345
CHARACTER*36 FUNCTION EXPPXC(Im_ident,section,item, 9,1GSS1F400.1346
*CALL ARGPPX GSS1F400.1347
& ErrorStatus ,CMESSAGE) GSS1F400.1348
IMPLICIT NONE GSS1F400.1349
! GSS1F400.1350
! Description: GSS1F400.1351
! Extracts a diagnostic name from ppxref lookup array PPXC. GSS1F400.1352
! GSS1F400.1353
! Method: GSS1F400.1354
! The required name is identified by the function arguments GSS1F400.1355
! Im_ident, section, item. The appropriate row in PPXC is found GSS1F400.1356
! from the 3-d pointer array PPXPTR as PPXPTR(m,s,i). GSS1F400.1357
! EXPPX1.21
! Current code owner: S.J.Swarbrick EXPPX1.22
! EXPPX1.23
! History: EXPPX1.24
! Version Date Comment EXPPX1.25
! ======= ==== ======= EXPPX1.26
! 3.5 Mar. 95 Original code. (S.J.Swarbrick) EXPPX1.27
! 4.1 June 96 Error checking improved S.J.Swarbrick GSS1F401.65
! EXPPX1.28
! Code description: EXPPX1.29
! FORTRAN 77 + common Fortran 90 extensions. EXPPX1.30
! Written to UM programming standards version 7. EXPPX1.31
! EXPPX1.32
! System component covered: EXPPX1.33
! System task: Sub-Models Project EXPPX1.34
! EXPPX1.35
! Global Variables: EXPPX1.36
*CALL CSUBMODL EXPPX1.38
*CALL CPPXREF EXPPX1.39
*CALL PPXLOOK EXPPX1.41
EXPPX1.42
! Function arguments: EXPPX1.43
! Scalar arguments with intent(in): GSS1F401.66
INTEGER Im_ident ! Internal model identifier (absolute) GSS1F400.1358
INTEGER section ! STASH section no. EXPPX1.114
INTEGER item ! STASH item no. EXPPX1.115
EXPPX1.116
! Scalar arguments with intent(out): EXPPX1.117
CHARACTER*80 CMESSAGE GSS9F402.167
EXPPX1.120
! Local scalars EXPPX1.121
INTEGER row ! Row no. in PPXC array EXPPX1.123
INTEGER I ! Loop counter EXPPX1.124
INTEGER Im_index ! Internal model index GSS1F400.1359
EXPPX1.125
! Error status: EXPPX1.126
INTEGER ErrorStatus !+ve = fatal error EXPPX1.127
EXPPX1.128
!- End of Header --------------------------------------------------- EXPPX1.129
EXPPX1.130
IF (Im_ident.LE.0 .OR. section.LT.0 .OR. item.LE.0) THEN GSS1F400.1360
IF (Im_ident.LE.0) WRITE(6,*) 'EXPPXC: INVALID Im_ident' GSS1F400.1361
IF (section .LT.0) WRITE(6,*) 'EXPPXC: INVALID SECTION NO.' GSS1F400.1362
IF (item .LE.0) WRITE(6,*) 'EXPPXC: INVALID ITEM NO.' GSS1F400.1363
WRITE(6,*) GSS1F400.1364
& 'Im_ident ',Im_ident,' section ',section,' item ',item GSS1F400.1365
ErrorStatus=1 GSS1F401.67
CMESSAGE='ERROR EXPPXC: INVALID STASH RECORD ID' GSS1F401.68
ELSE GSS1F401.69
GSS1F400.1367
! Obtain row no. in PPXC array EXPPX1.131
*IF DEF,RECON GSS1F400.1368
row = PPXPTR(Im_ident,section,item) GSS1F400.1369
IF (ROW.NE.0) THEN GSS1F400.1370
*ELSE GSS1F400.1371
Im_index = INTERNAL_MODEL_INDEX(Im_ident) GSS1F400.1372
row = PPXPTR(Im_index,section,item) GSS1F400.1373
IF (row.LE.0) THEN GSS1F400.1374
WRITE(6,*) 'ERROR in EXPPXC: INVALID row VALUE: ',row GSS1F401.70
WRITE(6,*) 'Model,Sec,Item: ',Im_ident,section,item GSS1F400.1376
! ErrorStatus = 1 GSS1F400.1378
! CMESSAGE='ERROR EXPPXC: INVALID row VALUE' GSS1F401.71
END IF GSS1F400.1380
*ENDIF GSS1F400.1381
EXPPX1.132
! Obtain required name EXPPX1.137
EXPPX1.138
IF (row.GT.0) THEN GSS1F400.1382
DO I = 1,PPXREF_CHARLEN GSS1F400.1383
EXPPXC(I:I) = PPXC(row,I) GSS1F400.1384
END DO GSS1F400.1385
END IF GSS1F400.1386
*IF DEF,RECON EXPPX1.142
ELSE IF ((ITEM.GE.177.AND.ITEM.LE.179).OR. EXPPX1.143
& (ITEM.GE.301.AND.ITEM.LE.324)) THEN EXPPX1.144
ErrorStatus=100 EXPPX1.145
ELSE EXPPX1.146
ErrorStatus=101 EXPPX1.147
END IF EXPPX1.148
*ENDIF EXPPX1.149
END IF GSS1F401.72
RETURN GSS1F401.73
END EXPPX1.150
EXPPX1.151
!--------------------------------------------------------------------- EXPPX1.152
*ENDIF EXPPX1.153