SUBROUTINE EXTDIAG (DATA,SI,SF,I1,I2, 16,2EXTDIA1A.29
& LEN_DATA,ROW_LENGTH,STLIST,LEN_STLIST, EXTDIA1A.30
& STINDEX,LEN_STINDEX, EXTDIA1A.31
& STASH_LEVELS, LEN_STASHLEVELS, EXTDIA1A.32
& STASH_PSEUDO_LEVELS, NUM_STASH_PSEUDO, EXTDIA1A.33
& im_ident,is, GPB1F403.1311
*CALL ARGPPX 
GPB1F403.1312
& ICODE, CMESSAGE) EXTDIA1A.34
EXTDIA1A.35
IMPLICIT NONE EXTDIA1A.36
EXTDIA1A.37
INTEGER EXTDIA1A.38
& I1, ! Item numbers of diagnostic EXTDIA1A.39
& I2, ! values to be extended EXTDIA1A.40
& SI(I2), ! Address of fields in DATA array EXTDIA1A.41
& LEN_DATA, ! Length of input data array EXTDIA1A.42
& ROW_LENGTH, ! Number of points in row, assumed the EXTDIA1A.43
C ! same for all fields. EXTDIA1A.44
& LEN_STLIST, ! EXTDIA1A.45
& STLIST(LEN_STLIST,*), !STASH list EXTDIA1A.46
& LEN_STINDEX, EXTDIA1A.47
& STINDEX(LEN_STINDEX,I2), !STASH index EXTDIA1A.48
& LEN_STASHLEVELS, ! EXTDIA1A.49
& STASH_LEVELS(LEN_STASHLEVELS,*), ! STASH levels list. EXTDIA1A.50
& NUM_STASH_PSEUDO, ! Size of: EXTDIA1A.51
& STASH_PSEUDO_LEVELS(NUM_STASH_PSEUDO+1,*), ! STASH pseudo EXTDIA1A.52
C ! levels list EXTDIA1A.53
& ICODE ! Return code =0 Normal exit EXTDIA1A.54
C >1 Error EXTDIA1A.55
INTEGER GPB1F403.1313
& im_ident ! IN: internal model identifier of STASH data GPB1F403.1314
&, is ! IN: section number of STASH data GPB1F403.1315
EXTDIA1A.56
CHARACTER*80 CMESSAGE TS150793.59
EXTDIA1A.58
REAL EXTDIA1A.59
& DATA(LEN_DATA)! Input data EXTDIA1A.60
EXTDIA1A.61
LOGICAL EXTDIA1A.62
& SF(I2) ! Logical switch set .TRUE. if field to EXTDIA1A.63
C ! be extended. EXTDIA1A.64
C* EXTDIA1A.65
*CALL CSUBMODL GPB1F403.1316
*CALL CPPXREF GPB1F403.1317
*CALL PPXLOOK GPB1F403.1318
*IF DEF,MPP GPB1F403.1319
*CALL PARVARS GPB1F403.1320
*ENDIF GPB1F403.1321
*CALL AMAXSIZE GPB1F403.1322
C Local variables EXTDIA1A.66
EXTDIA1A.67
REAL EXTDIA1A.68
& NP_MEAN(P_LEVELS_MAX) ! NP mean value GPB1F403.1323
&, SP_MEAN(P_LEVELS_MAX) ! SP mean value GPB1F403.1324
EXTDIA1A.71
INTEGER EXTDIA1A.72
& ITEM, ! STASH item number EXTDIA1A.73
& FIELD, ! Length of individual diagnostic field EXTDIA1A.74
& I, ! EXTDIA1A.75
& J, ! LAM E boundary pointer EXTDIA1A.76
& K, ! EXTDIA1A.77
& INDEX, ! Position within STASH list, refering to EXTDIA1A.78
C ! current ITEM EXTDIA1A.79
& LEVELS, ! EXTDIA1A.80
& START ! Position of first point of field at level EXTDIA1A.81
C ! to be processed. EXTDIA1A.82
GPB1F403.1325
*IF DEF,MPP GPB1F403.1326
INTEGER GPB1F403.1327
& gr ! grid type of field being processed GPB1F403.1328
&, fld_type ! field type (P or U) of the field being processed GPB1F403.1329
&, sp_row_start ! start point of south pole GPB1F403.1330
&, np_row_start ! start point of north pole GPB1F403.1331
&, lvl,lsl,lso,nv,info ! arguments to RVECSUMR GPB1F403.1332
GPB1F403.1333
! Functions: GPB1F403.1334
INTEGER GPB1F403.1335
& EXPPXI,GET_FLD_TYPE GPB1F403.1336
GPB1F403.1337
*ENDIF GPB1F403.1338
EXTDIA1A.83
DO ITEM=I1,I2 EXTDIA1A.84
IF(SF(ITEM)) THEN EXTDIA1A.85
EXTDIA1A.86
CL Calculate number of levels at which each diagnostic is held EXTDIA1A.87
EXTDIA1A.88
INDEX=STINDEX(1,ITEM) EXTDIA1A.89
EXTDIA1A.90
IF(STLIST(10,INDEX).LT.0) THEN EXTDIA1A.91
EXTDIA1A.92
C Levels list present EXTDIA1A.93
EXTDIA1A.94
LEVELS=STASH_LEVELS(1,-STLIST(10,INDEX)) EXTDIA1A.95
ELSEIF(STLIST(10,INDEX).LT.100) THEN EXTDIA1A.96
EXTDIA1A.97
C Top and bottom levels EXTDIA1A.98
EXTDIA1A.99
LEVELS=STLIST(11,INDEX)-STLIST(10,INDEX)+1 EXTDIA1A.100
IF(LEVELS.LE.0) THEN EXTDIA1A.101
ICODE=1 EXTDIA1A.102
CMESSAGE='EXTDIAG: Illegal levels limits.' EXTDIA1A.103
WRITE(6,*)'EXTDIAG illegal levels, STLIST(10,11)=', GIE0F403.148
& STLIST(10,INDEX),STLIST(11,INDEX) EXTDIA1A.105
WRITE(6,*)' SECTION AND ITEM NUMBER ', GIE0F403.149
* STLIST(2,INDEX),STLIST(1,INDEX) EXTDIA1A.107
RETURN EXTDIA1A.108
END IF EXTDIA1A.109
ELSE EXTDIA1A.110
LEVELS=1 EXTDIA1A.111
END IF EXTDIA1A.112
EXTDIA1A.113
C The 26th entry of STLIST indicates if the diagnostic is input to STASH EXTDIA1A.114
C on pseudo-levels and, if so, which - zero for none, otherwise the EXTDIA1A.115
C number of the list of pseudo-levels the data will be input to STASH EXTDIA1A.116
C on, and the first element of this list is the total number in it. EXTDIA1A.117
C (NUM_PSEUDO_LEVELS being the maximum value over all pseudo-levels EXTDIA1A.118
C lists.) So LEVELS, which is currently the number of physical levels EXTDIA1A.119
C the data is on, must be multiplied by this to give the number of EXTDIA1A.120
C combinations of physical levels and pseudo-levels. EXTDIA1A.121
EXTDIA1A.122
IF ( STLIST(26,INDEX) .GT. 0 ) EXTDIA1A.123
& LEVELS = LEVELS * STASH_PSEUDO_LEVELS(1,STLIST(26,INDEX)) EXTDIA1A.124
EXTDIA1A.125
CL Define length of field EXTDIA1A.126
EXTDIA1A.127
*IF -DEF,MPP GPB1F403.1339
FIELD=STLIST(17,INDEX)/LEVELS EXTDIA1A.128
*ELSE GPB1F403.1340
! Find out the gridtype of the field GPB1F403.1341
GR = EXPPXI(im_ident,IS,ITEM,ppx_grid_type, GPB1F403.1342
*CALL ARGPPX GPB1F403.1343
& ICODE,CMESSAGE) GPB1F403.1344
GPB1F403.1345
IF (ICODE .GT. 0) GOTO 9999 GPB1F403.1346
GPB1F403.1347
! and use this to find the field type (p field or u field) GPB1F403.1348
GPB1F403.1349
fld_type=GET_FLD_TYPE(GR) GPB1F403.1350
GPB1F403.1351
IF (atbase) THEN GPB1F403.1352
IF (fld_type .EQ. fld_type_p) THEN GPB1F403.1353
sp_row_start=(lasize(2)-Offy-2)*ROW_LENGTH+Offx+1 GPB1F403.1354
ELSEIF (fld_type .EQ. fld_type_u) THEN GPB1F403.1355
sp_row_start=(lasize(2)-Offy-3)*ROW_LENGTH+Offx+1 GPB1F403.1356
ELSE GPB1F403.1357
ICODE=1 GPB1F403.1358
CMESSAGE='EXTDIAG : Unrecognized field type' GPB1F403.1359
GOTO 9999 GPB1F403.1360
ENDIF GPB1F403.1361
ENDIF GPB1F403.1362
IF (attop) GPB1F403.1363
& np_row_start=(Offy+1)*ROW_LENGTH+1+Offx GPB1F403.1364
GPB1F403.1365
FIELD=lasize(1)*lasize(2) GPB1F403.1366
GPB1F403.1367
*ENDIF GPB1F403.1368
EXTDIA1A.129
CL Extend diagnostic to full field EXTDIA1A.130
EXTDIA1A.131
*IF DEF,GLOBAL GPB1F403.1369
*IF DEF,MPP GPB1F403.1370
! Calculate polar mean values GPB1F403.1371
GPB1F403.1372
DO K=1,LEVELS GPB1F403.1373
NP_MEAN(K)=0.0 GPB1F403.1374
SP_MEAN(K)=0.0 GPB1F403.1375
ENDDO GPB1F403.1376
GPB1F403.1377
lvl=FIELD ! size of each field GPB1F403.1378
lsl=ROW_LENGTH-2*Offx ! size of vector to sum GPB1F403.1379
nv=LEVELS ! number of vectors GPB1F403.1380
GPB1F403.1381
IF (attop) THEN GPB1F403.1382
GPB1F403.1383
lso=np_row_start ! start address of vector GPB1F403.1384
GPB1F403.1385
*IF DEF,REPROD GPB1F403.1386
CALL GCG_RVECSUMR(lvl,lsl,lso,nv,DATA(SI(ITEM)), GPB1F403.1387
& gc_proc_row_group,info,NP_MEAN) GPB1F403.1388
*ELSE GPB1F403.1389
CALL GCG_RVECSUMF(lvl,lsl,lso,nv,DATA(SI(ITEM)), GPB1F403.1390
& gc_proc_row_group,info,NP_MEAN) GPB1F403.1391
*ENDIF GPB1F403.1392
DO K=1,LEVELS GPB1F403.1393
NP_MEAN(K)=NP_MEAN(K)/glsize(1) GPB1F403.1394
ENDDO GPB1F403.1395
GPB1F403.1396
ENDIF GPB1F403.1397
GPB1F403.1398
IF (atbase) THEN GPB1F403.1399
GPB1F403.1400
lso=sp_row_start ! start address of vector GPB1F403.1401
GPB1F403.1402
*IF DEF,REPROD GPB1F403.1403
CALL GCG_RVECSUMR(lvl,lsl,lso,nv,DATA(SI(ITEM)), GPB1F403.1404
& gc_proc_row_group,info,SP_MEAN) GPB1F403.1405
*ELSE GPB1F403.1406
CALL GCG_RVECSUMF(lvl,lsl,lso,nv,DATA(SI(ITEM)), GPB1F403.1407
& gc_proc_row_group,info,SP_MEAN) GPB1F403.1408
*ENDIF GPB1F403.1409
DO K=1,LEVELS GPB1F403.1410
SP_MEAN(K)=SP_MEAN(K)/glsize(1) GPB1F403.1411
ENDDO GPB1F403.1412
GPB1F403.1413
ENDIF GPB1F403.1414
*ELSE GPB1F403.1415
GPB1F403.1416
DO K=1,LEVELS GPB1F403.1417
GPB1F403.1418
START=FIELD*(K-1)+SI(ITEM)-1 GPB1F403.1419
GPB1F403.1420
NP_MEAN(K)=0.0 GPB1F403.1421
SP_MEAN(K)=0.0 GPB1F403.1422
GPB1F403.1423
DO I=1,ROW_LENGTH GPB1F403.1424
NP_MEAN(K)=NP_MEAN(K)+ DATA(START+I+ROW_LENGTH) GPB1F403.1425
SP_MEAN(K)=SP_MEAN(K)+ DATA(START+I+FIELD-2*ROW_LENGTH) GPB1F403.1426
ENDDO GPB1F403.1427
GPB1F403.1428
NP_MEAN(K)=NP_MEAN(K)/ROW_LENGTH GPB1F403.1429
SP_MEAN(K)=SP_MEAN(K)/ROW_LENGTH GPB1F403.1430
GPB1F403.1431
ENDDO GPB1F403.1432
GPB1F403.1433
*ENDIF GPB1F403.1434
*ENDIF GPB1F403.1435
DO K=1,LEVELS EXTDIA1A.132
START=FIELD*(K-1)+SI(ITEM)-1 EXTDIA1A.133
EXTDIA1A.134
CL Copy diagnostic information to N and S boundaries EXTDIA1A.135
EXTDIA1A.136
! Update Northern boundary / Pole GPB1F403.1436
*IF DEF,MPP GPB1F403.1437
IF (attop) THEN GPB1F403.1438
!L Initialise unused row GSM1F404.28
! *DIR$ CACHE_BYPASS DATA GPB0F405.201
DO I=1,Offy*ROW_LENGTH GSM1F404.30
DATA(START+I)=0. GSM1F404.31
ENDDO GSM1F404.32
GSM1F404.33
DO I=Offy*ROW_LENGTH+1,(Offy+1)*ROW_LENGTH GPB1F403.1439
*ELSE GPB1F403.1440
DO I=1,ROW_LENGTH GPB1F403.1441
*ENDIF GPB1F403.1442
*IF DEF,GLOBAL GPB1F403.1443
DATA(START+I)=NP_MEAN(K) GPB1F403.1444
*ELSE GPB1F403.1445
DATA(START+I)=DATA(START+I+ROW_LENGTH) GPB1F403.1446
*ENDIF GPB1F403.1447
ENDDO GPB1F403.1448
*IF DEF,MPP GPB1F403.1449
ENDIF GPB1F403.1450
*ENDIF GPB1F403.1451
GPB1F403.1452
! Update Southern boundary / Pole GPB1F403.1453
*IF DEF,MPP GPB1F403.1454
IF (atbase) THEN GPB1F403.1455
!L Initialise unused row GSM1F404.34
! *DIR$ CACHE_BYPASS DATA GPB0F405.202
DO I=sp_row_start+2*ROW_LENGTH-Offx+1, GSM1F404.36
& lasize(1)*lasize(2) GSM1F404.37
DATA(START+I)=0. GSM1F404.38
ENDDO GSM1F404.39
GSM1F404.40
DO I=sp_row_start-Offx+ROW_LENGTH, GPB1F403.1456
& sp_row_start+2*ROW_LENGTH-Offx GPB1F403.1457
*ELSE GPB1F403.1458
DO I=FIELD-ROW_LENGTH+1,FIELD GPB1F403.1459
*ENDIF GPB1F403.1460
*IF DEF,GLOBAL GPB1F403.1461
DATA(START+I)=SP_MEAN(K) GPB1F403.1462
*ELSE GPB1F403.1463
DATA(START+I)=DATA(START+I-ROW_LENGTH) GPB1F403.1464
*ENDIF GPB1F403.1465
ENDDO GPB1F403.1466
*IF DEF,MPP GPB1F403.1467
ENDIF GPB1F403.1468
*ENDIF GPB1F403.1469
GPB1F403.1470
*IF -DEF,GLOBAL GPB1F403.1471
! Update Western boundary GPB1F403.1472
*IF DEF,MPP GPB1F403.1473
IF (atleft) THEN GPB1F403.1474
DO I=Offx+1,FIELD,ROW_LENGTH GPB1F403.1475
*ELSE GPB1F403.1476
DO I=1,FIELD,ROW_LENGTH GPB1F403.1477
*ENDIF GPB1F403.1478
DATA(START+I)=DATA(START+I+1) GPB1F403.1479
ENDDO GPB1F403.1480
*IF DEF,MPP GPB1F403.1481
ENDIF GPB1F403.1482
*ENDIF GPB1F403.1483
GPB1F403.1484
! Update Eastern boundary GPB1F403.1485
*IF DEF,MPP GPB1F403.1486
IF (atright) THEN GPB1F403.1487
DO I=ROW_LENGTH-Offx,FIELD,ROW_LENGTH GPB1F403.1488
*ELSE GPB1F403.1489
DO I=ROW_LENGTH,FIELD,ROW_LENGTH GPB1F403.1490
*ENDIF GPB1F403.1491
DATA(START+I)=DATA(START+I-1) GPB1F403.1492
ENDDO GPB1F403.1493
*IF DEF,MPP GPB1F403.1494
ENDIF GPB1F403.1495
*ENDIF GPB1F403.1496
GPB1F403.1497
*ENDIF GPB1F403.1498
EXTDIA1A.171
END DO EXTDIA1A.172
END IF EXTDIA1A.173
END DO EXTDIA1A.174
EXTDIA1A.175
9999 CONTINUE GPB1F403.1499
RETURN EXTDIA1A.176
END EXTDIA1A.177
*ENDIF EXTDIA1A.178