*IF DEF,CONTROL STASH1.2
C ******************************COPYRIGHT****************************** GTS2F400.9505
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.9506
C GTS2F400.9507
C Use, duplication or disclosure of this code is subject to the GTS2F400.9508
C restrictions as set forth in the contract. GTS2F400.9509
C GTS2F400.9510
C Meteorological Office GTS2F400.9511
C London Road GTS2F400.9512
C BRACKNELL GTS2F400.9513
C Berkshire UK GTS2F400.9514
C RG12 2SZ GTS2F400.9515
C GTS2F400.9516
C If no contract has been raised with this copy of the code, the use, GTS2F400.9517
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.9518
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.9519
C Modelling at the above address. GTS2F400.9520
C ******************************COPYRIGHT****************************** GTS2F400.9521
C GTS2F400.9522
CLL Subroutine STASH -------------------------------------------------- STASH1.3
CLL STASH1.4
CLL Purpose: Control routine for diagnostic processing step-by-step. STASH1.5
CLL Called after each code section to process diagnostic fields STASH1.6
CLL from workspace STASH_WORK to their final destination in D1 STASH1.7
CLL or PP file. This routine loops over raw input fields and STASH1.8
CLL calls a service routine STWORK to do the actual processing. STASH1.9
CLL STASH1.10
CLL TJ, SI <- programmer of some or all of previous code or changes STASH1.11
CLL STASH1.12
CLL Model Modification history from model version 3.0: STASH1.13
CLL version Date STASH1.14
CLL 3.1 2/02/93 : Add NUNITS to argument list of STWORK to increase RS030293.82
CLL no. of i/o units for 'C' portable code. RS030293.83
CLL 3.2 13/07/93 Changed CHARACTER*(*) to CHARACTER*(80) for TS150793.195
CLL portability. Author Tracey Smith. TS150793.196
CLL 3.2 13/04/93 Dynamic allocation of main arrays. R T H Barnes. @DYALLOC.3373
CLL 3.3 29/03/94 Correct serious error in computing LENOUT. This can TJ300394.1
CLL be longer than the input length for timeseries. TCJ TJ300394.2
CLL 3.3 26/10/93 M. Carter. Part of an extensive mod that: MC261093.263
CLL 1.Removes the limit on primary STASH item numbers. MC261093.264
CLL 2.Removes the assumption that (section,item) MC261093.265
CLL defines the sub-model. MC261093.266
CLL 3.Thus allows for user-prognostics. MC261093.267
CLL Re-Index PPXREF. MC261093.268
CLL 3.5 07/04/95 Recoded for first stage of submodels. Added GKR0F305.1
CLL routine to pack internal model specific data into GKR0F305.2
CLL a superarray. K Rogers GKR0F305.3
!LL 4.0 06/09/95 Pass in stash superarrays from above. K Rogers GKR0F400.137
!LL 4.1 03/05/96 Remove unnecessary comdecks ARGPTRA,ARGPTRO, GKR1F401.1
!LL ARGCONA,TYPPTRA and TYPPTRO. Add in wave GKR1F401.2
!LL comdecks and wave call to STWORK. K Rogers. GKR1F401.3
! 4.1 03/04/96 Pass DUMP_PACKim to STWORK. D. Robinson. GDR2F401.66
!LL 4.3 17/02/97 MPP code : Added code to change to correct GPB0F403.38
!LL decomposition before calling STASH. GPB0F403.39
!LL Add MOS_MASK_LEN to STWORK argument list GPB0F403.40
!LL P.Burton GPB0F403.41
!LL 4.3 16/05/97 Fix for MPP use of MOS diagnostics - GPB5F403.101
!LL calculate LENOUT correctly. P.Burton GPB5F403.102
!LL 4.4 7/10/97 FT_FIRSTSTEP needed in STWORK to check whether GRR1F404.22
!LL re-initialised file stream is written to before GRR1F404.23
!LL being opened. R.Rawlins GRR1F404.24
!LL 4.4 13/10/97 Pass LEN_A/O/W_SPSTS to STWORK. D. Robinson. UDR2F404.41
!LL 4.5 13/01/98 Add global_LENOUT argument to STWORK P.Burton GPB2F405.167
CLL STASH1.15
CLL GKR0F305.4
CLL Programming standard : UM Doc Paper no 3 STASH1.16
CLL STASH1.17
CLL Logical components covered : C3, C4, C8 STASH1.18
CLL STASH1.19
CLL Project task : C4 STASH1.20
CLL STASH1.21
CLL External documentation : UMDP no C4 STASH1.22
CLL STASH1.23
CL* Interface and arguments -------------------------------------------- STASH1.24
C STASH1.25
SUBROUTINE STASH(sm_ident,im_ident,IS,STASH_WORK, 32,7GKR1F401.4
*CALL ARGSIZE 
@DYALLOC.3375
*CALL ARGD1 @DYALLOC.3376
*CALL ARGDUMA @DYALLOC.3377
*CALL ARGDUMO @DYALLOC.3378
*CALL ARGDUMW GKR1F401.5
*CALL ARGSTS @DYALLOC.3379
*CALL ARGPPX GKR0F305.6
& ICODE,CMESSAGE) @DYALLOC.3383
C STASH1.27
IMPLICIT NONE STASH1.28
@DYALLOC.3384
*CALL CMAXSIZE @DYALLOC.3385
*CALL CSUBMODL GKR0F305.7
*CALL TYPSIZE @DYALLOC.3386
*CALL TYPD1 @DYALLOC.3387
*CALL TYPDUMA @DYALLOC.3388
*CALL TYPDUMO @DYALLOC.3389
*CALL TYPDUMW GKR1F401.6
*CALL TYPSTS @DYALLOC.3390
*CALL TYPCONA @DYALLOC.3393
@DYALLOC.3394
INTEGER STASH1.30
& sm_ident !IN Submodel identifier GKR1F401.7
& ,im_ident !IN Internal model identifier GKR0F305.8
& ,IS !IN SECTION NUMBER STASH1.32
& ,ICODE !OUT RETURN CODE STASH1.33
REAL STASH1.34
& STASH_WORK(*) !IN Area holding the data if not in D1 STASH1.35
CHARACTER*(80) TS150793.197
& CMESSAGE !OUT ANY ERROR MESSAGE PASSED BACK STASH1.37
STASH1.38
C*--------------------------------------------------------------------- STASH1.39
C STASH1.40
C Common blocks and PARAMETERs STASH1.41
C STASH1.42
*CALL PPXLOOK GKR0F305.9
*CALL CHSUNITS RS030293.84
*CALL CLOOKADD STASH1.45
*CALL STPARAM @DYALLOC.3395
*CALL CCONTROL STASH1.49
*CALL CTIME STASH1.50
*CALL CHISTORY GDR3F305.184
*CALL CNTL_IO GPB2F405.169
*IF DEF,MPP GPB0F403.42
*CALL DECOMPTP GPB0F403.43
*CALL PARVARS GPB0F403.44
*ENDIF GPB0F403.45
C STASH1.54
C Subroutines called STASH1.55
C STASH1.56
EXTERNAL STWORK STASH1.57
C STASH1.58
C Local variables. STASH1.59
C STASH1.60
LOGICAL STASH1.61
* LCYCLIC ! TRUE if submodel is cyclic STASH1.62
GKR0F305.10
INTEGER GKR0F305.11
* IE, ! Index over items in section STASH1.64
* ILEND, ! End point in STASHlist STASH1.65
* ILSTART, ! Start point in STASHlist STASH1.66
* IL, ! STASHlist index TJ300394.3
* IM, ! Item number in section STASH1.67
* IPPX, ! Index to record in PP_XREF MC261093.269
* LENOUT ! Maximum output length STASH1.68
& ,LEN_INTHD ! integer header length GKR0F305.14
& ,LEN_REALHD ! real header length GKR0F305.15
& ,LEN1_LEVDEPC ! length 1st dim LEVDEPC GKR0F305.16
& ,LEN2_LEVDEPC ! length 2nd dim LEVDEPC GKR0F305.17
& ,LEN2_LOOKUP ! length 2nd dim LOOKUP GKR0F305.18
& ,STEP ! Step number in integration GKR0F305.19
& ,STEPS_PER_PERIOD ! No of steps per period GKR0F305.20
& ,SECS_PER_PERIOD ! No of seconds per period GKR0F305.21
& ,im_index ! Internal model index number GKR0F305.22
& ,num_rows1 ! Number of rows in field type 1 GKR0F400.138
& ,num_rows2 ! Number of rows in field type 1 GKR0F400.139
& ,row_len ! Row length GKR0F400.140
& ,field_len1 ! Length of field type 1 GKR0F400.141
& ,field_len2 ! Length of field type 2 GKR0F400.142
& ,num_levels ! Number of levels GKR0F400.143
*IF DEF,OCEAN GKR0F305.23
& ,LEN_OCNWORK ! Length of ocean work array GKR0F305.24
*ENDIF GKR0F305.25
*IF DEF,WAVE GKR1F401.8
& ,len_wavwork ! Length of wave work array GKR1F401.9
*ENDIF GKR1F401.10
*IF DEF,MPP GPB0F403.46
& ,orig_decomp ! Decomposition on entry GPB0F403.47
&, global_LENOUT ! Size of output field on disk GPB2F405.168
*ENDIF GPB0F403.48
*IF -DEF,ATMOS GKR1F401.11
*IF DEF,OCEAN,OR,DEF,WAVE GKR1F401.12
LOGICAL ELF ! True if input grid rotated GKR0F305.31
! equatorial GKR0F305.32
*ENDIF GKR0F305.33
*ENDIF GKR1F401.13
GKR0F305.34
GKR0F305.36
GKR0F305.37
CL--------------------------------------------------------------------- STASH1.81
CL 0. Initialise. STASH1.82
CL Set LCYCLIC to indicate EW boundary condition. STASH1.83
CL STASH1.84
*IF DEF,MPP GPB0F403.49
! Find current decomposition, so we can return to this after STASH GPB0F403.50
orig_decomp=current_decomp_type GPB0F403.51
GPB0F403.52
*ENDIF GPB0F403.53
ICODE = 0 STASH1.85
*IF DEF,ATMOS STASH1.86
IF (sm_ident.eq.atmos_sm) LCYCLIC = .NOT. ELF GKR1F401.14
*ENDIF STASH1.88
*IF DEF,OCEAN STASH1.89
IF (sm_ident.eq.ocean_sm) LCYCLIC = CYCLIC_OCEAN GKR1F401.15
*ENDIF STASH1.91
*IF DEF,WAVE GKR1F401.16
IF (sm_ident.eq.wave_sm) LCYCLIC = GLOBAL_WAVE GKR1F401.17
*ENDIF GKR1F401.18
GKR0F305.38
im_index = internal_model_index(im_ident) GKR0F305.39
GKR0F305.40
CL--------------------------------------------------------------------- STASH1.92
CL 1. Loop over items within this section and call STWORK with STASH1.93
CL appropriate argument list depending on whether atmosphere/ocean STASH1.94
CL STASH1.95
DO 100 IE=1,NITEMS ! max no of items in this section STASH1.96
IF(STINDEX(2,IE,IS,im_index).GT.0) THEN ! Entries for this GKR0F305.41
! SECTION/ITEM GKR0F305.42
ILSTART=STINDEX(1,IE,IS,im_index) GKR0F305.43
ILEND=ILSTART+STINDEX(2,IE,IS,im_index)-1 GKR0F305.44
IM=STLIST(1,ILSTART) ! item number STASH1.100
STASH1.101
IF(SF(IM,IS)) THEN ! item/section reqd for this t/s STASH1.102
IF(STLIST(st_proc_no_code,STINDEX(1,IE,IS,im_index)) GKR0F305.45
& .NE.0) THEN GKR0F305.46
C required by STASH so continue. STASH1.104
C It should not be possible to have any multiple entries for a given STASH1.105
C ITEM SECTION number and one of those not be required by STASH STASH1.106
STASH1.107
*IF DEF,PRINT84 STASH1.108
WRITE(6,109) IM,IS STASH1.109
109 FORMAT(' ITEM',I4,' SECTION',I4,'REQUIRED BY STASH') STASH1.110
*ENDIF STASH1.111
TJ300394.4
C NB: max poss output length for the item/sect can be LONGER than TJ300394.5
C the input length in the case of timeseries. TJ300394.6
LENOUT=0 GPB5F403.103
*IF DEF,MPP GPB2F405.170
global_LENOUT=0 GPB2F405.171
*ENDIF GPB2F405.172
DO IL=ILSTART,ILEND GPB5F403.104
*IF -DEF,MPP GPB5F403.105
LENOUT=MAX(LENOUT,STLIST(st_output_length,IL)) GPB5F403.106
*ELSE GPB5F403.107
IF (STLIST(st_output_code,IL) .EQ. -89) THEN ! MOS GPB5F403.108
LENOUT=MAX(LENOUT,MOS_OUTPUT_LENGTH*P_LEVELS) GPB5F403.109
global_LENOUT=MAX(global_LENOUT, GPB2F405.173
& MOS_OUTPUT_LENGTH*P_LEVELS) GPB2F405.174
ELSE GPB5F403.110
LENOUT=MAX(LENOUT,STLIST(st_output_length,IL)) GPB5F403.111
global_LENOUT= GPB2F405.175
& MAX(global_LENOUT, GPB2F405.176
& STLIST(st_dump_level_output_length,IL)) GPB2F405.177
ENDIF GPB5F403.112
*ENDIF GPB5F403.113
ENDDO GPB5F403.114
*IF DEF,MPP GPB2F405.178
! Add on an extra UM_SECTOR_SIZE on the end, ensuring array is GPB2F405.179
! big enough for data+extra space to round up to the next GPB2F405.180
! UM_SECTOR_SIZE GPB2F405.181
global_LENOUT=global_LENOUT+UM_SECTOR_SIZE GPB2F405.182
*ENDIF GPB2F405.183
STASH1.114
! Set general variables GKR0F305.47
GKR0F305.48
STEP = STEPim(im_ident) GKR0F305.49
STEPS_PER_PERIOD = STEPS_PER_PERIODim(im_ident) GKR0F305.50
SECS_PER_PERIOD = SECS_PER_PERIODim(im_ident) GKR0F305.51
GKR0F305.52
! DUMP_PACKim controls the packing of fields in a dump GDR2F401.67
! 1 : Use PPXREF file to control packing GDR2F401.68
! 2 : Do not pack prognostics, as 1 for diagnostics GDR2F401.69
! 3 : Do not pack prognostics or diagnostics GDR2F401.70
GKR0F305.53
! Make superarrays to pass into STWORK GKR0F305.54
*IF DEF,ATMOS GKR0F305.55
if (im_ident .eq. atmos_sm) then GKR0F305.56
GKR0F305.57
*IF DEF,MPP GPB0F403.54
! Change to atmosphere decomposition GPB0F403.55
IF (current_decomp_type .NE. GPB0F403.56
& decomp_standard_atmos) THEN GPB0F403.57
CALL CHANGE_DECOMPOSITION(decomp_standard_atmos, GPB0F403.58
& ICODE) GPB0F403.59
ENDIF GPB0F403.60
IF (ICODE .NE. 0) THEN GPB0F403.61
CMESSAGE='STASH : Unsupported MPP submodel : atmos' GPB0F403.62
GOTO 999 GPB0F403.63
ENDIF GPB0F403.64
*ENDIF GPB0F403.65
! Following 6 lines to be removed at vn4.1 GKR0F305.67
LEN_INTHD = A_LEN_INTHD GKR0F305.68
LEN_REALHD = A_LEN_REALHD GKR0F305.69
LEN1_LEVDEPC = A_LEN1_LEVDEPC GKR0F305.70
LEN2_LEVDEPC = A_LEN2_LEVDEPC GKR0F305.71
LEN2_LOOKUP = A_LEN2_LOOKUP GKR0F305.72
num_rows1 = p_rows GKR0F400.144
num_rows2 = u_rows GKR0F400.145
row_len = row_length GKR0F400.146
field_len1 = p_field GKR0F400.147
field_len2 = u_field GKR0F400.148
num_levels = p_levels GKR0F400.149
GKR0F305.73
CALL STWORK( STASH1.118
*CALL ARGPPX GKR0F305.74
& D1,LEN_TOT,STASH_WORK,STASH_MAXLEN(IS,im_index),LENOUT, GKR0F400.150
*IF DEF,MPP GPB2F405.184
& global_LENOUT, GPB2F405.185
*ENDIF GPB2F405.186
& 1,IS,IM,ILSTART,ILEND,STEP,STEPS_PER_PERIOD, GKR0F400.151
& SECS_PER_PERIOD, PREVIOUS_TIME, GKR0F305.77
& STLIST,LEN_STLIST,TOTITEMS,SI,NSECTS,NITEMS, STASH1.153
& STASH_LEVELS,NUM_STASH_LEVELS,NUM_LEVEL_LISTS, STASH1.154
& STASH_PSEUDO_LEVELS,NUM_STASH_PSEUDO,NUM_PSEUDO_LISTS, STASH1.155
& MAX_STASH_LEVS,STTABL,NSTTIMS,NSTTABL, STASH1.156
& STASH_SERIES,nstash_series_records,time_series_rec_len, STASH1.157
& stash_series_index,nstash_series_block, STASH1.158
& MOS_MASK,MOS_MASK_LEN,MOS_OUTPUT_LENGTH, GPB0F403.66
& PP_PACK_CODE,MODEL_FT_UNIT,FT_STEPS,FT_FIRSTSTEP, GRR1F404.25
& A_FIXHD,A_INTHD, GRR1F404.26
& A_REALHD,LEN_FIXHD,LEN_INTHD,LEN_REALHD, GKR0F305.79
& A_LEVDEPC,LEN1_LEVDEPC,LEN2_LEVDEPC, GKR0F305.80
& A_LOOKUP,A_LOOKUP, ! 2nd copy used as REAL in PP_HEAD @DYALLOC.3405
& LEN1_LOOKUP,LEN2_LOOKUP,PP_LEN2_LOOKUP, GKR0F305.81
& NUNITS,PP_LEN2_LOOK, RS030293.88
& lcyclic,num_rows1,num_rows2, GKR0F400.152
& row_len,field_len1,field_len2,num_levels, GKR0F400.153
& FORECAST_HRS,RUN_INDIC_OP,ELF,FT_LASTFIELD, STASH1.171
& sm_ident,im_ident,DUMP_PACKim(sm_ident), GDR2F401.71
& len_a_spsts, a_spsts, a_spsts, a_ixsts, len_a_ixsts, UDR2F404.42
& ICODE,CMESSAGE) STASH1.172
endif GKR0F305.85
*ENDIF GKR0F305.86
*IF DEF,OCEAN GKR0F305.87
if (im_ident .eq. ocean_sm) then GKR0F305.88
GKR0F305.89
*IF DEF,MPP GPB0F403.67
! Change to ocean (no wrap around points) decomposition GPB0F403.68
IF (current_decomp_type .NE. GPB0F403.69
& decomp_nowrap_ocean) THEN GPB0F403.70
CALL CHANGE_DECOMPOSITION(decomp_nowrap_ocean, GPB0F403.71
& ICODE) GPB0F403.72
ENDIF GPB0F403.73
IF (ICODE .NE. 0) THEN GPB0F403.74
CMESSAGE='STASH : Unsupported MPP submodel : ocean' GPB0F403.75
GOTO 999 GPB0F403.76
ENDIF GPB0F403.77
*ENDIF GPB0F403.78
IF (CYCLIC_OCEAN) THEN STASH1.178
row_len = imtm2 GKR0F400.155
ELSE STASH1.180
row_len = imt GKR0F400.156
ENDIF STASH1.182
len_ocnwork = o_spsts(o_ixsts(9)) GKR0F400.157
GKR0F305.93
GKR0F305.101
! Following 6 lines to be removed at vn4.1 GKR0F305.102
LEN_INTHD = O_LEN_INTHD GKR0F305.103
LEN_REALHD = O_LEN_REALHD GKR0F305.104
LEN1_LEVDEPC = O_LEN1_LEVDEPC GKR0F305.105
LEN2_LEVDEPC = O_LEN2_LEVDEPC GKR0F305.106
LEN2_LOOKUP = O_LEN2_LOOKUP GKR0F305.107
GKR0F305.108
num_rows1 = jmt GKR0F400.158
num_rows2 = jmtm1 GKR0F400.159
field_len1 = jmt * row_len GKR0F400.160
field_len2 = jmtm1 * row_len GKR0F400.161
num_levels = km GKR0F400.162
ELF = .FALSE. GKR0F305.114
GKR0F305.115
CALL STWORK( STASH1.185
*CALL ARGPPX GKR0F305.116
& D1,LEN_TOT,STASH_WORK,STASH_MAXLEN(IS,im_index),LENOUT, GKR0F400.163
*IF DEF,MPP GPB2F405.187
& global_LENOUT, GPB2F405.188
*ENDIF GPB2F405.189
& LEN_OCNWORK, GKR0F400.164
& IS,IM,ILSTART,ILEND,STEP,STEPS_PER_PERIOD, GKR0F305.118
& SECS_PER_PERIOD, PREVIOUS_TIME, GKR0F305.119
& STLIST,LEN_STLIST,TOTITEMS,SI,NSECTS,NITEMS, STASH1.191
& STASH_LEVELS,NUM_STASH_LEVELS,NUM_LEVEL_LISTS, STASH1.192
& STASH_PSEUDO_LEVELS,NUM_STASH_PSEUDO,NUM_PSEUDO_LISTS, STASH1.193
& MAX_STASH_LEVS,STTABL,NSTTIMS,NSTTABL, STASH1.194
& STASH_SERIES,nstash_series_records,time_series_rec_len, STASH1.195
& stash_series_index,nstash_series_block, STASH1.196
& MOS_MASK,MOS_MASK_LEN,MOS_OUTPUT_LENGTH, GPB0F403.79
& PP_PACK_CODE,MODEL_FT_UNIT,FT_STEPS,FT_FIRSTSTEP, GRR1F404.27
& O_FIXHD,O_INTHD, GRR1F404.28
& O_REALHD,LEN_FIXHD,LEN_INTHD,LEN_REALHD, GKR0F305.121
& O_LEVDEPC,LEN1_LEVDEPC,LEN2_LEVDEPC, GKR0F305.122
& O_LOOKUP,O_LOOKUP, ! 2nd copy used as REAL in PP_HEAD @DYALLOC.3409
& LEN1_LOOKUP,LEN2_LOOKUP,PP_LEN2_LOOKUP, GKR0F305.123
& NUNITS,PP_LEN2_LOOK, RS030293.90
& lcyclic,num_rows1,num_rows2, GKR0F400.165
& row_len,field_len1,field_len2,num_levels, GKR0F400.166
& FORECAST_HRS,RUN_INDIC_OP,ELF,FT_LASTFIELD, GKR0F305.126
& sm_ident,im_ident,DUMP_PACKim(sm_ident), GDR2F401.72
& len_o_spsts, o_spsts, o_spsts, o_ixsts, len_o_ixsts, UDR2F404.43
& ICODE,CMESSAGE) STASH1.211
GKR0F305.129
endif GKR0F305.130
*ENDIF GKR0F305.131
*IF DEF,SLAB GKR0F305.132
if (im_ident .eq. slab_im) then GKR0F305.133
GKR0F305.134
GKR0F305.143
! Following 6 lines to be removed at vn4.1 GKR0F305.144
LEN_INTHD = A_LEN_INTHD GKR0F305.145
LEN_REALHD = A_LEN_REALHD GKR0F305.146
LEN1_LEVDEPC = A_LEN1_LEVDEPC GKR0F305.147
LEN2_LEVDEPC = A_LEN2_LEVDEPC GKR0F305.148
LEN2_LOOKUP = A_LEN2_LOOKUP GKR0F305.149
num_rows1 = p_rows GKR0F400.168
num_rows2 = u_rows GKR0F400.169
row_len = row_length GKR0F400.170
field_len1 = p_field GKR0F400.171
field_len2 = u_field GKR0F400.172
num_levels = p_levels GKR0F400.173
GKR0F305.150
CALL STWORK( GKR0F305.151
*CALL ARGPPX GKR0F305.152
& D1,LEN_TOT,STASH_WORK,STASH_MAXLEN(IS,im_index),LENOUT, GKR0F400.174
*IF DEF,MPP GPB2F405.190
& global_LENOUT, GPB2F405.191
*ENDIF GPB2F405.192
& 1,IS,IM,ILSTART,ILEND,STEP,STEPS_PER_PERIOD, GKR0F400.175
& SECS_PER_PERIOD, PREVIOUS_TIME, GKR0F305.155
& STLIST,LEN_STLIST,TOTITEMS,SI,NSECTS,NITEMS, GKR0F305.156
& STASH_LEVELS,NUM_STASH_LEVELS,NUM_LEVEL_LISTS, GKR0F305.157
& STASH_PSEUDO_LEVELS,NUM_STASH_PSEUDO,NUM_PSEUDO_LISTS, GKR0F305.158
& MAX_STASH_LEVS,STTABL,NSTTIMS,NSTTABL, GKR0F305.159
& STASH_SERIES,nstash_series_records,time_series_rec_len, GKR0F305.160
& stash_series_index,nstash_series_block, GKR0F305.161
& MOS_MASK,MOS_MASK_LEN,MOS_OUTPUT_LENGTH, GPB0F403.80
& PP_PACK_CODE,MODEL_FT_UNIT,FT_STEPS,FT_FIRSTSTEP, GRR1F404.29
& A_FIXHD,A_INTHD, GRR1F404.30
& A_REALHD,LEN_FIXHD,LEN_INTHD,LEN_REALHD, GKR0F305.164
& A_LEVDEPC,LEN1_LEVDEPC,LEN2_LEVDEPC, GKR0F305.165
& A_LOOKUP,A_LOOKUP, ! 2nd copy used as REAL in PP_HEAD GKR0F305.166
& LEN1_LOOKUP,LEN2_LOOKUP,PP_LEN2_LOOKUP, GKR0F305.167
& NUNITS,PP_LEN2_LOOK, GKR0F305.168
& lcyclic,num_rows1,num_rows2, GKR0F400.176
& row_len,field_len1,field_len2,num_levels, GKR0F400.177
& FORECAST_HRS,RUN_INDIC_OP,ELF,FT_LASTFIELD, GKR0F305.171
& sm_ident,im_ident,DUMP_PACKim(sm_ident), GDR2F401.73
& len_a_spsts, a_spsts, a_spsts, a_ixsts, len_a_ixsts, UDR2F404.44
& ICODE,CMESSAGE) GKR0F305.174
GKR0F305.175
endif GKR0F305.176
*ENDIF GKR0F305.177
*IF DEF,WAVE GKR1F401.19
if (im_ident .eq. wave_sm) then GKR1F401.20
GKR1F401.21
len_wavwork = w_spsts(w_ixsts(2)) GKR1F401.22
GKR1F401.23
num_rows1 = NGY GKR1F401.24
num_rows2 = NGY GKR1F401.25
field_len1 = NGX * NGY GKR1F401.26
field_len2 = NGX * NGY GKR1F401.27
num_levels = NANG ! number of directions GKR1F401.28
! num_freq = NFRE ! number of frequency pseudo-levels GKR1F401.29
ELF = .FALSE. GKR1F401.30
GKR1F401.31
CALL STWORK( GKR1F401.32
*CALL ARGPPX GKR1F401.33
& D1,LEN_TOT,STASH_WORK,STASH_MAXLEN(IS,im_index),LENOUT, GKR1F401.34
*IF DEF,MPP GPB2F405.193
& global_LENOUT, GPB2F405.194
*ENDIF GPB2F405.195
& len_wavwork, GKR1F401.35
& IS,IM,ILSTART,ILEND,STEP,STEPS_PER_PERIOD, GKR1F401.36
& SECS_PER_PERIOD, PREVIOUS_TIME, GKR1F401.37
& STLIST,LEN_STLIST,TOTITEMS,SI,NSECTS,NITEMS, GKR1F401.38
& STASH_LEVELS,NUM_STASH_LEVELS,NUM_LEVEL_LISTS, GKR1F401.39
& STASH_PSEUDO_LEVELS,NUM_STASH_PSEUDO,NUM_PSEUDO_LISTS, GKR1F401.40
& MAX_STASH_LEVS,STTABL,NSTTIMS,NSTTABL, GKR1F401.41
& STASH_SERIES,nstash_series_records,time_series_rec_len, GKR1F401.42
& stash_series_index,nstash_series_block, GKR1F401.43
& MOS_MASK,MOS_MASK_LEN,MOS_OUTPUT_LENGTH, GPB0F403.81
& PP_PACK_CODE,MODEL_FT_UNIT,FT_STEPS,FT_FIRSTSTEP, GRR1F404.31
& W_FIXHD,W_INTHD, GRR1F404.32
& W_REALHD,LEN_FIXHD,LEN_INTHD,LEN_REALHD, GKR1F401.46
& W_LEVDEPC,LEN1_LEVDEPC,LEN2_LEVDEPC, GKR1F401.47
& W_LOOKUP,W_LOOKUP, ! 2nd copy used as REAL in PP_HEAD GKR1F401.48
& LEN1_LOOKUP,LEN2_LOOKUP,PP_LEN2_LOOKUP, GKR1F401.49
& NUNITS,PP_LEN2_LOOK, GKR1F401.50
& lcyclic,num_rows1,num_rows2, GKR1F401.51
& row_len,field_len1,field_len2,num_levels, GKR1F401.52
& FORECAST_HRS,RUN_INDIC_OP,ELF,FT_LASTFIELD, GKR1F401.53
& sm_ident,im_ident,DUMP_PACKim(sm_ident), GKR1F401.54
& len_w_spsts, w_spsts, w_spsts, w_ixsts, len_w_ixsts, UDR2F404.45
& ICODE,CMESSAGE) GKR1F401.56
GKR1F401.57
endif GKR1F401.58
*ENDIF GKR1F401.59
GKR1F401.60
GKR0F305.178
ENDIF STASH1.214
GKR0F305.179
ENDIF STASH1.215
GKR0F305.180
ENDIF STASH1.216
C Handle error/warning conditions on return from STWORK STASH1.217
IF (icode.gt.0) THEN STASH1.218
WRITE(6,*)'STASH : Error processing diagnostic section ', GIE0F403.634
& is,', item ',im,', code ',icode GKR1F401.61
WRITE(6,*)' ',cmessage GIE0F403.635
goto 999 STASH1.221
ELSEIF (icode.lt.0) THEN STASH1.222
WRITE(6,*)'STASH : Warning processing diagnostic section ', GIE0F403.636
& is,', item ',im,', code ',icode STASH1.224
WRITE(6,*)' ',cmessage GIE0F403.637
icode=0 STASH1.226
ENDIF STASH1.227
100 CONTINUE STASH1.228
STASH1.229
999 CONTINUE STASH1.230
*IF DEF,MPP GPB0F403.82
IF (current_decomp_type .NE. orig_decomp) THEN GPB0F403.83
CALL CHANGE_DECOMPOSITION(orig_decomp, GPB0F403.84
& ICODE) GPB0F403.85
IF (ICODE .NE. 0) THEN GPB0F403.86
CMESSAGE='STASH : Unsupported MPP submodel' GPB0F403.87
ENDIF GPB0F403.88
ENDIF GPB0F403.89
*ENDIF GPB0F403.90
RETURN STASH1.231
END STASH1.232
*ENDIF STASH1.233