SUBROUTINE DIAGDESC(seqno,name,stlist,ppxref, 1DIAGDES1.30
& stash_levels,num_stash_levels,num_level_lists, DIAGDES1.31
& stash_pseudo_levels,num_stash_pseudo,num_pseudo_lists, TJ140193.109
& sttabl,nsttims,nsttabl, DIAGDES1.32
& stash_series,stash_series_rec_len,stash_series_len, DIAGDES1.33
& stash_series_index,stash_ser_index_size) DIAGDES1.34
C DIAGDES1.35
IMPLICIT NONE DIAGDES1.36
C DIAGDES1.37
CHARACTER*36 DIAGDES1.38
* name ! IN diagnostic name DIAGDES1.39
INTEGER DIAGDES1.40
* seqno, ! IN sequence number DIAGDES1.41
* stlist(*), ! IN STASHlist record DIAGDES1.42
* ppxref(*) ! IN PPXREF record DIAGDES1.43
C DIAGDES1.44
C STASH levels list information DIAGDES1.45
INTEGER DIAGDES1.46
& num_stash_levels ! IN Max levels in a list DIAGDES1.47
&, num_level_lists ! IN Number of lists DIAGDES1.48
&, stash_levels(num_stash_levels+1,num_level_lists) DIAGDES1.49
C STASH pseudo-levels list information TJ140193.110
INTEGER TJ140193.111
& num_stash_pseudo ! IN Max ps-levs in a list TJ140193.112
&, num_pseudo_lists ! IN No of ps-lev lists TJ140193.113
&, stash_pseudo_levels(num_stash_pseudo+1,num_pseudo_lists) TJ140193.114
C STASH time list information DIAGDES1.50
INTEGER DIAGDES1.51
& nsttims ! IN Max times in a list DIAGDES1.52
&, nsttabl ! IN Number of lists DIAGDES1.53
&, sttabl(nsttims,nsttabl) DIAGDES1.54
C STASH timeseries information DIAGDES1.55
INTEGER DIAGDES1.56
& stash_series_len ! IN Total no of records DIAGDES1.57
&, stash_series_rec_len ! IN Length of each record DIAGDES1.58
&, stash_series(stash_series_rec_len,stash_series_len) DIAGDES1.59
C ! IN array of records DIAGDES1.60
&, stash_ser_index_size ! IN No of index records DIAGDES1.61
&, stash_series_index(2,stash_ser_index_size) DIAGDES1.62
C DIAGDES1.63
*CALL STPARAM 
DIAGDES1.64
*CALL CPPXREF DIAGDES1.65
*CALL CSUBMODL GDR3F305.17
*CALL CHSUNITS GDR3F305.18
*CALL CCONTROL GDR3F305.19
C DIAGDES1.67
C Local variables DIAGDES1.68
C DIAGDES1.69
CHARACTER*132 line,line1,line2 ! Encoded line of information DIAGDES1.70
CHARACTER*80 ch ! Working character string variable DIAGDES1.71
INTEGER i1,i2,k ! Array indices DIAGDES1.72
INTEGER j ! Code value DIAGDES1.73
INTEGER time_list,lev_list ! pointers to time and levels lists DIAGDES1.74
&, plev_list ! pointer to pseudo-level list TJ140193.115
&, tser_list ! pointer to time series record list DIAGDES1.75
INTEGER ntimes ! no of times in a time list DIAGDES1.76
INTEGER packing_profile ! packing profile for output PPfield DIAGDES1.77
C DIAGDES1.78
CL---------------------------------------------------------------------- DIAGDES1.79
CL 0. Write header if sequence no indicates first item DIAGDES1.80
CL DIAGDES1.81
IF (seqno.EQ.1) THEN DIAGDES1.82
WRITE(6,1000) DIAGDES1.83
1000 FORMAT( DIAGDES1.84
* ' ********************************************************'/ DIAGDES1.85
* ' ********************************************************'/ DIAGDES1.86
* ' ** **'/ DIAGDES1.87
* ' ** LIST OF USER-DEFINED DIAGNOSTICS IN THIS RUN **'/ DIAGDES1.88
* ' ** **'/ DIAGDES1.89
* ' ********************************************************'/ DIAGDES1.90
* ' ********************************************************'/ DIAGDES1.91
* ' ** **'/ DIAGDES1.92
* ' ** NOTES: **'/ DIAGDES1.93
* ' ** Time processing details are in timesteps, where **'/ DIAGDES1.94
* ' ** ... represents "for ever". **'/ DIAGDES1.95
* ' ** Spatial processing domain is in gridpoints. **'/ DIAGDES1.96
* ' ** **'/ DIAGDES1.97
* ' ********************************************************'/ DIAGDES1.98
* ' ********************************************************'// DIAGDES1.99
*'================================================================= DIAGDES1.100
*==========================================================') DIAGDES1.101
ENDIF DIAGDES1.102
CL---------------------------------------------------------------------- DIAGDES1.103
CL 1. For each diagnostic processing request in the STASHlist, DIAGDES1.104
CL print the diagnostic name followed by a summary of the processing DIAGDES1.105
CL information on 3 lines. DIAGDES1.106
CL DIAGDES1.107
CL 1.0 If diagnostic is not required for output, exit routine DIAGDES1.108
CL DIAGDES1.109
IF (stlist(st_proc_no_code).EQ.0) GOTO 999 DIAGDES1.110
CL DIAGDES1.111
CL 1.1 Line 1. DIAGDES1.112
CL DIAGDES1.113
line=' ' DIAGDES1.114
C #No DIAGDES1.115
i1=2 DIAGDES1.116
i2=4 DIAGDES1.117
write(ch,'(i3)') seqno DIAGDES1.118
line(i1:i2)=ch(1:1+i2-i1) DIAGDES1.119
C Name DIAGDES1.120
i1=i2+2 DIAGDES1.121
i2=i1+36-1 DIAGDES1.122
line(i1:i2)=name DIAGDES1.123
C Submodel DIAGDES1.124
i1=i2+2 DIAGDES1.125
i2=i1+8-1 DIAGDES1.126
j=stlist(st_sect_no_code) DIAGDES1.127
IF (ppxref(ppx_model_number).EQ.ocean_im) THEN GDR3F305.20
ch=' OCEAN ' DIAGDES1.129
ELSE IF (ppxref(ppx_model_number).EQ. slab_im) THEN GDR3F305.21
ch=' SLAB ' MC261093.29
ELSE IF (ppxref(ppx_model_number).EQ.atmos_im) THEN GDR3F305.22
ch=' ATMOS ' MC261093.31
ELSE IF (ppxref(ppx_model_number).EQ.wave_im) THEN GSS3F401.1
ch=' WAVE ' GSS3F401.2
ELSE DIAGDES1.130
WRITE(6,*)' Error in DIAGDES. Unknown model' MC261093.32
ch=' UNKNOWN' MC261093.33
ENDIF DIAGDES1.132
line(i1:i2)=ch(1:1+i2-i1) DIAGDES1.133
C Item DIAGDES1.134
i1=i2+2 DIAGDES1.135
i2=i1+4-1 DIAGDES1.136
j=stlist(st_item_code) DIAGDES1.137
write(ch,'(i4)') j DIAGDES1.138
line(i1:i2)=ch(1:1+i2-i1) DIAGDES1.139
C Section DIAGDES1.140
i1=i2+2 DIAGDES1.141
i2=i1+7-1 DIAGDES1.142
j=stlist(st_sect_no_code) DIAGDES1.143
write(ch,'(i7)') j DIAGDES1.144
line(i1:i2)=ch(1:1+i2-i1) DIAGDES1.145
C PPfcode DIAGDES1.146
i1=i2+2 DIAGDES1.147
i2=i1+7-1 DIAGDES1.148
j=ppxref(ppx_field_code) DIAGDES1.149
write(ch,'(i7)') j DIAGDES1.150
line(i1:i2)=ch(1:1+i2-i1) DIAGDES1.151
C Datatype DIAGDES1.152
i1=i2+2 DIAGDES1.153
i2=i1+8-1 DIAGDES1.154
j=ppxref(ppx_data_type) DIAGDES1.155
IF (j.EQ.1.OR.j.EQ.4) THEN DIAGDES1.156
ch=' REAL ' DIAGDES1.157
ELSEIF (j.EQ.2.OR.j.EQ.5) THEN DIAGDES1.158
ch='INTEGER ' DIAGDES1.159
ELSEIF (j.EQ.3) THEN DIAGDES1.160
ch='LOGICAL ' DIAGDES1.161
ELSE DIAGDES1.162
ch='UNKNOWN ' DIAGDES1.163
ENDIF DIAGDES1.164
line(i1:i2)=ch(1:1+i2-i1) DIAGDES1.165
C Gridtype DIAGDES1.166
i1=i2+2 DIAGDES1.167
i2=i1+8-1 DIAGDES1.168
j=ppxref(ppx_grid_type) DIAGDES1.169
IF (j.EQ.ppx_atm_nonstd.OR.j.EQ.ppx_ocn_nonstd) THEN GTJ1F304.3
ch=' NONSTD ' DIAGDES1.171
ELSEIF ((j.GT.ppx_atm_nonstd.AND.j.LE.ppx_atm_tsea) .OR. GTJ1F304.4
& j.EQ.ppx_atm_compressed.OR.j.EQ.ppx_atm_ozone) THEN GTJ1F304.5
ch=' P-GRID ' DIAGDES1.173
ELSEIF (j.GE.ppx_atm_uall.AND.j.LE.ppx_atm_usea) THEN GTJ1F304.6
ch=' UV-GRID' DIAGDES1.175
ELSEIF (j.EQ.ppx_atm_cuall.OR.j.EQ.ppx_ocn_cuall) THEN GTJ1F304.7
ch=' CU-GRID' DIAGDES1.177
ELSEIF (j.EQ.ppx_atm_cvall.OR.j.EQ.ppx_ocn_cvall) THEN GTJ1F304.8
ch=' CV-GRID' DIAGDES1.179
ELSEIF (j.EQ.ppx_atm_tzonal) THEN GTJ1F304.9
ch=' PZ-GRID' GTJ1F304.10
ELSEIF (j.EQ.ppx_atm_uzonal) THEN GTJ1F304.11
ch=' UZ-GRID' GTJ1F304.12
ELSEIF (j.EQ.ppx_atm_tmerid) THEN GTJ1F304.13
ch=' PM-GRID' GTJ1F304.14
ELSEIF (j.EQ.ppx_atm_umerid) THEN GTJ1F304.15
ch=' UM-GRID' GTJ1F304.16
ELSEIF (j.EQ.ppx_atm_rim.OR.j.EQ.ppx_ocn_rim) THEN GTJ1F304.17
ch=' RIM ' DIAGDES1.181
ELSEIF (j.EQ.ppx_ocn_tcomp.OR.j.EQ.ppx_ocn_tall.OR. GTJ1F304.18
& j.EQ.ppx_ocn_tfield) THEN GTJ1F304.19
ch=' T-GRID ' DIAGDES1.183
ELSEIF (j.EQ.ppx_ocn_tzonal) THEN GTJ1F304.20
ch=' TZ-GRID' GTJ1F304.21
ELSEIF (j.EQ.ppx_ocn_uzonal) THEN GTJ1F304.22
ch=' UZ-GRID' GTJ1F304.23
ELSEIF (j.EQ.ppx_ocn_tmerid) THEN GTJ1F304.24
ch=' TM-GRID' GTJ1F304.25
ELSEIF (j.EQ.ppx_ocn_umerid) THEN GTJ1F304.26
ch=' UM-GRID' GTJ1F304.27
ELSEIF (j.EQ.ppx_ocn_ucomp.OR.j.EQ.ppx_ocn_uall.OR. GTJ1F304.28
& j.EQ.ppx_ocn_ufield) THEN GTJ1F304.29
ch=' UV-GRID' DIAGDES1.185
ELSEIF (j.EQ.ppx_atm_scalar.OR.j.EQ.ppx_ocn_scalar) THEN GTJ1F304.30
ch=' SCALAR ' GTJ1F304.31
ELSEIF (j.EQ.ppx_wam_all.OR.j.EQ.ppx_wam_sea) THEN GSS3F401.3
ch=' WAVE ' GSS3F401.4
ELSEIF (j.EQ.ppx_wam_rim) THEN GSS3F401.5
ch=' RIM ' GSS3F401.6
ELSE DIAGDES1.186
ch=' UNKNOWN' DIAGDES1.187
ENDIF DIAGDES1.188
line(i1:i2)=ch(1:1+i2-i1) DIAGDES1.189
C Leveltype DIAGDES1.190
i1=i2+2 DIAGDES1.191
i2=i1+9-1 DIAGDES1.192
j=ppxref(ppx_lv_code) DIAGDES1.193
IF (j.EQ.ppx_full_level) THEN DIAGDES1.194
ch='FULLLEVEL' DIAGDES1.195
ELSEIF (j.EQ.ppx_half_level) THEN DIAGDES1.196
ch='HALFLEVEL' DIAGDES1.197
ELSE DIAGDES1.198
ch='STD-LEVEL' DIAGDES1.199
ENDIF DIAGDES1.200
line(i1:i2)=ch(1:1+i2-i1) DIAGDES1.201
C Meto8LV DIAGDES1.202
i1=i2+2 DIAGDES1.203
i2=i1+7-1 DIAGDES1.204
j=ppxref(ppx_meto8_levelcode) DIAGDES1.205
write(ch,'(i7)') j DIAGDES1.206
line(i1:i2)=ch(1:1+i2-i1) DIAGDES1.207
C Meto8FC DIAGDES1.208
i1=i2+2 DIAGDES1.209
i2=i1+7-1 DIAGDES1.210
j=ppxref(ppx_meto8_fieldcode) DIAGDES1.211
write(ch,'(i7)') j DIAGDES1.212
line(i1:i2)=ch(1:1+i2-i1) DIAGDES1.213
C PackAcc DIAGDES1.214
i1=i2+2 DIAGDES1.215
i2=i1+7-1 DIAGDES1.216
j=stlist(st_output_code) DIAGDES1.217
IF (j.EQ.1) THEN DIAGDES1.218
IF (stlist(st_macrotag).GE.1000) THEN TJ140193.116
packing_profile=pp_pack_code(27) DIAGDES1.220
ELSE DIAGDES1.221
packing_profile=0 DIAGDES1.222
ENDIF DIAGDES1.223
ELSEIF(j.eq.2) THEN DIAGDES1.224
packing_profile=0 DIAGDES1.225
ELSEIF(j.lt.0) THEN DIAGDES1.226
packing_profile=pp_pack_code(-j) DIAGDES1.227
ELSE DIAGDES1.228
packing_profile=0 DIAGDES1.229
ENDIF DIAGDES1.230
IF (packing_profile.EQ.0) THEN DIAGDES1.231
ch=' ' DIAGDES1.232
ELSE DIAGDES1.233
j=ppxref(ppx_packing_acc+packing_profile-1) DIAGDES1.234
write(ch,'(i7)') j DIAGDES1.235
ENDIF DIAGDES1.236
line(i1:i2)=ch(1:1+i2-i1) DIAGDES1.237
C DIAGDES1.238
line1=line DIAGDES1.239
CL DIAGDES1.240
CL 1.2 Line 2. DIAGDES1.241
CL DIAGDES1.242
line=' ' DIAGDES1.243
C Time-processing DIAGDES1.244
i1=2 DIAGDES1.245
i2=16 DIAGDES1.246
j=stlist(st_proc_no_code) DIAGDES1.247
tser_list=0 DIAGDES1.248
IF (j.EQ.st_replace_code) THEN DIAGDES1.249
ch=' EXTRACT ' DIAGDES1.250
ELSEIF (j.EQ.st_accum_code) THEN DIAGDES1.251
ch=' ACCUMULATION ' DIAGDES1.252
ELSEIF (j.EQ.st_time_mean_code) THEN DIAGDES1.253
ch=' TIME MEAN ' DIAGDES1.254
ELSEIF (j.EQ.st_time_series_code) THEN DIAGDES1.255
write(ch,'('' TIME SERIES '')') DIAGDES1.256
tser_list=stlist(st_series_ptr) DIAGDES1.257
ELSEIF (j.EQ.st_max_code) THEN DIAGDES1.258
ch='MAX OVER PERIOD' DIAGDES1.259
ELSEIF (j.EQ.st_min_code) THEN DIAGDES1.260
ch='MIN OVER PERIOD' DIAGDES1.261
ELSEIF (j.EQ.st_append_traj_code) THEN DIAGDES1.262
ch=' TRAJECTORY ' DIAGDES1.263
ELSEIF (j.EQ.st_variance_code) THEN DIAGDES1.264
ch=' TIME VARIANCE ' DIAGDES1.265
ELSEIF (j.EQ.st_time_series_mean) THEN GRS1F404.247
ch='MEAN TIMESERIES' GRS1F404.248
ELSE DIAGDES1.266
ch=' UNKNOWN ' DIAGDES1.267
ENDIF DIAGDES1.268
line(i1:i2)=ch(1:1+i2-i1) DIAGDES1.269
C -From- DIAGDES1.270
i1=i2+2 DIAGDES1.271
i2=i1+6-1 DIAGDES1.272
IF (stlist(st_freq_code).LT.0) THEN DIAGDES1.273
ch=' ' DIAGDES1.274
ELSE DIAGDES1.275
j=stlist(st_start_time_code) DIAGDES1.276
write(ch,'(i6)') j DIAGDES1.277
ENDIF DIAGDES1.278
line(i1:i2)=ch(1:1+i2-i1) DIAGDES1.279
C --To-- DIAGDES1.280
i1=i2+2 DIAGDES1.281
i2=i1+6-1 DIAGDES1.282
IF (stlist(st_freq_code).LT.0) THEN DIAGDES1.283
ch=' ' DIAGDES1.284
ELSE DIAGDES1.285
j=stlist(st_end_time_code) DIAGDES1.286
IF (j.EQ.st_infinite_time) THEN DIAGDES1.287
ch=' ... ' DIAGDES1.288
ELSE DIAGDES1.289
write(ch,'(i6)') j DIAGDES1.290
ENDIF DIAGDES1.291
ENDIF DIAGDES1.292
line(i1:i2)=ch(1:1+i2-i1) DIAGDES1.293
C Frequency DIAGDES1.294
i1=i2+2 DIAGDES1.295
i2=i1+9-1 DIAGDES1.296
j=stlist(st_freq_code) DIAGDES1.297
IF (j.LT.0) THEN DIAGDES1.298
j=-j DIAGDES1.299
write(ch,'(''TIME LIST'')') DIAGDES1.300
time_list=j DIAGDES1.301
ELSE DIAGDES1.302
write(ch,'(i9)') j DIAGDES1.303
time_list=0 DIAGDES1.304
ENDIF DIAGDES1.305
line(i1:i2)=ch(1:1+i2-i1) DIAGDES1.306
C Period DIAGDES1.307
i1=i2+2 DIAGDES1.308
i2=i1+6-1 DIAGDES1.309
IF (stlist(st_freq_code).LT.0) THEN DIAGDES1.310
ch=' ' DIAGDES1.311
ELSE DIAGDES1.312
j=stlist(st_period_code) DIAGDES1.313
IF (stlist(st_proc_no_code).EQ.st_replace_code) THEN DIAGDES1.314
ch=' ' DIAGDES1.315
ELSEIF (j.EQ.st_infinite_time) THEN DIAGDES1.316
ch=' ... ' DIAGDES1.317
ELSE DIAGDES1.318
write(ch,'(i6)') j DIAGDES1.319
ENDIF DIAGDES1.320
ENDIF DIAGDES1.321
line(i1:i2)=ch(1:1+i2-i1) DIAGDES1.322
C __Source__ DIAGDES1.323
i1=i2+2 DIAGDES1.324
i2=i1+10-1 DIAGDES1.325
j=stlist(st_input_code) DIAGDES1.326
IF (j.EQ.0) THEN DIAGDES1.327
ch='PROGNOSTIC' DIAGDES1.328
ELSEIF(j.EQ.1) THEN DIAGDES1.329
ch=' STWORK ' DIAGDES1.330
ELSEIF(j.LT.0) THEN DIAGDES1.331
j=-j DIAGDES1.332
write(ch,'(''DUMP #'',i4)') j DIAGDES1.333
ELSE DIAGDES1.334
ch=' UNKNOWN ' DIAGDES1.335
ENDIF DIAGDES1.336
line(i1:i2)=ch(1:1+i2-i1) DIAGDES1.337
C ___Destination___ DIAGDES1.338
i1=i2+2 DIAGDES1.339
i2=i1+17-1 DIAGDES1.340
j=stlist(st_output_code) DIAGDES1.341
IF (j.EQ.1) THEN DIAGDES1.342
IF (stlist(st_macrotag).GE.1000) THEN TJ140193.117
ch='MEAN PP VIA DUMP' DIAGDES1.344
ELSEIF (stlist(st_macrotag).GT.0) THEN DIAGDES1.345
write(ch,'(''DUMP WITH TAG '',i3)') stlist(st_macrotag) DIAGDES1.346
ELSE DIAGDES1.347
ch=' DUMP ' DIAGDES1.348
ENDIF DIAGDES1.349
ELSEIF(j.eq.2) THEN DIAGDES1.350
ch=' SECONDARY ' DIAGDES1.351
ELSEIF(j.lt.0) THEN DIAGDES1.352
j=-j DIAGDES1.353
IF (j.EQ.27) THEN DIAGDES1.354
ch='MEAN PP (DIRECT) ' DIAGDES1.355
ELSE DIAGDES1.356
write(ch,'('' PP UNIT '',i2)') j DIAGDES1.357
ENDIF DIAGDES1.358
ELSE DIAGDES1.359
ch=' UNKNOWN ' DIAGDES1.360
ENDIF DIAGDES1.361
line(i1:i2)=ch(1:1+i2-i1) DIAGDES1.362
C DIAGDES1.363
line2=line DIAGDES1.364
CL DIAGDES1.365
CL 1.3 Line 3. DIAGDES1.366
CL DIAGDES1.367
line=' ' DIAGDES1.368
C Spatial-Processing DIAGDES1.369
i1=2 DIAGDES1.370
i2=19 DIAGDES1.371
j=stlist(st_gridpoint_code) DIAGDES1.372
IF (j.GE.extract_base.AND.j.LT.extract_top) THEN DIAGDES1.373
ch=' FULL FIELD ' DIAGDES1.374
ELSEIF (j.GE.vert_mean_base.AND.j.LT.vert_mean_top) THEN DIAGDES1.375
ch=' VERTICAL MEAN ' DIAGDES1.376
ELSEIF (j.GE.zonal_mean_base.AND.j.LT.zonal_mean_top) THEN DIAGDES1.377
ch=' ZONAL MEAN ' DIAGDES1.378
ELSEIF (j.GE.merid_mean_base.AND.j.LT.merid_mean_top) THEN DIAGDES1.379
ch=' MERIDIONAL MEAN ' DIAGDES1.380
ELSEIF (j.GE.field_mean_base.AND.j.LT.field_mean_top) THEN DIAGDES1.381
ch=' FIELD MEAN - 2D ' DIAGDES1.382
ELSEIF (j.GE.global_mean_base.AND.j.LT.global_mean_top) THEN DIAGDES1.383
ch=' GLOBAL MEAN - 3D ' DIAGDES1.384
ELSE DIAGDES1.385
ch=' ** UNKNOWN ** ' DIAGDES1.386
ENDIF DIAGDES1.387
line(i1:i2)=ch(1:1+i2-i1) DIAGDES1.388
C Levels-domain DIAGDES1.389
i1=i2+2 DIAGDES1.390
i2=i1+13-1 DIAGDES1.391
j=stlist(st_output_bottom) DIAGDES1.392
lev_list=0 DIAGDES1.393
IF (j.EQ.st_special_code) THEN DIAGDES1.394
ch='STANDARD LEV ' DIAGDES1.395
ELSEIF (j.gt.0) THEN DIAGDES1.396
write(ch,'(''LEVELS '',i2,''-'',i2)') j,stlist(st_output_top) DIAGDES1.397
ELSEIF (j.lt.0) THEN DIAGDES1.398
j=-j DIAGDES1.399
write(ch,'('' LEVELS LIST '')') DIAGDES1.400
lev_list=j DIAGDES1.401
ENDIF DIAGDES1.402
line(i1:i2)=ch(1:1+i2-i1) DIAGDES1.403
C Pseudo-levels TJ140193.118
i1=i2+2 TJ140193.119
i2=i1+15-1 TJ140193.120
j=stlist(st_pseudo_out) TJ140193.121
plev_list=0 TJ140193.122
IF (j.GT.0) THEN TJ140193.123
ch='PSEUDO-LEV LIST' TJ140193.124
plev_list=j TJ140193.125
ELSE TJ140193.126
ch=' NONE ' TJ140193.127
ENDIF TJ140193.128
line(i1:i2)=ch(1:1+i2-i1) TJ140193.129
C Horizontal-domain..... DIAGDES1.404
i1=i2+2 DIAGDES1.405
i2=i1+23-1 DIAGDES1.406
write(ch,'(''ROW:'',i3,''-'',i3,'' COL:'',i3,''-'',i3)') DIAGDES1.407
* stlist(st_north_code),stlist(st_south_code), DIAGDES1.408
* stlist(st_west_code),stlist(st_east_code) DIAGDES1.409
line(i1:i2)=ch(1:1+i2-i1) DIAGDES1.410
C Weighting DIAGDES1.411
i1=i2+2 DIAGDES1.412
i2=i1+9-1 DIAGDES1.413
j=stlist(st_weight_code) DIAGDES1.414
IF (j.EQ.stash_weight_null_code) THEN DIAGDES1.415
ch=' NONE ' DIAGDES1.416
ELSEIF (j.EQ.stash_weight_area_code) THEN DIAGDES1.417
ch=' AREA ' DIAGDES1.418
ELSEIF (j.EQ.stash_weight_volume_code) THEN DIAGDES1.419
ch=' VOLUME ' DIAGDES1.420
ELSEIF (j.EQ.stash_weight_mass_code) THEN DIAGDES1.421
ch=' MASS ' DIAGDES1.422
ENDIF DIAGDES1.423
line(i1:i2)=ch(1:1+i2-i1) DIAGDES1.424
C Masking DIAGDES1.425
i1=i2+2 DIAGDES1.426
i2=i1+7-1 DIAGDES1.427
j=mod(stlist(st_gridpoint_code),block_size) DIAGDES1.428
IF (j.EQ.stash_null_mask_code) THEN DIAGDES1.429
ch=' NONE ' DIAGDES1.430
ELSEIF (j.EQ.stash_land_mask_code) THEN DIAGDES1.431
ch=' LAND ' DIAGDES1.432
ELSEIF (j.EQ.stash_sea_mask_code) THEN DIAGDES1.433
ch=' SEA ' DIAGDES1.434
ELSE DIAGDES1.435
ch='UNKNOWN' DIAGDES1.436
ENDIF DIAGDES1.437
line(i1:i2)=ch(1:1+i2-i1) DIAGDES1.438
CL DIAGDES1.439
CL 1.4 Print the main part of the summary DIAGDES1.440
CL DIAGDES1.441
WRITE(6,1010) line1,line2,line DIAGDES1.442
1010 FORMAT(' #No ', DIAGDES1.443
* 'Diagnostic Description-------------- Submodel Item Section DIAGDES1.444
*PPfcode Datatype Gridtype Leveltype MetO8lv MetO8fc Packacc'/ DIAGDES1.445
* a124/ DIAGDES1.446
*' Time-processing -From- --To-- Frequency Period --Source-- ---Des DIAGDES1.447
*tination--- '/ DIAGDES1.448
* a124/ DIAGDES1.449
*' Spatial-processing Levels-domain -Pseudo-levels- ---Horizontal-d TJ140193.130
*omain--- Weighting Masking '/ TJ140193.131
* a124) DIAGDES1.452
CL DIAGDES1.453
CL 1.5 Print associated time and levels lists if appropriate DIAGDES1.454
CL DIAGDES1.455
CL 1.5.1 Time list DIAGDES1.456
CL DIAGDES1.457
IF (time_list.NE.0) THEN DIAGDES1.458
DO j=1,nsttims DIAGDES1.459
IF (sttabl(j,time_list).EQ.st_end_of_list) THEN DIAGDES1.460
ntimes=j-1 DIAGDES1.461
GOTO 210 DIAGDES1.462
ENDIF DIAGDES1.463
ENDDO DIAGDES1.464
210 CONTINUE DIAGDES1.465
WRITE(6,'('' ***** TIME LIST ***** '',i3, DIAGDES1.466
& '' times are as follows:-'')') ntimes DIAGDES1.467
i1=1 DIAGDES1.468
i2=8 DIAGDES1.469
DO j=1,ntimes DIAGDES1.470
IF (i1.EQ.1) line=' ' DIAGDES1.471
WRITE(ch,'(1x,i7)') sttabl(j,time_list) DIAGDES1.472
line(i1:i2)=ch(1:8) DIAGDES1.473
i1=i1+8 DIAGDES1.474
i2=i2+8 DIAGDES1.475
IF (i2.GT.80) THEN DIAGDES1.476
i1=1 DIAGDES1.477
i2=8 DIAGDES1.478
WRITE(6,'(a80)') line DIAGDES1.479
ENDIF DIAGDES1.480
ENDDO DIAGDES1.481
IF (i2.LE.80) WRITE(6,'(a80)') line DIAGDES1.482
ENDIF DIAGDES1.483
CL DIAGDES1.484
CL 1.5.2 Levels list DIAGDES1.485
CL DIAGDES1.486
IF (lev_list.NE.0) THEN DIAGDES1.487
write(6,'('' ***** LEVELS LIST ***** '',i3, DIAGDES1.488
& '' levels are as follows:-'')') stash_levels(1,lev_list) DIAGDES1.489
i1=1 DIAGDES1.490
i2=8 DIAGDES1.491
DO j=2,1+stash_levels(1,lev_list) DIAGDES1.492
IF (i1.EQ.1) line=' ' DIAGDES1.493
write(ch,'(1x,i7)') stash_levels(j,lev_list) DIAGDES1.494
line(i1:i2)=ch(1:8) DIAGDES1.495
i1=i1+8 DIAGDES1.496
i2=i2+8 DIAGDES1.497
IF (i2.GT.80) THEN DIAGDES1.498
i1=1 DIAGDES1.499
i2=8 DIAGDES1.500
write(6,'(a80)') line DIAGDES1.501
ENDIF DIAGDES1.502
ENDDO DIAGDES1.503
IF (i2.LE.80) write(6,'(a80)') line DIAGDES1.504
ENDIF DIAGDES1.505
CL DIAGDES1.506
CL 1.5.3 Pseudo-levels list TJ140193.132
CL TJ140193.133
IF (plev_list.NE.0) THEN TJ140193.134
write(6,'('' ***** PSEUDO-LEVELS LIST ***** '',i3, TJ140193.135
& '' pseudo-levels are as follows:-'')') TJ140193.136
& stash_pseudo_levels(1,plev_list) TJ140193.137
i1=1 TJ140193.138
i2=8 TJ140193.139
DO j=2,1+stash_pseudo_levels(1,plev_list) TJ140193.140
IF (i1.EQ.1) line=' ' TJ140193.141
write(ch,'(1x,i7)') stash_pseudo_levels(j,plev_list) TJ140193.142
line(i1:i2)=ch(1:8) TJ140193.143
i1=i1+8 TJ140193.144
i2=i2+8 TJ140193.145
IF (i2.GT.80) THEN TJ140193.146
i1=1 TJ140193.147
i2=8 TJ140193.148
write(6,'(a80)') line TJ140193.149
ENDIF TJ140193.150
ENDDO TJ140193.151
IF (i2.LE.80) write(6,'(a80)') line TJ140193.152
ENDIF TJ140193.153
CL TJ140193.154
CL 1.5.4 Time series subdomain record list TJ140193.155
CL DIAGDES1.508
IF (tser_list.NE.0) THEN DIAGDES1.509
i1=stash_series_index(1,tser_list) DIAGDES1.510
i2=stash_series_index(2,tser_list) DIAGDES1.511
WRITE(6,'('' ***** TIME SERIES ***** '',i3, DIAGDES1.512
& '' subdomain records are as follows:-''/ DIAGDES1.513
& '' Record North/South West/ East Bottom/ Top'')') DIAGDES1.514
& i2 DIAGDES1.515
DO j=1,i2 DIAGDES1.516
WRITE(6,'(3x,i4,1x,3(5x,i5,1x,i5,1x))') DIAGDES1.517
& j,(stash_series(3+k,i1+j-1),k=1,6) DIAGDES1.518
ENDDO DIAGDES1.519
ENDIF DIAGDES1.520
CL DIAGDES1.521
CL 1.5.5 Print final ruler line TJ140193.156
CL DIAGDES1.523
WRITE(6,1020) DIAGDES1.524
1020 FORMAT( DIAGDES1.525
*'================================================================= DIAGDES1.526
*==========================================================') DIAGDES1.527
C DIAGDES1.528
999 CONTINUE DIAGDES1.529
RETURN DIAGDES1.530
END DIAGDES1.531
*ENDIF DIAGDES1.532