SUBROUTINE ST_DIAG2( NUM_STASH_LEVELSDA,INT16, 2,7@DYALLOC.3294
& P_FIELDDA,P_LEVELSDA,TR_VARSDA, ADP0F401.62
*CALL ARGSIZE 
@DYALLOC.3295
*CALL ARGD1 @DYALLOC.3296
*CALL ARGDUMA @DYALLOC.3297
*CALL ARGDUMO @DYALLOC.3298
*CALL ARGDUMW GKR1F401.269
*CALL ARGSTS @DYALLOC.3299
*CALL ARGPTRA @DYALLOC.3300
*CALL ARGPTRO @DYALLOC.3301
*CALL ARGCONA @DYALLOC.3302
*CALL ARGPPX GKR0F305.996
*CALL ARGFLDPT GSM1F405.460
& ICODE,CMESSAGE) @DYALLOC.3303
@DYALLOC.3304
IMPLICIT NONE ST_DIA21.28
C*L ST_DIA21.29
*CALL CMAXSIZE @DYALLOC.3305
*CALL CSUBMODL GSS1F305.939
*CALL TYPSIZE @DYALLOC.3306
*CALL TYPD1 @DYALLOC.3307
*CALL TYPDUMA @DYALLOC.3308
*CALL TYPDUMO @DYALLOC.3309
*CALL TYPDUMW GKR1F401.270
*CALL TYPSTS @DYALLOC.3310
*CALL TYPPTRA @DYALLOC.3311
*CALL TYPPTRO @DYALLOC.3312
*CALL TYPCONA @DYALLOC.3313
*CALL PPXLOOK GKR0F305.997
*CALL TYPFLDPT GSM1F405.461
ST_DIA21.30
INTEGER ST_DIA21.31
& INT16, ! Dummy variable for STASH_MAXLEN(16) ST_DIA21.32
& ICODE, ! Out return code : 0 Normal exit ST_DIA21.33
C ! : >0 Error exit ST_DIA21.34
& NUM_STASH_LEVELSDA! Extra copy NUM_STASH_LEVELS to allow @DYALLOC.3314
C ! workspace to be dynamically allocated ST_DIA21.36
& ,P_FIELDDA ! No. of points in field ( " ) ANF1F304.12
& ,P_LEVELSDA ! No. of levels (for port.dyn.allocn.) ANF1F304.13
& ,TR_VARSDA ! No. of tracers (for port.dyn.allocn.) ADP0F401.63
ST_DIA21.37
CHARACTER*(80) TS150793.191
& CMESSAGE ! Out error message if ICODE > 0 ST_DIA21.39
ST_DIA21.40
*CALL CHSUNITS RS030293.232
*CALL CCONTROL ST_DIA21.45
*CALL C_R_CP CW151293.4
*CALL C_ETA_PMSL GDR3F404.2
*CALL CTRACERA ADP0F401.64
ST_DIA21.46
CL External subroutines called ST_DIA21.47
ST_DIA21.48
EXTERNAL ST_DIA21.49
& STASH, ST_DIA21.50
& PHY_DIAG, ST_DIA21.51
& TIMER ST_DIA21.52
ST_DIA21.53
CL Locally dynamically allocated work area ST_DIA21.54
ST_DIA21.55
REAL ST_DIA21.56
& STASHWORK(INT16), ST_DIA21.57
& T_P_PRESS(NUM_STASH_LEVELSDA), @DYALLOC.3315
& HTS_PRESS(NUM_STASH_LEVELSDA), @DYALLOC.3316
& REL_HUMID_PRESS(NUM_STASH_LEVELSDA), @DYALLOC.3317
& WBPT_PRESS(NUM_STASH_LEVELSDA), @DYALLOC.3318
& TH_ADV_PRESS(NUM_STASH_LEVELSDA), @DYALLOC.3319
& PRESS_LEVS(NUM_STASH_LEVELSDA), ASW3F304.3
& TR_PRESS(TR_VARSDA+1,NUM_STASH_LEVELSDA), ADP0F401.65
& HEIGHT(P_FIELDDA,P_LEVELSDA) ASW3F304.4
ST_DIA21.64
C Local variables ST_DIA21.65
ST_DIA21.66
INTEGER ST_DIA21.67
& I,J, CW151293.5
& NI, ST_DIA21.69
& K, ST_DIA21.70
& ISL, ST_DIA21.71
& BL, ST_DIA21.72
& TL, ST_DIA21.73
& LEVEL, ASW3F304.5
& LAST_POINT, ASW3F304.6
& FIRST_POINT ASW3F304.7
& ,ITR ADP0F404.3
& ,STASH_TR_FIRST ADP0F401.66
& ,STASH_TR_LAST ADP0F401.67
& ,im_ident ! Internal Model Identifier GDR4F305.222
& ,im_index ! Internal Model Index for Stash arrays GDR4F305.223
ST_DIA21.75
INTEGER ST_DIA21.76
& T_P_LEVS, ST_DIA21.77
& HTS_LEVS, H2_P_LEVS, ST_DIA21.78
& REL_HUMID_LEVS, ST_DIA21.79
& WBPT_LEVS, ST_DIA21.80
& TH_ADV_P_LEVS ST_DIA21.82
& ,TR_PRESS_LEVS(TR_VARSDA+1) ADP0F401.68
& ,TR_P_FIELD_DA ! P_FIELD for DA of tracer fields ADP0F401.69
ST_DIA21.83
INTEGER ST_DIA21.84
& H2_IND(NUM_STASH_LEVELSDA) @DYALLOC.3321
ST_DIA21.86
INTEGER ST_DIA21.87
& PT_TRACER(TR_VARSDA+1) ADP0F401.70
INTEGER ADP0F401.71
& PT201,PT202,PT203,PT204,PT205,PT206,PT207,PT208,PT209, ST_DIA21.88
& PT210,PT211,PT212,PT213,PT214,PT215,PT216,PT217,PT218,PT219, ST_DIA21.89
& PT220,PT221,PT222,PT223,PT224,PT225 ASW3F304.8
ST_DIA21.91
REAL CW151293.9
& EW_SPACE, ST_DIA21.93
& NS_SPACE ST_DIA21.94
LOGICAL ADP0F401.72
& SF_TRACER(TR_VARSDA+1) ADP0F401.73
ASW3F304.9
CL Initialisation ASW3F304.10
FIRST_POINT=FIRST_FLD_PT GSM1F405.462
LAST_POINT=LAST_P_FLD_PT GSM1F405.463
ASW3F304.13
CL Internal Structure: ST_DIA21.95
ST_DIA21.96
! Set to atmosphere internal model GDR4F305.224
im_ident = atmos_im GDR4F305.225
im_index = internal_model_index(im_ident) GDR4F305.226
GDR4F305.227
ST_DIA21.97
CL----- Calculate additional diagnostic quantities------------------ ST_DIA21.98
ST_DIA21.99
CL------------ Extract required pressures for T_P ---------------------- ST_DIA21.100
NS_SPACE=A_REALHD(2) ST_DIA21.101
EW_SPACE=A_REALHD(1) ST_DIA21.102
ST_DIA21.103
ISL=STINDEX(1,203,16,im_index) GDR4F305.228
IF(ISL.GT.0) THEN ST_DIA21.105
NI=-STLIST(10,ISL) ST_DIA21.106
T_P_LEVS=STASH_LEVELS(1,NI) ST_DIA21.107
DO K =1,T_P_LEVS ST_DIA21.108
T_P_PRESS(K)=STASH_LEVELS(K+1,NI)/1000.0 ST_DIA21.109
ENDDO ST_DIA21.110
ELSE ST_DIA21.111
T_P_LEVS=1 ST_DIA21.112
END IF ST_DIA21.113
ST_DIA21.114
CL------------ Extract required pressures for Heights ------------------ ST_DIA21.115
ST_DIA21.116
ISL=STINDEX(1,202,16,im_index) GDR4F305.229
IF(ISL.GT.0) THEN ST_DIA21.118
NI=-STLIST(10,ISL) ST_DIA21.119
HTS_LEVS=STASH_LEVELS(1,NI) ST_DIA21.120
DO K =1,HTS_LEVS ST_DIA21.121
HTS_PRESS(K)=STASH_LEVELS(K+1,NI)/1000.0 ST_DIA21.122
ENDDO ST_DIA21.123
ELSE ST_DIA21.124
HTS_LEVS=1 ST_DIA21.125
END IF ST_DIA21.126
ST_DIA21.127
ST_DIA21.128
CL------------ Extract required pressures for Humidities --------------- ST_DIA21.129
ST_DIA21.130
ISL=STINDEX(1,204,16,im_index) GDR4F305.230
IF(ISL.GT.0) THEN ST_DIA21.132
IF(STLIST(10,ISL).LT.0) THEN ST_DIA21.133
IF(STLIST(11,ISL).EQ.2) THEN ST_DIA21.134
NI=-STLIST(10,ISL) ST_DIA21.135
REL_HUMID_LEVS=STASH_LEVELS(1,NI) ST_DIA21.136
DO K =1,REL_HUMID_LEVS ST_DIA21.137
REL_HUMID_PRESS(K)=STASH_LEVELS(K+1,NI)/1000.0 ST_DIA21.138
ENDDO ST_DIA21.139
ELSE ST_DIA21.140
CMESSAGE='ST_DIAG2 : Level not pressure for REL_HUMID' ST_DIA21.141
ICODE=1 ST_DIA21.142
RETURN ST_DIA21.143
END IF ST_DIA21.144
ELSE ST_DIA21.145
CMESSAGE='ST_DIAG2 : Level not a levels list for REL_HUMID' ST_DIA21.146
ICODE=1 ST_DIA21.147
RETURN ST_DIA21.148
END IF ST_DIA21.149
ELSE ST_DIA21.150
REL_HUMID_LEVS=1 ST_DIA21.151
END IF ST_DIA21.152
ST_DIA21.153
ST_DIA21.154
ST_DIA21.155
CL------------ Extract required pressures for Wet bulb pot temp--------- ST_DIA21.156
ST_DIA21.157
ISL=STINDEX(1,205,16,im_index) GDR4F305.231
IF(ISL.GT.0) THEN ST_DIA21.159
IF(STLIST(10,ISL).LT.0) THEN ST_DIA21.160
IF(STLIST(11,ISL).EQ.2) THEN ST_DIA21.161
NI=-STLIST(10,ISL) ST_DIA21.162
WBPT_LEVS=STASH_LEVELS(1,NI) ST_DIA21.163
DO K =1,WBPT_LEVS ST_DIA21.164
WBPT_PRESS(K)=STASH_LEVELS(K+1,NI)/1000.0 ST_DIA21.165
ENDDO ST_DIA21.166
ELSE ST_DIA21.167
CMESSAGE='ST_DIAG2 : Level not pressure for WBPT' ST_DIA21.168
ICODE=1 ST_DIA21.169
RETURN ST_DIA21.170
END IF ST_DIA21.171
ELSE ST_DIA21.172
CMESSAGE='ST_DIAG2 : Level not a levels list for WBPT' ST_DIA21.173
ICODE=1 ST_DIA21.174
RETURN ST_DIA21.175
END IF ST_DIA21.176
ELSE ST_DIA21.177
WBPT_LEVS=1 ST_DIA21.178
END IF ST_DIA21.179
CL------------ Extract required pressures for Thermal advection -------- ST_DIA21.180
ST_DIA21.181
ISL=STINDEX(1,219,16,im_index) GDR4F305.232
IF(ISL.GT.0) THEN ST_DIA21.183
IF(STLIST(10,ISL).LT.0) THEN ST_DIA21.184
IF(STLIST(11,ISL).EQ.2) THEN ST_DIA21.185
NI=-STLIST(10,ISL) ST_DIA21.186
TH_ADV_P_LEVS=STASH_LEVELS(1,NI) ST_DIA21.187
DO K =1,TH_ADV_P_LEVS ST_DIA21.188
TH_ADV_PRESS(K)=STASH_LEVELS(K+1,NI)/1000.0 ST_DIA21.189
ENDDO ST_DIA21.190
ELSE ST_DIA21.191
CMESSAGE='ST_DIAG2 : Level not pressure for THADV' ST_DIA21.192
ICODE=1 ST_DIA21.193
RETURN ST_DIA21.194
END IF ST_DIA21.195
ELSE ST_DIA21.196
CMESSAGE='ST_DIAG2 : Level not a levels list for THADV' ST_DIA21.197
ICODE=1 ST_DIA21.198
RETURN ST_DIA21.199
END IF ST_DIA21.200
ELSE ST_DIA21.201
TH_ADV_P_LEVS=1 ST_DIA21.202
END IF ST_DIA21.203
ST_DIA21.204
CL------------ Extract required pressures for Tracers ------------------ ADP0F401.74
ADP0F401.75
STASH_TR_FIRST=226 ADP0F401.76
STASH_TR_LAST=254 ADP0F401.77
C ITR is a count of tracers found to be using this diagnostic ADP0F404.4
ITR=0 ADP0F404.5
IF (TR_VARS.GT.0) THEN ADP0F404.6
ADP0F404.7
C Initialize PT_TRACER and SF_TRACER arrays ADP0F404.8
DO I=1,TR_VARS ADP0F404.9
PT_TRACER(I)=1 ADP0F404.10
SF_TRACER(I)=.FALSE. ADP0F404.11
END DO ADP0F404.12
ADP0F404.13
DO J=STASH_TR_FIRST,STASH_TR_LAST ADP0F401.79
ISL=STINDEX(1,J,16,im_index) ADP0F401.80
IF(ISL.GT.0) THEN ADP0F401.81
IF(STLIST(10,ISL).LT.0) THEN ADP0F401.82
IF(STLIST(11,ISL).EQ.2) THEN ADP0F401.83
ITR=ITR+1 ADP0F404.14
NI=-STLIST(10,ISL) ADP0F401.85
TR_PRESS_LEVS(ITR)=STASH_LEVELS(1,NI) ADP0F404.15
DO K=1,TR_PRESS_LEVS(ITR) ADP0F404.16
TR_PRESS(ITR,K)=STASH_LEVELS(K+1,NI)/1000.0 ADP0F404.17
ENDDO ADP0F401.89
PT_TRACER(ITR)=SI(J,16,im_index) ADP0F404.18
SF_TRACER(ITR)=SF(J,16) ADP0F404.19
ELSE ADP0F401.92
CMESSAGE='ST_DIAG2 : Level not pressure for Tracers' ADP0F401.93
ICODE=1 ADP0F401.94
RETURN ADP0F401.95
END IF ADP0F401.96
ELSE ADP0F401.97
CMESSAGE='ST_DIAG2 : Level not a levels list for Tracers' ADP0F401.98
ICODE=1 ADP0F401.99
RETURN ADP0F401.100
END IF ADP0F401.101
END IF ADP0F401.102
END DO ADP0F401.103
END IF ADP0F404.20
ADP0F401.104
C Set last (or only) values in tracer pointer arrays ADP0F401.105
PT_TRACER(TR_VARS+1)=1 ADP0F401.106
SF_TRACER(TR_VARS+1)=.FALSE. ADP0F401.107
ADP0F401.108
C Set size of TR_P_FIELD_DA depending on whether any tracers ADP0F404.21
C are using this diagnostic. (Used for dynamic allocation of ADP0F404.22
C tracer arrays in phy_diag). ADP0F404.23
IF (ITR.GT.0) THEN ADP0F404.24
TR_P_FIELD_DA=P_FIELD ADP0F401.113
ELSE ADP0F401.114
TR_P_FIELD_DA=1 ADP0F401.115
END IF ADP0F404.25
ADP0F401.117
CL----- check height available for calculation of height**2 ----------- ST_DIA21.205
ST_DIA21.206
ST_DIA21.207
IF (SF(224,16)) THEN ST_DIA21.208
IF (.NOT.SF(202,16)) THEN ST_DIA21.209
CMESSAGE='ST_DIAG2 : ERROR h**2 requires H at same timestep' ST_DIA21.210
ICODE=1 ST_DIA21.211
GOTO 999 ST_DIA21.212
ELSE ST_DIA21.213
ISL=STINDEX(1,224,16,im_index) GDR4F305.233
IF(ISL.GT.0) THEN ST_DIA21.215
NI=-STLIST(10,ISL) ST_DIA21.216
H2_P_LEVS=STASH_LEVELS(1,NI) ST_DIA21.217
DO K =1,H2_P_LEVS ST_DIA21.218
PRESS_LEVS(K)=STASH_LEVELS(K+1,NI)/1000.0 ST_DIA21.219
DO I=1,HTS_LEVS ST_DIA21.220
IF(PRESS_LEVS(K).EQ.HTS_PRESS(I)) THEN ST_DIA21.221
H2_IND(k)=I ST_DIA21.222
ENDIF ST_DIA21.223
ENDDO ST_DIA21.224
ENDDO ST_DIA21.225
ELSE ST_DIA21.226
H2_P_LEVS=1 ST_DIA21.227
END IF ST_DIA21.228
ENDIF ST_DIA21.229
ELSE ST_DIA21.230
H2_P_LEVS=1 ST_DIA21.231
END IF ST_DIA21.232
ST_DIA21.233
ST_DIA21.234
IF(SF(202,16)) THEN ST_DIA21.235
SF(201,16)=.TRUE. !making sure model half heights switched ST_DIA21.236
ENDIF !on if heights on pressure surface is reqd ST_DIA21.237
PT202=SI(202,16,im_index) GDR4F305.234
PT203=SI(203,16,im_index) GDR4F305.235
PT204=SI(204,16,im_index) GDR4F305.236
PT205=SI(205,16,im_index) GDR4F305.237
PT206=SI(206,16,im_index) GDR4F305.238
PT207=SI(207,16,im_index) GDR4F305.239
PT208=SI(208,16,im_index) GDR4F305.240
PT209=SI(209,16,im_index) GDR4F305.241
PT210=SI(210,16,im_index) GDR4F305.242
PT211=SI(211,16,im_index) GDR4F305.243
PT212=SI(212,16,im_index) GDR4F305.244
PT213=SI(213,16,im_index) GDR4F305.245
PT214=SI(214,16,im_index) GDR4F305.246
PT215=SI(215,16,im_index) GDR4F305.247
PT216=SI(216,16,im_index) GDR4F305.248
PT217=SI(217,16,im_index) GDR4F305.249
PT218=SI(218,16,im_index) GDR4F305.250
PT219=SI(219,16,im_index) GDR4F305.251
PT220=SI(220,16,im_index) GDR4F305.252
PT221=SI(221,16,im_index) GDR4F305.253
PT222=SI(222,16,im_index) GDR4F305.254
PT223=SI(223,16,im_index) GDR4F305.255
PT224=SI(224,16,im_index) GDR4F305.256
PT225=SI(225,16,im_index) GDR4F305.257
ST_DIA21.263
IF(LTIMER) THEN ST_DIA21.264
CALL TIMER('PHY_DIAG',3) ST_DIA21.265
END IF ST_DIA21.266
ST_DIA21.267
! Initialise STASHWORK as PHY_DIAG avoids MPP halo calculations GSM1F405.464
!* DIR$ CACHE_BYPASS STASHWORK GSM1F405.465
DO I=1,INT16 GSM1F405.466
STASHWORK(I)=0. GSM1F405.467
ENDDO GSM1F405.468
GSM1F405.469
CALL PHY_DIAG( ST_DIA21.268
*CALL ARGFLDPT GSM1F405.470
C Primary data in ST_DIA21.269
ST_DIA21.270
& D1(JPSTAR),D1(JU(1)),D1(JV(1)),D1(JQ(1)), ST_DIA21.271
& D1(JTHETA(1)),D1(JOROG),D1(JP_EXNER(1)),D1(JLAND),D1(JTSTAR), @DYALLOC.3322
& D1(JTRACER(1,1)), ADP0F401.118
ST_DIA21.273
C Primary data constants ST_DIA21.274
ST_DIA21.275
& U_ROWS,P_ROWS,ROW_LENGTH,P_LEVELS,Q_LEVELS,P_FIELD,U_FIELD, ST_DIA21.276
& A_LEVDEPC(JAK),A_LEVDEPC(JBK),AKH,BKH,EW_SPACE,NS_SPACE, ST_DIA21.277
& SEC_U_LATITUDE, ST_DIA21.278
& TR_LEVELS,TR_VARS,TR_P_FIELD_DA, ADP0F401.119
ST_DIA21.279
C STASH variables ST_DIA21.280
ST_DIA21.281
& T_P_PRESS,HTS_PRESS,REL_HUMID_PRESS,WBPT_PRESS,TH_ADV_PRESS, ST_DIA21.282
& TR_PRESS, ADP0F401.120
& H2_IND, ST_DIA21.283
ST_DIA21.284
C DIAGNOSTICS OUT ST_DIA21.285
ST_DIA21.286
& STASHWORK(PT202),STASHWORK(PT203),STASHWORK(PT204), ST_DIA21.287
& STASHWORK(PT205),STASHWORK(PT206),STASHWORK(PT207), ST_DIA21.288
& STASHWORK(PT208),STASHWORK(PT209),STASHWORK(PT210), ST_DIA21.289
& STASHWORK(PT211),STASHWORK(PT212),STASHWORK(PT213), ST_DIA21.290
& STASHWORK(PT214),STASHWORK(PT215),STASHWORK(PT216), ST_DIA21.291
& STASHWORK(PT217),STASHWORK(PT218),STASHWORK(PT219), ST_DIA21.292
& STASHWORK(PT220),STASHWORK(PT221),STASHWORK(PT222), ST_DIA21.293
& STASHWORK(PT223),STASHWORK(PT224),HEIGHT, ASW3F304.15
& STASHWORK,INT16,PT_TRACER, ADP0F401.121
ST_DIA21.295
C Diagnostic lengths ST_DIA21.296
ST_DIA21.297
& T_P_LEVS,HTS_LEVS,REL_HUMID_LEVS,WBPT_LEVS,TH_ADV_P_LEVS, ST_DIA21.298
& H2_P_LEVS, ST_DIA21.299
& TR_PRESS_LEVS,NUM_STASH_LEVELSDA, ADP0F401.122
ST_DIA21.300
C Diagnostic logical indicators ST_DIA21.301
ST_DIA21.302
& SF(201,16),SF(202,16),SF(203,16),SF(204,16),SF(205,16), ST_DIA21.303
& SF(206,16),SF(207,16),SF(208,16),SF(209,16),SF(210,16), ST_DIA21.304
& SF(211,16),SF(212,16),SF(213,16),SF(214,16),SF(215,16), ST_DIA21.305
& SF(216,16),SF(217,16),SF(218,16),SF(219,16),SF(220,16), ST_DIA21.306
& SF(221,16),SF(222,16),SF(223,16),SF(224,16),SF(225,16), ASW3F304.16
& SF_TRACER, ADP0F401.123
& LEVNO_PMSL_CALC, L_VINT_TP, L_LSPICE, GDR4F405.12
& ICODE, CMESSAGE) GDR4F405.13
GDR4F405.14
IF (SF(225,16)) THEN ASW3F304.17
CALL COPYDIAG_3D(STASHWORK(SI(225,16,im_index)),HEIGHT, GDR4F305.258
& FIRST_POINT,LAST_POINT,P_FIELD,ROW_LENGTH, ASW3F304.19
& P_LEVELS,STLIST(1,STINDEX(1,225,16,im_index)), GDR4F305.259
& LEN_STLIST,STASH_LEVELS,NUM_STASH_LEVELS+1, GDR4F305.260
& im_ident,16,225, GPB1F403.1277
*CALL ARGPPX GPB1F403.1278
& ICODE,CMESSAGE) ASW3F304.22
ENDIF ASW3F304.23
ST_DIA21.309
IF(LTIMER) THEN ST_DIA21.310
CALL TIMER('PHY_DIAG',4) ST_DIA21.311
END IF ST_DIA21.312
ST_DIA21.313
IF(LTIMER) THEN ST_DIA21.314
CALL TIMER('STASH ',3) ST_DIA21.315
END IF ST_DIA21.316
ST_DIA21.317
CALL STASH(a_sm,a_im,16,STASHWORK, GKR0F305.998
*CALL ARGSIZE @DYALLOC.3324
*CALL ARGD1 @DYALLOC.3325
*CALL ARGDUMA @DYALLOC.3326
*CALL ARGDUMO @DYALLOC.3327
*CALL ARGDUMW GKR1F401.271
*CALL ARGSTS @DYALLOC.3328
*CALL ARGPPX GKR0F305.999
& ICODE,CMESSAGE) @DYALLOC.3332
ST_DIA21.319
IF(LTIMER) THEN ST_DIA21.320
CALL TIMER('STASH ',4) ST_DIA21.321
END IF ST_DIA21.322
ST_DIA21.323
999 CONTINUE ST_DIA21.324
RETURN ST_DIA21.325
END ST_DIA21.326
*ENDIF ST_DIA21.327