*IF DEF,C84_1A STWORK1A.2
C ******************************COPYRIGHT****************************** GTS2F400.9793
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.9794
C GTS2F400.9795
C Use, duplication or disclosure of this code is subject to the GTS2F400.9796
C restrictions as set forth in the contract. GTS2F400.9797
C GTS2F400.9798
C Meteorological Office GTS2F400.9799
C London Road GTS2F400.9800
C BRACKNELL GTS2F400.9801
C Berkshire UK GTS2F400.9802
C RG12 2SZ GTS2F400.9803
C GTS2F400.9804
C If no contract has been raised with this copy of the code, the use, GTS2F400.9805
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.9806
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.9807
C Modelling at the above address. GTS2F400.9808
C ******************************COPYRIGHT****************************** GTS2F400.9809
C GTS2F400.9810
CLL Subroutine STWORK ------------------------------------------------- STWORK1A.3
CLL STWORK1A.4
CLL Purpose: Processes all the STASHlist entries for a particular STWORK1A.5
CLL item and section number after a timestep. Raw input diagnostics to STWORK1A.6
CLL STWORK come either from D1, the main data array, or STASH_WORK, a STWORK1A.7
CLL work array dimensioned by the control level and passed in. Each STWORK1A.8
CLL field is spatially processed, temporally processed and then output. STWORK1A.9
CLL The output destination can either be to an address in D1 or to a PP STWORK1A.10
CLL fieldsfile on a given unit. In either case a PP-type LOOKUP header STWORK1A.11
CLL is generated to describe the contents of the output field. Now STWORK1A.12
CLL handles atmosphere or ocean diagnostics according to arguments STWORK1A.13
CLL passed by calling routine. STWORK1A.14
CLL STWORK1A.15
CLL Author: T.Johns/S.Tett STWORK1A.16
CLL STWORK1A.17
CLL Tested under compiler: cft77 STWORK1A.18
CLL Tested under OS version: UNICOS 5.1 STWORK1A.19
CLL STWORK1A.20
CLL Model Modification history from model version 3.0: STWORK1A.21
CLL version Date STWORK1A.22
CLL 3.0 31/12/92 Reference to deck name removed from message STWORK1A.23
CLL when deckname STWORK2 changed to STWORK1A MJH TJ140193.1
CLL 3.1 19/01/93 Enforce processing thro' SPATIAL loop if the input TJ140193.2
CLL and output pseudo-levels lists differ (bugfix). TJ140193.3
CLL 3.1 24/02/93 Correct outstanding problems with timeseries (ST). TJ140193.4
CLL 16/03/93 Correct coding errors for ppx_ocn GR types (SI). TJ140193.5
CLL 3.1 15/01/93 Add NUNITS to argument list to cope with increases RS030293.278
CLL in i/o units for 'C' portable code. R.Rawlins RS030293.279
CLL 3.2 13/07/93 Changed CHARACTER*(*) to CHARACTER*(80) for TS150793.243
CLL portability. Author Tracey Smith. TS150793.244
CLL 3.2 06/04/93 Correct base_level in no-SPATIAL-processing case TJ010793.1
CLL when OCEAN diagnostic on input levels list. Trap TJ010793.2
CLL error return codes from STOCGT. Bugfix for packing TJ010793.3
CLL of timeseries (extraw_hdr not extraw). Initialise TJ010793.4
CLL extraw_hdr (MOS case). Remove rogue comma.(TCJ/ST) TJ010793.5
CLL 3.2 02/07/93 Add arguments needed in STOCGT owing to dynamic @DYALLOC.3463
CLL allocation control level changes. R.T.H.Barnes. @DYALLOC.3464
CLL 3.3 30/03/94 Pass lenout dimension to MULTI_SPAIAL and remove TJ300394.13
CLL redundant addr_out addressing on ppfield; correct TJ300394.14
CLL bug in SPATIAL processing of ocean fields on TJ300394.15
CLL input levels lists. Author Tim Johns. TJ300394.16
CLL 3.3 17/11/93 Declaring MODEL_FT_UNIT(NUNITS) after NUNITS NF171193.5
CLL has been defined. (N.Farnon) NF171193.6
CLL 3.3 17/09/93 Set LOGICAL lmasswt to denote that level-by-level TJ170993.5
CLL mass-weights exist and pass to (MULTI)SPATIAL. TJ170993.6
CLL Also correct error in passing addressed field to TJ170993.7
CLL SPATIAL in vertical/global mean case (TCJ). TJ170993.8
CLL 3.4 04/08/94 No packing indicator change from -26 to -99 PJS APS1F304.5
CLL 3.4 07/10/94 : Move call to grib_file so that pp headers are GRS3F304.184
CLL set correctly R A Stratton. GRS3F304.185
CLL 3.4 15/06/94 Force soft failure if number of fields output to GRR0F304.1
CLL a PP file exceeds the number of pre-allocated GRR0F304.2
CLL headers. R.Rawlins GRR0F304.3
CLL 3.4 22/07/94 Corrects uninitialised argument to PP_HEAD when GDG1F304.1
CLL stashing data to D1 GDG1F304.2
CLL 3.4 13/01/94 Correct bug in spatial processing loop - cater for GTJ1F304.32
CLL C-U and C-V grid types. T.Johns GTJ1F304.33
CLL 4.0 26/07/95 Allow integer or logical fields to be passed thro' GTJ0F400.10
CLL STASH provided no spatial processing done. T.Johns GTJ0F400.11
CLL 3.5 07/04/95 Changes for stage 1 of submodels project. K Rogers GKR0F305.434
CLL In STOCGT remove ARGSIZE and pass in: GKR0F305.435
CLL JMT=T_ROWS,IMT=ROW_LENGTH,KM=P_LEVELS or GKR0F305.436
CLL JMT=T_ROWS,IMTM2=ROW_LENGTH,KM=P_LEVELS GKR0F305.437
CLL 3.5 24/03/95 Changed OPEN to FILE_OPEN and GPB1F305.152
CLL CLOSE to FILE_CLOSE P.Burton GPB1F305.153
CLL 4.0 12/09/95 Remove CMESSAGE='' after call to PP_HEAD. GAB1F400.157
CLL Call PP_HEAD with AK, BK, AHH, BKH, T_levels and GAB1F400.158
CLL JJ (level list value) and without RUN_INDIC_OP GAB1F400.159
CLL (Andrew Brady) GAB1F400.160
!LL 4.0 06/09/95 Pass in superarray from higher levels. K Rogers GKR0F400.179
! 4.0 10/03/95 Allow alternative packing method for grib output. GRS3F400.275
! R A Stratton GRS3F400.276
CLL 4.0 15/06/95 Reduce i/o required by STASH. Original code read GRR1F400.1
CLL the entire set of pp lookup tables (at least GRR1F400.2
CLL PP_LEN2_LOOK, usually 4096) records, then re-wrote GRR1F400.3
CLL the same set for each call to STASH. This is GRR1F400.4
CLL replaced here by only reading the last pp header GRR1F400.5
CLL written to and subsequently only writing out the GRR1F400.6
CLL next set of pp headers serviced by the STASH call. GRR1F400.7
CLL Rick Rawlins. GRR1F400.8
! 4.1 Apr. 96 Rationalise *CALLs S.J.Swarbrick GSS1F401.55
CLL 4.1 31/05/96 Add calls to STWVGT for wave model. K Rogers GKR1F401.63
! 4.1 03/04/96 New argument DUMP_PACK : Use to control GDR2F401.55
! packing in dumps. D. Robinson GDR2F401.56
! 4.2 10/09/96 MPP modifications to STASH P.Burton GPB1F402.1
! 4.3 13/3/97 Further MPP STASH modifications P.Burton GPB0F403.2030
!LL 4.3 30/04/97 Added code to use UM_SECTOR_SIZE to make transfers GBC0F403.60
!LL well-formed. GBC0F403.61
!LL B. Carruthers Cray Research. GBC0F403.62
! 4.3 07/05/97 Correct error in STASH-time processed GMC1F403.1
! diagnostics affecting Ocean and Wave GMC1F403.2
! models only M.Carter GMC1F403.3
! 4.3 17/4/97 Parallelisation of COEX D.Salmond GDS3F403.1
! 4.4 25/11/96 New option - mean timeseries. R A Stratton. GRS1F404.158
! 4.4 25/06/97 Set PPHORIZ_OUT and NROWS/COLS_OUT correctly GPB1F404.66
! when outputing timeseries. P.Burton GPB1F404.67
!LL 4.4 28/07/97 Changes connected with allowing reinitialisation of GMG1F404.345
!LL PP files on Gregorian month boundaries. M.Gallani GMG1F404.346
!LL 4.4 16/06/97 Add processing after the write, so GBC3F404.19
!LL that all the processors know the answer GBC3F404.20
!LL Author: Bob Carruthers, Cray Rsearch. GBC3F404.21
! 4.4 12/06/97 MPP improvements P.Burton GPB0F404.1
! 4.4 7/10/97 Force explicit fail of model when attempting to GRR1F404.1
! write to a file on a re-initialised stream before GRR1F404.2
! it has been opened. R.Rawlins GRR1F404.3
!LL 4.5 13/01/98 Added global_LENOUT argument, and replace GPB2F405.247
!LL SHMEM COMMON blocks with dynamic arrays GPB2F405.248
!LL for buf and buf3 arrays. P.Burton GPB2F405.249
!LL 4.5 18/09/98 Corrected non-standard FORMAT statments GPB0F405.140
!LL P.Burton GPB0F405.141
!LL 4.5 28/05/98 Code for parallel processing in COEX Packing GBCQF405.41
!LL Author: Paul Burton & Bob Carruthers GBCQF405.42
CLL 4.5 28/02/96 Flush buffer for non-reinitializable files to try GDR8F405.30
CLL to avoid problems with continuation runs following GDR8F405.31
CLL hard failures. RTHBarnes. GDR8F405.32
CLL STWORK1A.25
CLL Programming standard: UM Doc Paper 3, version 2 (7/9/90) STWORK1A.26
CLL STWORK1A.27
CLL Logical components covered : C3, C4, C8 STWORK1A.28
CLL STWORK1A.29
CLL Project task: C4 STWORK1A.30
CLL STWORK1A.31
CLL External documentation : UMDP no C4 STWORK1A.32
CLL STWORK1A.33
C*L Interface and arguments: ------------------------------------------ STWORK1A.34
SUBROUTINE STWORK ( 4,60SF011193.51
*CALL ARGPPX 
GKR0F305.438
& D1,LEN_TOT,STASH_WORK,STASH_WORK_LEN,LENOUT, GPB2F405.250
*IF DEF,MPP GPB2F405.251
& global_LENOUT, GPB2F405.252
*ENDIF GPB2F405.253
& len_ocwork, GPB2F405.254
& IS,IM,ILSTART,ILEND,STEP,steps_per_period,secs_per_period, STWORK1A.38
& previous_time, STWORK1A.39
& STLIST,LEN_STLIST,TOTITEMS,SI,NSECTS,NITEMS, STWORK1A.40
& STASH_LEVELS,NUM_STASH_LEVELS,NUM_LEVEL_LISTS, STWORK1A.41
& STASH_PSEUDO_LEVELS,NUM_STASH_PSEUDO,NUM_PSEUDO_LISTS, STWORK1A.42
& MAX_STASH_LEVS,STTABL,NSTTIMS, STWORK1A.43
& NSTTABL,STASH_SERIES,STASH_SERIES_LEN, STWORK1A.44
& stash_series_rec_len,stash_series_index,stash_ser_index_size, STWORK1A.45
& MOS_MASK,MOS_MASK_LEN,MOS_OUTPUT_LENGTH, GPB0F403.2031
& PP_PACK_CODE,MODEL_FT_UNIT,FT_STEPS,FT_FIRSTSTEP, GRR1F404.4
& FIXHD,INTHD,REALHD,LEN_FIXHD,LEN_INTHD,LEN_REALHD, STWORK1A.48
& LEVDEPC,LEN1_LEVDEPC,LEN2_LEVDEPC, STWORK1A.49
& LOOKUP,RLOOKUP,LEN1_LOOKUP,LEN2_LOOKUP, STWORK1A.50
& PP_LEN2_LOOKUP,NUNITS,PP_LEN2_LOOK, RS030293.280
& LCYCLIC, GKR0F305.440
& T_rows,U_ROWS,ROW_LENGTH,T_field,U_FIELD,T_levels, STWORK1A.54
& FCST_PRD,RUN_INDIC_OP,ELF,FT_LASTFIELD, STWORK1A.55
& sm_ident,im_ident,dump_pack, GDR2F401.57
& stsuparrlen, stsuparr, istsuparr, sa_idx, sa_idxlen, GKR0F400.181
& ICODE,CMESSAGE) STWORK1A.56
C STWORK1A.57
IMPLICIT NONE STWORK1A.58
C STWORK1A.59
*CALL CSUBMODL GKR0F305.443
INTEGER STWORK1A.62
* TOTITEMS !IN MAX NO OF ITEMS IN STASHLIST STWORK1A.63
*, NSECTS !IN MAX NO OF SECTIONS STWORK1A.64
*, NITEMS !IN MAX NO OF ITEMS IN A SECTION STWORK1A.65
*, LEN_TOT !IN LENGTH OF REAL DATA ARRAY D1 STWORK1A.66
*, len_ocwork !IN Length of ocean work array OCWORK STWORK1A.67
*, LEN_FIXHD !IN LENGTH OF FIXED CONSTANTS STWORK1A.68
*, LEN_INTHD !IN LENGTH OF INTEGER CONSTANTS STWORK1A.69
*, LEN_REALHD !IN LENGTH OF REAL CONSTANTS STWORK1A.70
*, LEN1_LEVDEPC !IN First dimension of LEVDEPC STWORK1A.71
*, LEN2_LEVDEPC !IN Second dimension of LEVDEPC STWORK1A.72
*, NUM_STASH_LEVELS !IN DIMENSION OF STASH_LEVELS STWORK1A.73
*, NUM_LEVEL_LISTS !IN DIMENSION OF STASH_LEVELS STWORK1A.74
*, NUM_STASH_PSEUDO !IN Maximum no of pseudo-levels in a list STWORK1A.75
*, NUM_PSEUDO_LISTS !IN Number of pseudo-level lists STWORK1A.76
*, MAX_STASH_LEVS !IN Max no of output levels for any diag STWORK1A.77
*, LEN1_LOOKUP !IN First dimension of LOOKUP/IPPLOOK STWORK1A.78
*, LEN2_LOOKUP !IN Second dimension of LOOKUP STWORK1A.79
*, PP_LEN2_LOOKUP !IN Largest poss. value in PP_LEN2_LOOK STWORK1A.80
*, NUNITS !IN Max i/o FT unit no RS030293.282
*, PP_LEN2_LOOK(20:NUNITS)!IN Individual PP_LEN2_LOOKs per unit RS030293.283
*, PP_PACK_CODE(20:NUNITS)!IN Packing code per unit RS030293.284
*, FT_LASTFIELD(20:NUNITS)!IN Current write posn in each PP file RS030293.285
*, FT_STEPS(20:NUNITS) !IN File reinitialisation freq per unit RS030293.286
*, FT_FIRSTSTEP(20:NUNITS)!IN First step file initialised GRR1F404.5
*, NSTTIMS !IN Number of times against to test STWORK1A.85
*, NSTTABL !IN Number of STASH timetables STWORK1A.86
*, NUM_WORDS !IN Number of 64 Bit words to hold DATA STWORK1A.87
*, sm_ident !IN Submodel identifier GKR1F401.64
*, im_ident !IN Internal model identifier GKR0F305.445
&, dump_pack !IN Packing Indicator for Dump GDR2F401.58
&, sa_idxlen !IN Superarray index length GKR0F400.182
&, sa_idx(sa_idxlen) !IN Superarray index GKR0F400.183
&, stsuparrlen !IN Superarray index length GKR0F400.184
&, istsuparr(stsuparrlen)!IN Integer superarray GKR0F400.185
CHARACTER*80 NF171193.7
* MODEL_FT_UNIT(NUNITS) !IN Current table of file associations NF171193.8
NF171193.9
INTEGER STWORK1A.88
* FIXHD(LEN_FIXHD) !IN ARRAY OF FIXED CONSTANTS STWORK1A.89
*, PP_FIXHD(LEN_FIXHD)!IN Array of fixed constants from PP file STWORK1A.90
*, INTHD(LEN_INTHD) !IN ARRAY OF integer CONSTANTS STWORK1A.91
*, ILSTART !IN START OF LOOP OVER ENTRIES STWORK1A.92
*, ILEND !IN END OF LOOP OVER ENTRIES STWORK1A.93
*, IS !IN SECTION NUMBERS STWORK1A.94
*, IM !IN ITEM NUMBER STWORK1A.95
*, STEP !IN MODEL STEP NUMBER STWORK1A.96
*, steps_per_period !IN No of steps in defining period STWORK1A.97
*, secs_per_period !IN No of secs in period (define timestep) STWORK1A.98
*, previous_time(7) !IN Time at start of current step STWORK1A.99
*, LOOKUP(LEN1_LOOKUP,LEN2_LOOKUP) ! Integer LOOKUP headers STWORK1A.101
*, RLOOKUP(LEN1_LOOKUP,LEN2_LOOKUP) ! Real version of LOOKUP STWORK1A.102
*, ICODE !OUT RETURN CODE FROM ROUTINE STWORK1A.103
C STWORK1A.104
INTEGER STWORK1A.105
* LENOUT !IN Length of largest workfield needed STWORK1A.106
*IF DEF,MPP GPB2F405.255
&, global_LENOUT !IN Output length of largest field GPB2F405.256
*ENDIF GPB2F405.257
*, T_field !IN NO OF TEMP/PRESS POINTS STWORK1A.107
*, U_FIELD !IN NO OF U,V POINTS STWORK1A.108
*, ROW_LENGTH !IN No of points per row STWORK1A.109
*, U_ROWS !IN No of U,V, rows STWORK1A.110
*, T_rows !IN No of PRESS/TEMP rows STWORK1A.111
*, T_levels !IN No of model Press/Temp levels STWORK1A.112
*, STASH_WORK_LEN !IN LENGTH of STASH_WORK STWORK1A.113
&, MOS_MASK_LEN !IN Size of MOS_MASK array GPB0F403.2032
*, MOS_OUTPUT_LENGTH !IN No of MOS data pts extracted STWORK1A.114
*, LEN_STLIST !IN No of entries in STASHlist STWORK1A.115
*, STLIST(LEN_STLIST,TOTITEMS) !IN STASHLIST STWORK1A.116
*, SI(NITEMS,0:NSECTS,N_INTERNAL_MODEL) !IN STASH IN ADDRESS GKR0F305.449
*, STTABL(NSTTIMS,NSTTABL)!IN STASH TIME TABLES STWORK1A.118
*, STASH_LEVELS(NUM_STASH_LEVELS+1,NUM_LEVEL_LISTS) STWORK1A.119
*, STASH_PSEUDO_LEVELS(NUM_STASH_PSEUDO+1,NUM_PSEUDO_LISTS) STWORK1A.120
&, MOS_MASK(MOS_MASK_LEN) ! IN mask used to output data on MOS grid GPB0F403.2033
*, FCST_PRD !IN Forecast period STWORK1A.122
*, RUN_INDIC_OP !IN Operational Run indicator (ITAB) STWORK1A.123
C STASH timeseries information STWORK1A.124
*, STASH_SERIES_LEN ! IN no of STASH SERIES records STWORK1A.125
*, stash_series_rec_len ! IN length of each record STWORK1A.126
*, STASH_SERIES(stash_series_rec_len,STASH_SERIES_LEN) STWORK1A.127
C ! IN individual sample records STWORK1A.128
*, stash_ser_index_size ! IN no. of index blocks STWORK1A.129
*, stash_series_index(2,stash_ser_index_size) STWORK1A.130
C ! IN index block (1=start, 2=no of records) STWORK1A.131
*, EXPPXI ! Function to extract ppxref info GKR0F305.454
*, im_index ! Internal model index number GKR0F305.455
&, N1 ! Packing Indicator for Lookup(21) GDR2F401.59
C STWORK1A.132
CHARACTER*(80) CMESSAGE ! OUT MESSAGE FROM ROUTINE TS150793.245
C STWORK1A.134
C STWORK1A.135
LOGICAL STWORK1A.136
* LCYCLIC !IN TRUE if cyclic EW BCs STWORK1A.137
*, LAND(T_field) !IN land sea mask STWORK1A.138
*, ELF !IN True if the input grid is rotated Equatorial STWORK1A.139
C STWORK1A.140
STWORK1A.141
REAL STWORK1A.142
* D1(LEN_TOT) !IN REAL DATA ARRAY STWORK1A.143
*, REALHD(LEN_REALHD) !IN ARRAY OF REAL CONSTANTS STWORK1A.144
*, LEVDEPC(LEN1_LEVDEPC*LEN2_LEVDEPC+1) !IN level dep constants STWORK1A.145
*, STASH_WORK(STASH_WORK_LEN) !IN INPUT work array to STASH STWORK1A.146
&, stsuparr(stsuparrlen) !IN Real superarray GKR0F400.186
GKR0F400.187
C STWORK1A.157
C*---------------------------------------------------------------------- STWORK1A.158
C STWORK1A.159
C Common blocks and PARAMETERs STWORK1A.160
C STWORK1A.161
*CALL STPARAM STWORK1A.162
*CALL STERR STWORK1A.163
*CALL CPPXREF STWORK1A.164
*CALL PPXLOOK ! Contains *CALL VERSION GSS1F401.56
*CALL CLOOKADD STWORK1A.165
*CALL C_MDI STWORK1A.166
*IF DEF,MPP GPB1F402.2
*CALL PARVARS GPB1F402.3
*CALL DECOMPTP GPB1F402.4
*ENDIF GPB1F402.7
C STWORK1A.167
C Subroutines called STWORK1A.168
C STWORK1A.169
EXTERNAL STOCGT,SPATIAL,MULTI_SPATIAL,STLEVELS,TEMPORAL, STWORK1A.170
& PP_FILE,PP_HEAD,BUFFIN,BUFFOUT,EXPPXI,STWVGT GKR1F401.65
& ,GRIB_FILE,IOERROR,SETPOS,FILE_OPEN,FILE_CLOSE,FLUSH_BUFFER GDR8F405.33
C STWORK1A.172
C Local variables STWORK1A.173
C STWORK1A.174
REAL STWORK1A.175
* PPFIELD(LENOUT) ! Main internal work array STWORK1A.176
&, OCWORK(len_ocwork) ! Extra work array needed by ocean GKR0F400.188
& ! Also used by wave model in STWVGT. GKR1F401.66
C ! - reduced to minimum length in atmos case STWORK1A.178
*, AK_LEV(max_stash_levs) ! The values of A at output levels STWORK1A.179
*, BK_LEV(max_stash_levs) ! The values of B at output levels STWORK1A.180
*, LEVEL(max_stash_levs) ! The levels of the data as REAL nos STWORK1A.181
*, sample_prd ! Sampling period in hours for means, etc STWORK1A.182
*, A_IO ! The output code from the unit command. STWORK1A.183
C STWORK1A.184
*IF DEF,MPP GPB2F405.258
GPB2F405.259
! I/O buffer workspace arrays - used for holding the data to be GPB2F405.260
! written to disk. GPB2F405.261
GPB2F405.262
REAL GPB2F405.263
& buf(global_LENOUT) GPB2F405.264
&, buf3(global_LENOUT) GPB2F405.265
GPB2F405.266
CDIR$ CACHE_ALIGN buf,buf3 GPB2F405.267
GPB2F405.268
*IF DEF,T3E GPB2F405.269
! buf3 is used in direct shmem communications, so some extra stuff is GPB2F405.270
! required since it is not memory aligned: GPB2F405.271
GPB2F405.272
REAL remote_buf3(global_LENOUT) GPB2F405.273
POINTER (ptr_buf3,remote_buf3) GPB2F405.274
INTEGER address GPB2F405.275
COMMON /shmem_address_align/ address GPB2F405.276
GPB2F405.277
*ENDIF GPB2F405.278
*ENDIF GPB2F405.279
INTEGER STWORK1A.185
* IPPLOOK(LEN1_LOOKUP,PP_LEN2_LOOKUP) ! INTEGER LOOKUP TABLE STWORK1A.186
*, N_ROWS_OUT ! No of rows used for a diagnostic STWORK1A.187
*, N_COLS_OUT ! No of cols used PPHORIZ=N_ROWS*N_COLS_ STWORK1A.188
*, SROW_IN,SROW_OUT ! North, South, East and West STWORK1A.189
*, NROW_IN,NROW_OUT ! subdomain limits in the horizontal sense STWORK1A.190
*, WCOL_IN,WCOL_OUT ! corresponding to the subarea before being STWORK1A.191
*, ECOL_IN,ECOL_OUT ! processed (IN) and after processing (OUT) STWORK1A.192
*, LEV_IN_ADDR ! The num of pts skipped in the Input STWORK1A.193
*, GR ! Grid point code STWORK1A.194
*, LBPROC_COMP(14) ! Array of 1/0 denoting LBPROC components STWORK1A.195
*, UNITPP ! PPinit number (also used in PP_FILE) STWORK1A.196
*, LENBUF ! PPHORIZ_OUT rnd to 512 words (used PP) STWORK1A.197
*, COMP_ACCRCY ! PACKING ACCURACY IN POWER OF 2 STWORK1A.198
*, PPHORIZ_OUT ! No of points in the output field STWORK1A.199
*, PPHORIZ_IN ! No of points in the input field STWORK1A.200
*, IWA ! Record no used inSETPOS STWORK1A.201
*, LEN_BUF_WORDS ! Number of 64 Bit words (rounded to 512) STWORK1A.202
*, NUM_LEVS_OUT ! Number of output levels STWORK1A.203
*, NUM_LEVS_IN ! Number of input levels STWORK1A.204
*, NI ! Number of the INPUT STASH_LIST STWORK1A.205
*, NO ! Number of the OUTPUT STASH_LIST STWORK1A.206
*, INDX1 STWORK1A.207
*, INDEX_LEV(MAX_STASH_LEVS) ! Index used to relate input and STWORK1A.208
C ! output levels STWORK1A.209
*, level_list(MAX_STASH_LEVS) ! model level for each output level STWORK1A.210
*, pseudo_level(MAX_STASH_LEVS) ! pseudo-level at each output level STWORK1A.211
*, lv ! LV code for field from PP_XREF STWORK1A.212
*, samples ! no of samples (timeseries/trajec) STWORK1A.213
*, icurrll_dump_ptr ! pointer to mother record LOOKUP STWORK1A.214
*, start_time(7) ! start time for PPheader in STWORK1A.215
C ! timeseries/time mean/accumulation STWORK1A.216
*, no_records ! no of records processed by multi_spatial STWORK1A.217
*, record_start ! the start record for multi_spatial STWORK1A.218
&, PEXNER ! Exner Pressure GKR0F400.189
&, PSTAR ! Surface pressure GKR0F400.190
C GBC0F403.63
cdir$ cache_align ipplook GBC0F403.64
*CALL CNTL_IO GBC0F403.65
GKR0F400.191
INTEGER STWORK1A.219
& JL,II,IL,JJ,IT, STWORK1A.220
& ntab, ! Number of the STASH TIMES table STWORK1A.221
& IKOUNT, ! Local counter STWORK1A.222
& POINTS, ! No of points in a field STWORK1A.223
& POSN, ! Local temp variable STWORK1A.224
& KL, ! Local counter STWORK1A.225
& ML, ! Local counter STWORK1A.226
* LEN_IO, ! The length of data transferred. STWORK1A.227
* ILPREV, !The counter of the first of a pair of STLIST STWORK1A.228
* ILCURR, ! The current value of IL STWORK1A.229
* IWL, ! The word address of the LOOKUP table STWORK1A.230
* LBVCL, ! Vertical coordinate code in LOOKUP table STWORK1A.231
* ICURRLL, ! Current position in the PP Lookup table STWORK1A.232
* INT_LEVEL, ! Integer copy of level STWORK1A.233
* DUMP_PACKING, ! Copy of packing indicator in dump LOOKUP STWORK1A.234
* DUMP_DATA_TYPE,! Copy of data type in dump LOOKUP TJ140193.6
* I ! loop variable TJ140193.7
* ,J ! Level indicator used in call to GRIB_FILE GO261093.1
* ,PACKING_TYPE ! 0 No packing, 1 for WGDOS, 3 for GRIB GO261093.3
& ,GRIB_PACKING ! ppxref profile number used to determine GRS3F400.277
! grib packing method GRS3F400.278
INTEGER VX,VY,VZ ! SIZES OF ARRAYS. STWORK1A.236
&, st_grid ! Horizontal grid type, (eg. T-p or u-v) STWORK1A.237
*,LEN_PPNAME STWORK1A.238
INTEGER INPUT_CODE ! VALUE OF INPUT_CODE IN STASHLIST STWORK1A.239
INTEGER ADDR ! ADDRESS OF STASH VARIABLE IN EITHER DUMP OR STWORK1A.240
INTEGER ADDR_OUT ! ADDRESS OF SPATIALLY PROCESSED FIELD STWORK1A.241
INTEGER ELAP_TIME ! NO OF TIMESTEPS ELAPSED IN PERIOD. STWORK1A.243
INTEGER SERIES_PTR ! THE ADDRESS IN STASH_SERIES WHERE DOMIN INF STWORK1A.244
INTEGER INDEX_SIZE ! THE NUMBER OF LEVELS IN THE INDEX. STWORK1A.245
INTEGER BASE_LEVEL ! Base model level needed for mass weighting STWORK1A.246
INTEGER top_level ! Top model level for 3D ocean decompress STWORK1A.247
INTEGER base_level0,top_level0 ! Ref base/top levels in levs loop STWORK1A.248
INTEGER what_proc ! What kind of processing will be done STWORK1A.249
INTEGER what_mean ! What kind of meaning will be done STWORK1A.250
INTEGER output_code ! Output destination code from STLIST STWORK1A.251
INTEGER expected_len ! expected length of output field STWORK1A.252
INTEGER ocnlev_bottom ! first ocean level diagnosed STWORK1A.253
LOGICAL STWORK1A.254
& S_F ! TRUE for items requiring processing STWORK1A.255
&, OCEAN ! TRUE if processing an ocean diagnostic STWORK1A.256
&, LLPROC ! TRUE if spatial processing required STWORK1A.257
&, lnullproc ! TRUE if null processing indicated STWORK1A.258
&, lfullfield ! TRUE if output field on full horiz domain STWORK1A.259
&, lmasswt ! TRUE if level-by-level mass-weights exist TJ170993.9
&, start_step ! TRUE at start of time period (TEMPORAL) STWORK1A.260
&, end_step ! TRUE at end of time period (TEMPORAL) STWORK1A.261
&, MOS ! TRUE if MOS output is required STWORK1A.262
&, PACKING ! TRUE if packing required STWORK1A.263
&, GRIB_OUT ! TRUE if output to be in GRIB code. GO261093.4
&, ROTATE ! TRUE if input data to be rotated STWORK1A.265
CHARACTER*14 STWORK1A.266
& PPNAME ! PPfile name decoded from MODEL_FT_UNIT STWORK1A.267
CHARACTER*80 STWORK1A.268
& STRING ! PPfile name decoded from MODEL_FT_UNIT STWORK1A.269
STWORK1A.270
integer expected_extra ! expected length of extra data STWORK1A.271
INTEGER extraw ! number of extra words this timestep TJ140193.8
INTEGER extraw_hdr ! number of extra words for the header TJ140193.9
INTEGER data_type_code ! ppx_data_type code copied from PPX file GTJ0F400.12
INTEGER rotatecode ! code for rotated grid GKR0F305.464
INTEGER NT_DIM ! Number of tracers GKR0F400.192
INTEGER pointer_dummy ! dummy pointer variable for ocean GKR0F400.193
REAL RPPLOOK(64) GO261093.5
GPB1F402.8
*IF DEF,MPP GPB1F402.9
INTEGER GPB1F402.10
! local versions of the subdomain limits GPB1F402.11
& local_NROW_OUT,local_SROW_OUT,local_ECOL_OUT,local_WCOL_OUT GPB1F402.12
&, local_NROW_IN,local_SROW_IN,local_ECOL_IN,local_WCOL_IN GPB0F404.2
! global versions of the total size of output GPB1F402.13
&, global_N_ROWS_OUT,global_N_COLS_OUT, global_PPHORIZ_OUT GPB1F402.14
! MOS variables GPB0F403.2034
&, global_NROWS GPB0F403.2035
&, info ! return variable from GCOM GPB1F402.15
*IF DEF,MPP,AND,DEF,T3E GBCQF405.43
c GBCQF405.44
integer current_io_pe GBCQF405.45
c GBCQF405.46
data current_io_pe/0/ GBCQF405.47
*ENDIF GBCQF405.48
GPB0F403.2036
*ENDIF GPB1F402.16
*IF DEF,T3E,AND,DEF,MPP GDS3F403.2
GDS3F403.3
REAL GDS3F403.4
* IX ! RETURN VALUE FROM UNIT COMMAND GDS3F403.5
GDS3F403.6
integer LENGTH_FULLWRD,num_out,jjj GDS3F403.7
GDS3F403.8
integer len_buf_words_com,num_words_com GDS3F403.9
common/coex_com/len_buf_words_com,num_words_com GDS3F403.10
GDS3F403.11
*ENDIF GDS3F403.12
GPB0F403.2037
INTEGER GPB0F403.2038
& grid_type_code ! grid type of field being processed GPB0F403.2039
GPB0F403.2040
*IF DEF,MPP,AND,DEF,T3E GPB2F405.280
!-------------------------------------------------------------- GPB2F405.281
! Initialise address of buf3, required for later shmem communication GPB2F405.282
address=LOC(buf3) GPB2F405.283
CALL barrier() GPB2F405.284
GPB2F405.285
*ENDIF GPB2F405.286
CL---------------------------------------------------------------------- STWORK1A.273
CL 0. Initialise: set constants relating to input grid type and size STWORK1A.274
CL STWORK1A.275
CL 0.1 Set up internal grid type st_grid and input field size GKR0F305.462
CL according to the master GR code for the diagnostic GKR0F305.463
CL STWORK1A.278
GKR0F305.465
! Get internal model index GKR0F305.466
im_index = internal_model_index(im_ident) GKR0F305.467
NT_DIM = (sa_idx(2) - sa_idx(1))/2 GKR0F400.194
GKR0F305.468
if (im_ident .eq. ocean_im) then GKR0F400.195
OCEAN = .true. GKR0F400.196
else GKR0F400.197
OCEAN = .false. GKR0F400.198
endif GKR0F400.199
GKR0F400.200
if ((im_ident .eq. atmos_im) .or. (im_ident .eq. slab_im)) then GKR0F400.201
pexner = stsuparr(sa_idx(7)) GKR0F400.202
pstar = stsuparr(sa_idx(8)) GKR0F400.203
else GKR0F400.204
pointer_dummy = 1 GKR0F400.205
pexner = pointer_dummy GKR0F400.206
pstar = pointer_dummy GKR0F400.207
endif GKR0F400.208
GKR0F305.491
GKR0F305.492
! Get PP_XREF gridtype code GKR0F305.493
GR = EXPPXI( im_ident, IS, IM, ppx_grid_type, GKR0F305.494
*CALL ARGPPX GKR0F305.495
& icode, cmessage) GKR0F305.496
grid_type_code=GR GPB0F403.2041
GKR0F305.497
IF (GR.EQ.ppx_atm_tall.OR.GR.EQ.ppx_atm_tland.OR. STWORK1A.282
& GR.EQ.ppx_atm_tsea) THEN STWORK1A.283
C Atmosphere data on T-grid STWORK1A.284
st_grid=st_tp_grid STWORK1A.285
PPHORIZ_IN=T_field STWORK1A.286
ELSEIF (GR.EQ.ppx_atm_uall.OR.GR.EQ.ppx_atm_uland.OR. STWORK1A.287
& GR.EQ.ppx_atm_usea) THEN STWORK1A.288
C Atmosphere data on U-grid STWORK1A.289
st_grid=st_uv_grid STWORK1A.290
PPHORIZ_IN=U_FIELD STWORK1A.291
ELSEIF(GR.EQ.ppx_atm_compressed) THEN STWORK1A.292
C Atmosphere data on T-grid (compressed) STWORK1A.293
st_grid=st_tp_grid STWORK1A.294
PPHORIZ_IN=T_field STWORK1A.295
ELSEIF(GR.EQ.ppx_atm_cuall) THEN STWORK1A.296
C Atmosphere data on C-grid (u-points) STWORK1A.297
st_grid=st_cu_grid STWORK1A.298
PPHORIZ_IN=T_field STWORK1A.299
ELSEIF(GR.EQ.ppx_atm_cvall) THEN STWORK1A.300
C Atmosphere data on C-grid (v-points) STWORK1A.301
st_grid=st_cv_grid STWORK1A.302
PPHORIZ_IN=U_field STWORK1A.303
ELSEIF(GR.EQ.ppx_atm_tzonal) THEN STWORK1A.304
C Atmosphere zonal data on T-grid STWORK1A.305
st_grid=st_zt_grid STWORK1A.306
PPHORIZ_IN=T_rows STWORK1A.307
ELSEIF(GR.EQ.ppx_atm_uzonal) THEN STWORK1A.308
C Atmosphere zonal data on u-grid STWORK1A.309
st_grid=st_zu_grid STWORK1A.310
PPHORIZ_IN=u_rows STWORK1A.311
ELSEIF(GR.EQ.ppx_atm_tmerid) THEN STWORK1A.312
C Atmosphere meridional data on T-grid STWORK1A.313
st_grid=st_mt_grid STWORK1A.314
PPHORIZ_IN=row_length STWORK1A.315
ELSEIF(GR.EQ.ppx_atm_umerid) THEN STWORK1A.316
C Atmosphere meridional data on u-grid STWORK1A.317
st_grid=st_mu_grid STWORK1A.318
PPHORIZ_IN=row_length STWORK1A.319
ELSEIF(GR.EQ.ppx_atm_scalar) THEN STWORK1A.320
C Atmosphere scalar STWORK1A.321
st_grid=st_scalar STWORK1A.322
PPHORIZ_IN=1 STWORK1A.323
ELSEIF (GR.EQ.ppx_ocn_tcomp.OR.GR.EQ.ppx_ocn_tall.OR. STWORK1A.324
& GR.EQ.ppx_ocn_tfield) THEN STWORK1A.325
C Ocean data on T-grid (compressed/uncompressed) STWORK1A.326
st_grid=st_tp_grid STWORK1A.328
PPHORIZ_IN=T_field STWORK1A.329
ELSEIF (GR.EQ.ppx_ocn_ucomp.OR.GR.EQ.ppx_ocn_uall.OR. STWORK1A.330
& GR.EQ.ppx_ocn_ufield) THEN STWORK1A.331
C Ocean data on U-grid (compressed/uncompressed) STWORK1A.332
st_grid=st_uv_grid STWORK1A.334
PPHORIZ_IN=U_FIELD STWORK1A.335
ELSEIF(GR.EQ.ppx_ocn_cuall) THEN STWORK1A.336
C Ocean data on C-grid (u-points) STWORK1A.337
st_grid=st_cu_grid STWORK1A.339
PPHORIZ_IN=T_field STWORK1A.340
ELSEIF(GR.EQ.ppx_ocn_cvall) THEN STWORK1A.341
C Ocean data on C-grid (v-points) STWORK1A.342
st_grid=st_cv_grid STWORK1A.344
PPHORIZ_IN=U_field STWORK1A.345
ELSEIF(GR.EQ.ppx_ocn_tzonal) THEN TJ140193.10
C Ocean zonal data on T-grid STWORK1A.346
st_grid=st_zt_grid STWORK1A.348
PPHORIZ_IN=T_rows STWORK1A.349
ELSEIF(GR.EQ.ppx_ocn_uzonal) THEN TJ140193.11
C Ocean zonal data on u-grid STWORK1A.351
st_grid=st_zu_grid STWORK1A.353
PPHORIZ_IN=u_rows STWORK1A.354
ELSEIF(GR.EQ.ppx_ocn_tmerid) THEN TJ140193.12
C Ocean meridional data on T-grid STWORK1A.356
st_grid=st_mt_grid STWORK1A.358
PPHORIZ_IN=row_length STWORK1A.359
ELSEIF(GR.EQ.ppx_ocn_umerid) THEN TJ140193.13
C Ocean meridional data on u-grid STWORK1A.361
st_grid=st_mu_grid STWORK1A.362
PPHORIZ_IN=row_length STWORK1A.363
ELSEIF(GR.EQ.ppx_ocn_scalar) THEN TJ140193.14
C Ocean scalar STWORK1A.365
st_grid=st_scalar STWORK1A.367
PPHORIZ_IN=1 STWORK1A.368
ELSE STWORK1A.369
C Unknown grid type STWORK1A.370
ICODE=1 STWORK1A.371
CMESSAGE='STWORK : Unknown grid type found in PP_XREF' TJ170993.10
GOTO 999 STWORK1A.373
ENDIF STWORK1A.374
CL STWORK1A.375
CL 0.2 Set up ROTATE to flag fields which are rotated (eg. ELF winds) STWORK1A.376
CL (this is used to set alternative fieldcodes in PPHEAD) STWORK1A.377
CL STWORK1A.378
GKR0F305.498
rotatecode = EXPPXI( im_ident, IS, IM, ppx_rotate_code, GKR0F305.499
*CALL ARGPPX GKR0F305.500
& icode, cmessage) GKR0F305.501
GKR0F305.502
IF (rotatecode .EQ. ppx_elf_rotated .AND. ELF) GKR0F305.503
& THEN STWORK1A.380
ROTATE=.TRUE. STWORK1A.381
ELSE STWORK1A.382
ROTATE=.FALSE. STWORK1A.383
ENDIF STWORK1A.384
CL---------------------------------------------------------------------- STWORK1A.385
CL 1. Loop over entries with this section/item number STWORK1A.386
CL STWORK1A.387
DO 200 IL=ILSTART,ILEND !loop over num entries for each item/sec STWORK1A.388
extraw=0 ! no extra data by default TJ140193.15
*IF DEF,PRINT84 STWORK1A.389
WRITE(6,104) IL,IS,IM STWORK1A.390
*ENDIF STWORK1A.391
104 FORMAT(' MAIN LOOP IN STWORK IL/IS/IM ARE',I6,2X,I4,2X,I4) STWORK1A.392
C Set MOS flag if output PP unit indicates output to MOS file STWORK1A.393
MOS=(STLIST(st_output_code,IL).EQ.-89) STWORK1A.394
CL STWORK1A.395
CL 1.1 Set up S_F which has to be set for each STASHLIST entry. The STWORK1A.396
CL STASHFLAG is be set for a particular ITEM/SECTION the S_F for STWORK1A.397
CL the STASHLIST entry. STWORK1A.398
CL STWORK1A.399
S_F=.FALSE. STWORK1A.400
IF (STLIST(st_freq_code,IL).EQ.1.AND. STWORK1A.401
& STEP.GE.STLIST(st_start_time_code,IL).AND. STWORK1A.402
& (STEP.LE.STLIST(st_end_time_code,IL).OR. STWORK1A.403
& STLIST(st_end_time_code,IL).EQ.st_infinite_time)) THEN STWORK1A.404
C ... if required every step between start and end STWORK1A.405
S_F=.TRUE. STWORK1A.406
ELSEIF(STLIST(st_freq_code,IL).LT.0) THEN STWORK1A.407
C ... if required at specified times and this is one of them STWORK1A.408
NTAB=-STLIST(st_freq_code,IL) STWORK1A.409
DO 220 IT=1,NSTTIMS STWORK1A.410
IF (STTABL(IT,NTAB).EQ.st_end_of_list) GOTO 230 STWORK1A.411
IF (STEP.EQ.STTABL(IT,NTAB)) S_F=.TRUE. STWORK1A.412
220 CONTINUE STWORK1A.413
ELSEIF (STLIST(st_freq_code,IL).gt.0) THEN STWORK1A.414
IF (MOD((STEP-STLIST(st_start_time_code,IL)), STWORK1A.415
& STLIST(st_freq_code,IL)).EQ.0.AND. STWORK1A.416
& STEP.GE.STLIST(st_start_time_code,IL).AND. STWORK1A.417
& (STEP.LE.STLIST(st_end_time_code,IL).OR. STWORK1A.418
& STLIST(st_end_time_code,IL).EQ.st_infinite_time)) STWORK1A.419
C ... if required every N timesteps and this is one of them STWORK1A.420
& S_F=.TRUE. STWORK1A.421
ENDIF STWORK1A.422
230 CONTINUE STWORK1A.423
C STWORK1A.424
C S_F now set - Start of IF (S_F) block ....... STWORK1A.425
C STWORK1A.426
IF(S_F) THEN STWORK1A.427
CL STWORK1A.428
CL 1.2 Find number of input and output levels and relative positions STWORK1A.429
CL and set up levels and pseudo-levels arrays for PPheaders. STWORK1A.430
CL Set indicator lmasswt if level-by-level mass weighting possible TJ170993.11
CL - only currently available with atmosphere model full levels. TJ170993.12
CL STWORK1A.431
! special case of mean timeseries leave ilcurr pointing to il GRS1F404.159
GRS1F404.160
ilcurr=il ! The current STASHlist entry IL STWORK1A.432
IF (STLIST(st_input_code,IL).LT.0.and. GRS1F404.161
& STLIST(st_proc_no_code,IL).ne.st_time_series_mean) THEN GRS1F404.162
ilcurr=-STLIST(st_input_code,il) ! points to prev entry STWORK1A.434
ENDIF STWORK1A.435
C STWORK1A.436
GKR0F305.504
C Get PP_XREF lbvc code GKR0F305.505
lbvcl = EXPPXI( im_ident, IS, IM, ppx_lbvc_code, GKR0F305.506
*CALL ARGPPX GKR0F305.507
& icode, cmessage) GKR0F305.508
GKR0F305.509
C Get PP_XREF lv code GKR0F305.510
lv = EXPPXI( im_ident, IS, IM, ppx_lv_code, GKR0F305.511
*CALL ARGPPX GKR0F305.512
& icode, cmessage) GKR0F305.513
GKR0F305.514
C STWORK1A.439
IF (lv.EQ.ppx_full_level.AND.im_ident .NE. ocean_im) THEN GKR0F305.515
lmasswt=.TRUE. TJ170993.14
ELSE TJ170993.15
lmasswt=.FALSE. TJ170993.16
ENDIF TJ170993.17
C TJ170993.18
IF (lv.EQ.ppx_half_level) THEN STWORK1A.440
CALL STLEVELS(stlist(1,ilcurr),len_stlist, STWORK1A.441
+ stash_levels,num_stash_levels,num_level_lists, STWORK1A.442
+ stash_pseudo_levels,num_stash_pseudo,num_pseudo_lists, STWORK1A.443
+ max_stash_levs,num_levs_in,num_levs_out,index_size, STWORK1A.444
+ index_lev,level_list, STWORK1A.445
& lbvcl,stsuparr(sa_idx(3)),stsuparr(sa_idx(4)), ! akh,bkh GKR0F400.209
& level,pseudo_level,ak_lev,bk_lev, GKR0F400.210
+ icode,cmessage) STWORK1A.447
ELSE STWORK1A.448
CALL STLEVELS(stlist(1,ilcurr),len_stlist, STWORK1A.449
+ stash_levels,num_stash_levels,num_level_lists, STWORK1A.450
+ stash_pseudo_levels,num_stash_pseudo,num_pseudo_lists, STWORK1A.451
+ max_stash_levs,num_levs_in,num_levs_out,index_size, STWORK1A.452
+ index_lev,level_list, STWORK1A.453
& lbvcl,stsuparr(sa_idx(3)),stsuparr(sa_idx(4)), ! akh,bkh GKR0F400.211
& level,pseudo_level,ak_lev,bk_lev, GKR0F400.212
+ icode,cmessage) STWORK1A.455
ENDIF STWORK1A.456
IF (icode.gt.0) goto 999 STWORK1A.457
vz=num_levs_in STWORK1A.458
CL STWORK1A.459
CL 1.3 Find the horizontal dimensions for the output grid STWORK1A.460
CL and the input field subdomain limits in which processing happens. STWORK1A.461
CL STWORK1A.462
WCOL_IN= STLIST(st_west_code,ILCURR) ! Input subdomain limits STWORK1A.463
ECOL_IN= STLIST(st_east_code,ILCURR) STWORK1A.464
NROW_IN= STLIST(st_north_code,ILCURR) STWORK1A.465
SROW_IN= STLIST(st_south_code,ILCURR) STWORK1A.466
C STWORK1A.467
IF(MOS) THEN STWORK1A.468
CL STWORK1A.469
CL 1.3.1 MOS output uses hard-wired MOS_OUTPUT_LENGTH, samples,extraw=0 TJ010793.7
CL STWORK1A.471
PPHORIZ_OUT=MOS_OUTPUT_LENGTH STWORK1A.472
NROW_OUT=1 ! Used in PP_HEAD , so set to preserve orig grid STWORK1A.473
WCOL_OUT=1 ! " " " " " " " " " STWORK1A.474
N_ROWS_OUT=1 STWORK1A.475
N_COLS_OUT=MOS_OUTPUT_LENGTH STWORK1A.476
samples=0 STWORK1A.477
extraw_hdr=0 TJ010793.8
ELSE STWORK1A.478
CL STWORK1A.479
CL 1.3.2 Other output types need to calculate lengths in detail STWORK1A.480
CL (ie. number of rows, columns, and horizontal field size) STWORK1A.481
CL according to processing options STWORK1A.482
CL STWORK1A.483
*IF DEF,MPP GPB0F404.3
GPB0F404.4
! Calculate local versions of the subdomain limits and area GPB0F404.5
GPB0F404.6
CALL GLOBAL_TO_LOCAL_SUBDOMAIN( GPB0F404.7
& .TRUE.,.TRUE., GPB0F404.8
& grid_type_code,mype, GPB0F404.9
& NROW_IN,ECOL_IN,SROW_IN,WCOL_IN, GPB0F404.10
& local_NROW_IN,local_ECOL_IN, GPB0F404.11
& local_SROW_IN,local_WCOL_IN) GPB0F404.12
GPB0F404.13
*ENDIF GPB0F404.14
what_proc=stlist(st_proc_no_code,ilcurr) STWORK1A.484
what_mean=(stlist(st_gridpoint_code,ilcurr)/block_size)* STWORK1A.485
+ block_size STWORK1A.486
samples=0 ! Initialise value for non-timeseries STWORK1A.487
CL STWORK1A.488
CL 1.3.2.1 Time series or trajectory processing STWORK1A.489
CL STWORK1A.490
IF (what_proc.eq.st_time_series_code.or. STWORK1A.491
& what_proc.eq.st_append_traj_code.or. GRS1F404.163
& what_proc.eq.st_time_series_mean) THEN GRS1F404.164
CL STWORK1A.493
CL 1.3.2.2 Compute number of samples in period for timeseries for STWORK1A.494
CL input to PP_HEAD. STWORK1A.495
CL No of output rows and cols are set to the no of points STWORK1A.496
CL in each time sample and number of time samples in the STWORK1A.497
CL period spanned by the output field, respectively. STWORK1A.498
CL STWORK1A.499
samples=stlist(st_period_code,ilcurr)/ STWORK1A.500
& stlist(st_freq_code,ilcurr) STWORK1A.501
wcol_out=1 STWORK1A.502
ecol_out=samples STWORK1A.503
nrow_out=1 STWORK1A.504
srow_out=stlist(st_output_length,ilcurr)/samples STWORK1A.505
*IF DEF,MPP GPB0F404.15
local_WCOL_OUT=1 GPB0F404.16
local_ECOL_OUT=samples GPB0F404.17
local_NROW_OUT=1 GPB0F404.18
local_SROW_OUT=stlist(st_output_length,ilcurr)/samples GPB0F404.19
*ENDIF GPB0F404.20
CL 1.3.2.3 Multi spatial processing of some other type (not supported) STWORK1A.506
ELSEIF (stlist(st_series_ptr,ilcurr).ne.0) THEN STWORK1A.507
ICODE=1323 STWORK1A.508
CMESSAGE='STWORK : Illegal timeseries processing selected' TJ170993.19
GOTO 999 STWORK1A.510
CL 1.3.2.4 Primary record requesting an extract STWORK1A.511
ELSEIF (what_mean.eq.extract_base) THEN STWORK1A.512
WCOL_OUT= WCOL_IN STWORK1A.513
ECOL_OUT= ECOL_IN STWORK1A.514
NROW_OUT= NROW_IN STWORK1A.515
SROW_OUT= SROW_IN STWORK1A.516
*IF DEF,MPP GPB0F404.21
local_WCOL_OUT= local_WCOL_IN GPB0F404.22
local_ECOL_OUT= local_ECOL_IN GPB0F404.23
local_NROW_OUT= local_NROW_IN GPB0F404.24
local_SROW_OUT= local_SROW_IN GPB0F404.25
*ENDIF GPB0F404.26
CL 1.3.2.5 Primary record requesting a vertical mean STWORK1A.517
ELSEIF (what_mean.eq.vert_mean_base) THEN STWORK1A.518
WCOL_OUT= WCOL_IN STWORK1A.519
ECOL_OUT= ECOL_IN STWORK1A.520
NROW_OUT= NROW_IN STWORK1A.521
SROW_OUT= SROW_IN STWORK1A.522
*IF DEF,MPP GPB0F404.27
local_WCOL_OUT= local_WCOL_IN GPB0F404.28
local_ECOL_OUT= local_ECOL_IN GPB0F404.29
local_NROW_OUT= local_NROW_IN GPB0F404.30
local_SROW_OUT= local_SROW_IN GPB0F404.31
*ENDIF GPB0F404.32
CL 1.3.2.6 Primary record requesting a zonal mean STWORK1A.523
ELSEIF (what_mean.eq.zonal_mean_base) THEN STWORK1A.524
WCOL_OUT= 1 STWORK1A.525
ECOL_OUT= 1 STWORK1A.526
NROW_OUT= NROW_IN STWORK1A.527
SROW_OUT= SROW_IN STWORK1A.528
*IF DEF,MPP GPB0F404.33
local_WCOL_OUT= 1 GPB0F404.34
local_ECOL_OUT= 1 GPB0F404.35
local_NROW_OUT= local_NROW_IN GPB0F404.36
local_SROW_OUT= local_SROW_IN GPB0F404.37
*ENDIF GPB0F404.38
CL 1.3.2.7 Primary record requesting a meridional mean STWORK1A.529
ELSEIF (what_mean.eq.merid_mean_base) THEN STWORK1A.530
WCOL_OUT= WCOL_IN STWORK1A.531
ECOL_OUT= ECOL_IN STWORK1A.532
NROW_OUT= 1 STWORK1A.533
SROW_OUT= 1 STWORK1A.534
*IF DEF,MPP GPB0F404.39
local_WCOL_OUT= local_WCOL_IN GPB0F404.40
local_ECOL_OUT= local_ECOL_IN GPB0F404.41
local_NROW_OUT= 1 GPB0F404.42
local_SROW_OUT= 1 GPB0F404.43
*ENDIF GPB0F404.44
CL 1.3.2.8 Primary record requesting a global mean STWORK1A.535
ELSEIF (what_mean.eq.global_mean_base) THEN STWORK1A.536
WCOL_OUT= 1 STWORK1A.537
ECOL_OUT= 1 STWORK1A.538
NROW_OUT= 1 STWORK1A.539
SROW_OUT= 1 STWORK1A.540
*IF DEF,MPP GPB0F404.45
local_WCOL_OUT= 1 GPB0F404.46
local_ECOL_OUT= 1 GPB0F404.47
local_NROW_OUT= 1 GPB0F404.48
local_SROW_OUT= 1 GPB0F404.49
*ENDIF GPB0F404.50
CL 1.3.2.9 Primary record requesting a field mean STWORK1A.541
ELSEIF (what_mean.eq.field_mean_base) THEN STWORK1A.542
WCOL_OUT= 1 STWORK1A.543
ECOL_OUT= 1 STWORK1A.544
NROW_OUT= 1 STWORK1A.545
SROW_OUT= 1 STWORK1A.546
*IF DEF,MPP GPB0F404.51
local_WCOL_OUT= 1 GPB0F404.52
local_ECOL_OUT= 1 GPB0F404.53
local_NROW_OUT= 1 GPB0F404.54
local_SROW_OUT= 1 GPB0F404.55
*ENDIF GPB0F404.56
CL 1.3.2.10 Error trap for unknown request STWORK1A.547
ELSE ! Invalid option STWORK1A.548
icode=st_unknown STWORK1A.549
write(cmessage,87)'unknown option in setup',what_mean STWORK1A.550
goto 999 ! jump to error return STWORK1A.551
ENDIF STWORK1A.552
CL STWORK1A.553
CL 1.3.3 Compute expected length. This differs from total output length STWORK1A.554
CL when data is appended from multiple timesteps into the same STWORK1A.555
CL field, being output_length/number_of_appends in this case. STWORK1A.556
CL STWORK1A.557
IF (stlist(st_output_code,il).ge.0.and. STWORK1A.558
& (what_proc.eq.st_time_series_code.or. GRS1F404.165
& what_proc.eq.st_append_traj_code.or. GRS1F404.166
& what_proc.eq.st_time_series_mean)) THEN GRS1F404.167
series_ptr=stlist(st_series_ptr,il) !set up ptr to stashseries STWORK1A.561
expected_extra=(stash_series_index(2,series_ptr)+1)*6 STWORK1A.562
extraw_hdr=expected_extra TJ140193.17
expected_len=((stlist(st_output_length,ilcurr) STWORK1A.563
& -expected_extra)* STWORK1A.564
& stlist(st_freq_code,ilcurr))/stlist(st_period_code,ilcurr) STWORK1A.565
ELSE STWORK1A.566
expected_len=stlist(st_output_length,ilcurr) STWORK1A.567
expected_extra=0 ! no extra data for non timeseries stuff TJ140193.18
extraw_hdr=0 TJ140193.19
ENDIF STWORK1A.568
CL STWORK1A.569
CL 1.3.6 Compute number of rows and columns and field size for output STWORK1A.570
CL - first adjust easternmost column if field wraps EW STWORK1A.571
CL STWORK1A.572
IF (WCOL_IN .GT.ECOL_IN .AND.LCYCLIC) STWORK1A.573
*IF -DEF,MPP GPB1F402.41
& ECOL_IN =ECOL_IN +ROW_LENGTH STWORK1A.574
*ELSE GPB1F402.42
& ECOL_IN =ECOL_IN + glsize(1) GPB1F402.43
*ENDIF GPB1F402.44
IF (WCOL_OUT.GT.ECOL_OUT.AND.LCYCLIC) STWORK1A.575
*IF -DEF,MPP GPB1F402.45
& ECOL_OUT=ECOL_OUT+ROW_LENGTH STWORK1A.576
*ELSE GPB1F402.46
& ECOL_OUT=ECOL_OUT + glsize(1) GPB1F402.47
*ENDIF GPB1F402.48
C STWORK1A.577
*IF -DEF,MPP GPB1F402.49
N_ROWS_OUT= SROW_OUT - NROW_OUT + 1 STWORK1A.578
N_COLS_OUT= ECOL_OUT - WCOL_OUT + 1 STWORK1A.579
PPHORIZ_OUT= N_ROWS_OUT*N_COLS_OUT STWORK1A.580
*ELSE GPB1F402.50
GPB1F402.51
IF (local_WCOL_OUT .GT. local_ECOL_OUT) GPB0F403.2043
& local_ECOL_OUT=local_ECOL_OUT+ROW_LENGTH-2*Offx GPB0F404.57
GPB0F403.2045
N_ROWS_OUT = local_SROW_OUT - local_NROW_OUT + 1 GPB1F402.60
N_COLS_OUT = local_ECOL_OUT - local_WCOL_OUT + 1 GPB1F402.61
global_N_ROWS_OUT = SROW_OUT - NROW_OUT + 1 GPB1F402.62
global_N_COLS_OUT = ECOL_OUT - WCOL_OUT + 1 GPB1F402.63
GPB1F402.64
PPHORIZ_OUT= N_ROWS_OUT*N_COLS_OUT GPB1F402.65
global_PPHORIZ_OUT=global_N_ROWS_OUT*global_N_COLS_OUT GPB1F402.66
*ENDIF GPB1F402.67
GPB1F402.68
ENDIF ! End of MOS IF block STWORK1A.581
CL STWORK1A.582
CL 1.4 Check to see if any processing is required. STWORK1A.583
CL Set flag LLPROC if some SPATIAL processing indicated. STWORK1A.584
CL NB: If input and output bottom levels differ (or the input and TJ140193.20
CL output pseudo-levels lists differ), level-by-level TJ140193.21
CL processing in the SPATIAL loop IS required. STWORK1A.586
CL MULTI-SPATIAL processing is always required for timeseries. STWORK1A.587
CL STWORK1A.588
*IF -DEF,MPP GPB1F402.69
lfullfield=((st_grid.EQ.st_tp_grid .OR. st_grid.EQ.st_cu_grid) STWORK1A.589
& .AND. stlist(st_west_code,il).eq.1.and. STWORK1A.590
& stlist(st_east_code,il).eq.row_length.and. STWORK1A.591
& stlist(st_north_code,il).eq.1.and. STWORK1A.592
& stlist(st_south_code,il).eq.T_rows) .OR. STWORK1A.593
& ((st_grid.EQ.st_uv_grid .OR. st_grid.EQ.st_cv_grid) STWORK1A.594
& .AND. stlist(st_west_code,il).eq.1.and. STWORK1A.595
& stlist(st_east_code,il).eq.row_length.and. STWORK1A.596
& stlist(st_north_code,il).eq.1.and. STWORK1A.597
& stlist(st_south_code,il).eq.u_rows) .OR. STWORK1A.598
& ((st_grid.EQ.st_zt_grid) STWORK1A.599
& .AND. stlist(st_north_code,il).eq.1.and. STWORK1A.600
& stlist(st_south_code,il).eq.T_rows) .OR. STWORK1A.601
& ((st_grid.EQ.st_zu_grid) STWORK1A.602
& .AND. stlist(st_north_code,il).eq.1.and. STWORK1A.603
& stlist(st_south_code,il).eq.u_rows) .OR. STWORK1A.604
& ((st_grid.EQ.st_mt_grid .OR. st_grid.EQ.st_mu_grid) STWORK1A.605
& .AND. stlist(st_west_code,il).eq.1.and. STWORK1A.606
& stlist(st_east_code,il).eq.row_length) .OR. STWORK1A.607
& (st_grid.EQ.st_scalar) STWORK1A.608
*ELSE GPB1F402.70
lfullfield=((st_grid.EQ.st_tp_grid .OR. st_grid.EQ.st_cu_grid) GPB1F402.71
& .AND. stlist(st_west_code,il).eq.1.and. GPB1F402.72
& stlist(st_east_code,il).eq.glsize(1).and. GPB1F402.73
& stlist(st_north_code,il).eq.1.and. GPB1F402.74
& stlist(st_south_code,il).eq.glsize(2)) .OR. GPB1F402.75
& ((st_grid.EQ.st_uv_grid .OR. st_grid.EQ.st_cv_grid) GPB1F402.76
& .AND. stlist(st_west_code,il).eq.1.and. GPB1F402.77
& stlist(st_east_code,il).eq.glsize(1).and. GPB1F402.78
& stlist(st_north_code,il).eq.1.and. GPB1F402.79
& stlist(st_south_code,il).eq.glsize(2)-1) .OR. GPB1F402.80
& ((st_grid.EQ.st_zt_grid) GPB1F402.81
& .AND. stlist(st_north_code,il).eq.1.and. GPB1F402.82
& stlist(st_south_code,il).eq.glsize(2)) .OR. GPB1F402.83
& ((st_grid.EQ.st_zu_grid) GPB1F402.84
& .AND. stlist(st_north_code,il).eq.1.and. GPB1F402.85
& stlist(st_south_code,il).eq.glsize(2)-1) .OR. GPB1F402.86
& ((st_grid.EQ.st_mt_grid .OR. st_grid.EQ.st_mu_grid) GPB1F402.87
& .AND. stlist(st_west_code,il).eq.1.and. GPB1F402.88
& stlist(st_east_code,il).eq.glsize(1)) .OR. GPB1F402.89
& (st_grid.EQ.st_scalar) GPB1F402.90
*ENDIF GPB1F402.91
lnullproc= lfullfield .AND. STWORK1A.609
& (stlist(st_input_bottom,il).eq. STWORK1A.610
& stlist(st_output_bottom,il)) .and. STWORK1A.611
& (stlist(st_pseudo_in,il).eq. TJ140193.22
& stlist(st_pseudo_out,il)) .and. TJ140193.23
& (stlist(st_gridpoint_code,il).eq. STWORK1A.612
& (extract_base+stash_null_mask_code) .and. STWORK1A.613
& stlist(st_weight_code,IL).eq. STWORK1A.614
& stash_weight_null_code ) STWORK1A.615
IF (STLIST(st_series_ptr,IL).GT.0) THEN STWORK1A.616
lnullproc=.FALSE. ! Timeseries always requires processing STWORK1A.617
ENDIF STWORK1A.618
C LLPROC must be false for MOS output, output from a prev STLIST STWORK1A.619
C or simple extraction of full field with no weighting STWORK1A.620
IF (MOS .or. (STLIST(st_input_code,IL).LT.0.and. GRS1F404.168
& STLIST(st_proc_no_code,IL).ne.st_time_series_mean).or. GRS1F404.169
& lnullproc) THEN GRS1F404.170
LLPROC=.FALSE. STWORK1A.622
ELSE STWORK1A.623
LLPROC=.TRUE. STWORK1A.624
ENDIF STWORK1A.625
CL STWORK1A.626
CL 1.5 Check that no spatial processing is requested if the input field GTJ0F400.13
CL is of integer or logical type -- these types of fields can be GTJ0F400.14
CL passed directly through STASH, for example for coupling purposes, GTJ0F400.15
CL but no arithmetic is allowed at present. GTJ0F400.16
CL STWORK1A.630
data_type_code=EXPPXI(im_ident,IS,IM,ppx_data_type, GTJ0F400.17
*CALL ARGPPX GTJ0F400.18
& icode,cmessage) GTJ0F400.19
C GTJ0F400.20
IF (( data_type_code .EQ.ppx_type_int .OR. GTJ0F400.21
& data_type_code .EQ.ppx_type_log) .AND. GTJ0F400.22
& .NOT. lnullproc) THEN GTJ0F400.23
ICODE=st_not_supported STWORK1A.632
CMESSAGE='STWORK : Spatial processing of INT/LOGICAL illegal' GTJ0F400.24
GOTO 999 STWORK1A.634
ENDIF STWORK1A.635
CL---------------------------------------------------------------------- STWORK1A.636
CL 2. Perform spatial processing (loop over output levels) STWORK1A.637
CL STWORK1A.638
IF (LLPROC) THEN ! Processing is required STWORK1A.639
input_code=stlist(st_input_code,il) STWORK1A.640
CL make sure no volume processing asked for as not supported STWORK1A.641
CL this will need adding at some point STWORK1A.642
IF (stlist(st_weight_code,il).eq.stash_weight_volume_code) STWORK1A.643
+ THEN STWORK1A.644
icode=st_not_supported STWORK1A.645
cmessage='STWORK : volume processing not supported' STWORK1A.646
goto 999 STWORK1A.647
ENDIF STWORK1A.648
C Work out vx,vy (depends on kind of grid) STWORK1A.649
IF (st_grid.EQ.st_tp_grid.OR.st_grid.EQ.st_cu_grid) THEN GTJ1F304.34
vx=row_length ! T_rows x row_length STWORK1A.651
vy=T_rows ! worth of data in input field STWORK1A.652
ELSEIF (st_grid.EQ.st_uv_grid.OR.st_grid.EQ.st_cv_grid) THEN GTJ1F304.35
vx=row_length ! u_rows x row_length STWORK1A.654
vy=u_rows ! worth of data in input field STWORK1A.655
ELSEIF (st_grid.EQ.st_zt_grid) THEN STWORK1A.656
vx=1 ! T_rows x 1 STWORK1A.657
vy=T_rows ! worth of data in input field STWORK1A.658
ELSEIF (st_grid.EQ.st_zu_grid) THEN STWORK1A.659
vx=1 ! u_rows x 1 STWORK1A.660
vy=u_rows ! worth of data in input field STWORK1A.661
ELSEIF (st_grid.EQ.st_mt_grid .OR. st_grid.EQ.st_mu_grid) THEN STWORK1A.662
vx=row_length ! 1 x row_length STWORK1A.663
vy=1 ! worth of data in input field STWORK1A.664
ELSEIF (st_grid.EQ.st_scalar) THEN STWORK1A.665
vx=1 ! 1 x 1 STWORK1A.666
vy=1 ! worth of data in input field STWORK1A.667
ENDIF STWORK1A.668
CL Work out if this is the first timestep in a timeseries. TJ140193.24
CL This is required so that the extra data can be generated TJ140193.25
C STWORK1A.673
series_ptr=stlist(st_series_ptr,il) STWORK1A.674
IF (series_ptr.gt.0) THEN ! multi spatial processing reqd. STWORK1A.675
CL recompute expected sizes TJ140193.26
elap_time=step-stlist(st_start_time_code,il) STWORK1A.677
elap_time=mod(elap_time,stlist(st_period_code,il)) STWORK1A.678
start_step=(elap_time.eq.0) TJ140193.27
IF (start_step) THEN TJ140193.28
expected_len=stlist(st_output_length,ilcurr) TJ140193.29
ELSE TJ140193.30
expected_extra=0 ! reset to zero as no extra data TJ140193.31
expected_len=((stlist(st_output_length,ilcurr) TJ140193.32
& -((stash_series_index(2,series_ptr)+1)*6))* TJ140193.33
& stlist(st_freq_code,ilcurr))/stlist(st_period_code,ilcurr) TJ140193.34
ENDIF TJ140193.35
CL STWORK1A.685
CL 2.1 Timeseries extraction section follows STWORK1A.686
CL STWORK1A.687
no_records=stash_series_index(2,series_ptr) STWORK1A.688
record_start=stash_series_index(1,series_ptr) STWORK1A.689
CL STWORK1A.690
CL 2.1.0 Strip/decompress ocean fields using STOCGT if not already STWORK1A.691
CL processed - output result to ocwork STWORK1A.692
CL processed - output result to ocwork GKR1F401.69
CL Similarly decompress wave fields using STWVGT. GKR1F401.70
CL STWORK1A.693
IF (im_ident .eq. ocean_im) THEN GKR0F400.243
base_level=stlist(st_input_bottom,il) STWORK1A.695
top_level=stlist(st_input_top,il) STWORK1A.696
ocnlev_bottom=base_level STWORK1A.697
IF (base_level.LT.0.OR.base_level.EQ.st_special_code)THEN STWORK1A.698
base_level=1 STWORK1A.699
top_level =1 STWORK1A.700
ocnlev_bottom=1 STWORK1A.701
ENDIF STWORK1A.702
IF (input_code.eq.0) THEN STWORK1A.703
CALL STOCGT ( GKR0F400.213
*CALL ARGPPX GKR0F400.214
& t_rows,row_length,t_levels, GKR0F400.215
& im_ident,sm_ident, GKR1F401.67
& d1,im,is,base_level,top_level, GKR0F400.217
& ocnlev_bottom,rmdi,ocwork,vx,vy,vz, GKR0F400.218
& nt_dim,si,istsuparr(sa_idx(1)), ! joc_tracer GKR0F400.219
& istsuparr(sa_idx(2)), ! joc_u GKR0F400.220
& istsuparr(sa_idx(3)), ! joc_v GKR0F400.221
& istsuparr(sa_idx(6)), ! o_cfi1, GKR0F400.222
& istsuparr(sa_idx(7)), ! o_cfi2 GKR0F400.223
& istsuparr(sa_idx(8)), ! o_cfi3 GKR0F400.224
& istsuparr(sa_idx(4)), ! joc_no_seapts GKR0F400.225
& istsuparr(sa_idx(5)), ! joc_no_segs GKR0F400.226
& icode,cmessage) GKR0F400.227
IF (icode.GT.0) GOTO 999 TJ010793.9
ELSEIF (input_code.eq.1) THEN STWORK1A.707
CALL STOCGT ( GKR0F400.228
*CALL ARGPPX GKR0F400.229
& t_rows,row_length,t_levels, GKR0F400.230
& im_ident,sm_ident, GKR1F401.68
& stash_work,im,is,base_level,top_level, GKR0F400.232
& ocnlev_bottom,rmdi,ocwork,vx,vy,vz, GKR0F400.233
& nt_dim,si,istsuparr(sa_idx(1)), ! joc_tracer GKR0F400.234
& istsuparr(sa_idx(2)), ! joc_u GKR0F400.235
& istsuparr(sa_idx(3)), ! joc_v GKR0F400.236
& istsuparr(sa_idx(6)), ! o_cfi1, GKR0F400.237
& istsuparr(sa_idx(7)), ! o_cfi2 GKR0F400.238
& istsuparr(sa_idx(8)), ! o_cfi3 GKR0F400.239
& istsuparr(sa_idx(4)), ! joc_no_seapts GKR0F400.240
& istsuparr(sa_idx(5)), ! joc_no_segs GKR0F400.241
& icode,cmessage) GKR0F400.242
IF (icode.GT.0) GOTO 999 TJ010793.10
ENDIF STWORK1A.711
GKR1F401.71
ELSEIF (im_ident .eq. wave_im) THEN GKR1F401.72
GKR1F401.73
IF (input_code.eq.0) THEN GKR1F401.74
CALL STWVGT( GKR1F401.75
*CALL ARGPPX GKR1F401.76
& t_rows,row_length,im_ident,sm_ident, GKR1F401.77
& d1,im,is,rmdi,ocwork,vx,vy,si, GKR1F401.78
& istsuparr(sa_idx(1)), ! land-sea mask GKR1F401.79
& ICODE,CMESSAGE) GKR1F401.80
IF (icode.GT.0) GOTO 999 GKR1F401.81
GKR1F401.82
ELSEIF (input_code.eq.1) THEN GKR1F401.83
CALL STWVGT( GKR1F401.84
*CALL ARGPPX GKR1F401.85
& t_rows,row_length,im_ident,sm_ident, GKR1F401.86
& stash_work,im,is,rmdi,ocwork,vx,vy,si, GKR1F401.87
& istsuparr(sa_idx(1)), ! land-sea mask GKR1F401.88
& ICODE,CMESSAGE) GKR1F401.89
IF (icode.GT.0) GOTO 999 GKR1F401.90
ENDIF GKR1F401.91
ENDIF GKR1F401.92
CL STWORK1A.713
CL 2.1.1 Process a primary field from D1 (timeseries) STWORK1A.714
CL STWORK1A.715
IF (input_code.eq.0) THEN STWORK1A.716
IF (im_ident .eq.ocean_im) THEN GKR0F305.523
CALL MULTI_SPATIAL(ocwork, STWORK1A.718
+ vx,vy,vz,grid_type_code,st_grid,lcyclic,lmasswt, GPB0F403.2046
+ pphoriz_out,num_levs_out, STWORK1A.720
& d1(pexner), d1(pstar), GKR0F400.244
& stsuparr(sa_idx(5)), ! a_levdepc(jdelta_ak) GKR0F400.245
& stsuparr(sa_idx(6)), ! a_levdepc(jdelta_bk) GKR0F400.246
& stsuparr(sa_idx(9)), ! cos_p_latitude GKR0F400.247
& stsuparr(sa_idx(10)), ! cos_u_latitude GKR0F400.248
& stsuparr(sa_idx(11)), ! land GKR0F400.249
+ row_length,T_rows,u_rows,T_levels, STWORK1A.723
+ ppfield,lenout, TJ300394.17
+ rmdi,stlist(1,il),len_stlist, STWORK1A.725
+ stash_series(1,record_start), STWORK1A.726
+ stash_series_rec_len,no_records, STWORK1A.727
+ index_size,index_lev,level_list, STWORK1A.728
+ start_step,extraw,n_rows_out,n_cols_out, TJ140193.36
+ realhd,len_realhd,inthd,len_inthd,ocean, STWORK1A.730
+ icode,cmessage) STWORK1A.731
ELSE STWORK1A.732
addr=si(im,is,im_index) GKR0F305.524
CALL MULTI_SPATIAL(d1(addr), STWORK1A.734
+ vx,vy,vz,grid_type_code,st_grid,lcyclic,lmasswt, GPB0F403.2047
+ pphoriz_out,num_levs_out, STWORK1A.736
& d1(pexner), d1(pstar), GKR0F400.250
& stsuparr(sa_idx(5)), ! a_levdepc(jdelta_ak) GKR0F400.251
& stsuparr(sa_idx(6)), ! a_levdepc(jdelta_bk) GKR0F400.252
& stsuparr(sa_idx(9)), ! cos_p_latitude GKR0F400.253
& stsuparr(sa_idx(10)), ! cos_u_latitude GKR0F400.254
& stsuparr(sa_idx(11)), ! land GKR0F400.255
+ row_length,T_rows,u_rows,T_levels, STWORK1A.739
+ ppfield,lenout, TJ300394.18
+ rmdi,stlist(1,il),len_stlist, STWORK1A.741
+ stash_series(1,record_start), STWORK1A.742
+ stash_series_rec_len,no_records, STWORK1A.743
+ index_size,index_lev,level_list, STWORK1A.744
+ start_step,extraw,n_rows_out,n_cols_out, TJ140193.37
+ realhd,len_realhd,inthd,len_inthd,ocean, STWORK1A.746
+ icode,cmessage) STWORK1A.747
ENDIF STWORK1A.748
CL STWORK1A.749
CL 2.1.2 Process a field from STASHWORK (timeseries) STWORK1A.750
CL STWORK1A.751
ELSEIF (input_code.eq.1) THEN STWORK1A.752
IF (im_ident .eq.ocean_im) THEN GKR0F305.525
CALL MULTI_SPATIAL(ocwork, STWORK1A.754
+ vx,vy,vz,grid_type_code,st_grid,lcyclic,lmasswt, GPB0F403.2048
+ pphoriz_out,num_levs_out, STWORK1A.756
& d1(pexner), d1(pstar), GKR0F400.256
& stsuparr(sa_idx(5)), ! a_levdepc(jdelta_ak) GKR0F400.257
& stsuparr(sa_idx(6)), ! a_levdepc(jdelta_bk) GKR0F400.258
& stsuparr(sa_idx(9)), ! cos_p_latitude GKR0F400.259
& stsuparr(sa_idx(10)), ! cos_u_latitude GKR0F400.260
& stsuparr(sa_idx(11)), ! land GKR0F400.261
+ row_length,T_rows,u_rows,T_levels, STWORK1A.759
+ ppfield,lenout, TJ300394.19
+ rmdi,stlist(1,il),len_stlist, STWORK1A.761
+ stash_series(1,record_start), STWORK1A.762
+ stash_series_rec_len,no_records, STWORK1A.763
+ index_size,index_lev,level_list, STWORK1A.764
+ start_step,extraw,n_rows_out,n_cols_out, TJ140193.38
+ realhd,len_realhd,inthd,len_inthd,ocean, STWORK1A.766
+ icode,cmessage) STWORK1A.767
ELSE STWORK1A.768
addr=si(im,is,im_index) GKR0F305.526
CALL MULTI_SPATIAL(stash_work(addr), STWORK1A.770
+ vx,vy,vz,grid_type_code,st_grid,lcyclic,lmasswt, GPB0F403.2049
+ pphoriz_out,num_levs_out, STWORK1A.772
& d1(pexner), d1(pstar), GKR0F400.262
& stsuparr(sa_idx(5)), ! a_levdepc(jdelta_ak) GKR0F400.263
& stsuparr(sa_idx(6)), ! a_levdepc(jdelta_bk) GKR0F400.264
& stsuparr(sa_idx(9)), ! cos_p_latitude GKR0F400.265
& stsuparr(sa_idx(10)), ! cos_u_latitude GKR0F400.266
& stsuparr(sa_idx(11)), ! land GKR0F400.267
+ row_length,T_rows,u_rows,T_levels, STWORK1A.775
+ ppfield,lenout, TJ300394.20
+ rmdi,stlist(1,il),len_stlist, STWORK1A.777
+ stash_series(1,record_start), STWORK1A.778
+ stash_series_rec_len,no_records, STWORK1A.779
+ index_size,index_lev,level_list, STWORK1A.780
+ start_step,extraw,n_rows_out,n_cols_out, TJ140193.39
+ realhd,len_realhd,inthd,len_inthd,ocean, STWORK1A.782
+ icode,cmessage) STWORK1A.783
ENDIF STWORK1A.784
ELSEIF (input_code.lt.0) then STWORK1A.785
CL STWORK1A.786
CL 2.1.3 Process a field from previously STASHed position in D1 STWORK1A.787
CL (currently unsupported since diagnostic-of-diagnostic) STWORK1A.788
CL STWORK1A.789
IF (what_proc.eq.st_time_series_mean) THEN GRS1F404.171
! special case of mean timeseries GRS1F404.172
IF (im_ident .eq.ocean_im) THEN GRS1F404.173
! Warning never tested for ocean case GRS1F404.174
CALL MULTI_SPATIAL(ocwork, GRS1F404.175
+ vx,vy,vz,grid_type_code,st_grid,lcyclic,lmasswt, GRS1F404.176
+ pphoriz_out,num_levs_out, GRS1F404.177
& d1(pexner), d1(pstar), GRS1F404.178
& stsuparr(sa_idx(5)), ! a_levdepc(jdelta_ak) GRS1F404.179
& stsuparr(sa_idx(6)), ! a_levdepc(jdelta_bk) GRS1F404.180
& stsuparr(sa_idx(9)), ! cos_p_latitude GRS1F404.181
& stsuparr(sa_idx(10)), ! cos_u_latitude GRS1F404.182
& stsuparr(sa_idx(11)), ! land GRS1F404.183
+ row_length,T_rows,u_rows,T_levels, GRS1F404.184
+ ppfield,lenout, GRS1F404.185
+ rmdi,stlist(1,il),len_stlist, GRS1F404.186
+ stash_series(1,record_start), GRS1F404.187
+ stash_series_rec_len,no_records, GRS1F404.188
+ index_size,index_lev,level_list, GRS1F404.189
+ start_step,extraw,n_rows_out,n_cols_out, GRS1F404.190
+ realhd,len_realhd,inthd,len_inthd,ocean, GRS1F404.191
+ icode,cmessage) GRS1F404.192
ELSE GRS1F404.193
! Mother record GRS1F404.194
ILPREV=-stlist(st_input_code,IL) GRS1F404.195
! address of mother record in D1 GRS1F404.196
addr=stlist(20,ILPREV) GRS1F404.197
CALL MULTI_SPATIAL(D1(addr), GRS1F404.198
+ vx,vy,vz,grid_type_code,st_grid,lcyclic,lmasswt, GRS1F404.199
+ pphoriz_out,num_levs_out, GRS1F404.200
& d1(pexner), d1(pstar), GRS1F404.201
& stsuparr(sa_idx(5)), ! a_levdepc(jdelta_ak) GRS1F404.202
& stsuparr(sa_idx(6)), ! a_levdepc(jdelta_bk) GRS1F404.203
& stsuparr(sa_idx(9)), ! cos_p_latitude GRS1F404.204
& stsuparr(sa_idx(10)), ! cos_u_latitude GRS1F404.205
& stsuparr(sa_idx(11)), ! land GRS1F404.206
+ row_length,T_rows,u_rows,T_levels, GRS1F404.207
+ ppfield,lenout, GRS1F404.208
+ rmdi,stlist(1,il),len_stlist, GRS1F404.209
+ stash_series(1,record_start), GRS1F404.210
+ stash_series_rec_len,no_records, GRS1F404.211
+ index_size,index_lev,level_list, GRS1F404.212
+ start_step,extraw,n_rows_out,n_cols_out, GRS1F404.213
+ realhd,len_realhd,inthd,len_inthd,ocean, GRS1F404.214
+ icode,cmessage) GRS1F404.215
ENDIF GRS1F404.216
ELSE GRS1F404.217
icode=st_not_supported STWORK1A.790
cmessage='STWORK1 : diag-of-diagnostic unsupported' STWORK1A.791
goto 999 ! jump to error return STWORK1A.792
ENDIF GRS1F404.218
ELSE STWORK1A.793
icode=st_unknown STWORK1A.794
write(cmessage,87)'unknown input option',input_code STWORK1A.795
goto 999 STWORK1A.796
ENDIF STWORK1A.797
if (icode.ne.0) goto 999 ! error exit STWORK1A.798
IF (start_step.AND.(extraw.NE.expected_extra)) THEN TJ140193.40
icode=st_bad_array_param STWORK1A.800
write(cmessage,89) extraw,expected_extra STWORK1A.801
89 FORMAT('STWORK : Inconsistent length for extra data ', STWORK1A.802
& i8,1x,i8) STWORK1A.803
goto 999 STWORK1A.804
endif STWORK1A.805
C STWORK1A.806
CL pphoriz_out has been computed by multi_spatial TJ140193.41
CL it is the size of the output field TJ140193.42
ELSE ! do "normal" spatial processing STWORK1A.807
CL STWORK1A.808
CL 2.2 Standard spatial processing section follows STWORK1A.809
CL STWORK1A.810
CL In ocean case, a possibly 3D decompression is required (to top_level) STWORK1A.811
CL STWORK1A.812
CL If multi-level processing (ie. vertical, global mean) is performed by TJ170993.24
CL SPATIAL, the input field is passed in with the original start address TJ170993.25
CL but if single-level processing is done by SPATIAL, the field is TJ170993.26
CL passed in with an address pointing to the single level required. TJ170993.27
CL TJ170993.28
base_level0=stlist(st_input_bottom,il) STWORK1A.813
what_proc=stlist(st_gridpoint_code,il) TJ170993.29
IF (im_ident .eq.ocean_im) THEN GKR0F305.527
IF ((what_proc.LT.vert_mean_top .AND. STWORK1A.816
& what_proc.GT.vert_mean_base) .OR. STWORK1A.817
& (what_proc.LT.global_mean_top .AND. STWORK1A.818
& what_proc.GT.global_mean_base)) THEN STWORK1A.819
top_level0=stlist(st_input_top,il) STWORK1A.820
ELSE STWORK1A.821
top_level0=base_level0 STWORK1A.822
ENDIF STWORK1A.823
ENDIF STWORK1A.824
C STWORK1A.825
addr_out=1 ! Initialise output address TJ300394.21
C TJ300394.22
DO kl=1,num_levs_out ! --- Start of levels loop --- STWORK1A.826
C Work out model level if model level range, otherwise set to 1 STWORK1A.827
IF (base_level0.LT.0.OR.base_level0.EQ.st_special_code) STWORK1A.828
& THEN STWORK1A.829
base_level=1 STWORK1A.830
IF (im_ident .eq.ocean_im) THEN GKR0F305.528
top_level =1 STWORK1A.832
ocnlev_bottom=1 STWORK1A.833
ENDIF STWORK1A.834
ELSE STWORK1A.835
base_level=base_level0+index_lev(kl)-1 STWORK1A.836
IF (im_ident .eq.ocean_im) THEN GKR0F305.529
top_level=top_level0+index_lev(kl)-1 STWORK1A.838
ocnlev_bottom=stlist(st_input_bottom,il) STWORK1A.839
ENDIF STWORK1A.840
ENDIF STWORK1A.841
CL STWORK1A.842
CL 2.2.0 Strip/decompress ocean fields using STOCGT if not already STWORK1A.843
CL processed - output result to ocwork STWORK1A.844
CL NB: If 3D global mean is required, perform 3D decompress STWORK1A.845
CL between base_level and top_level. STWORK1A.846
CL STWORK1A.847
IF (im_ident .eq. ocean_im) THEN GKR1F401.93
IF (input_code.eq.0) THEN GKR1F401.94
CALL STOCGT ( GKR1F401.95
*CALL ARGPPX GKR0F400.269
& t_rows,row_length,t_levels, GKR0F400.270
& im_ident,sm_ident, GKR1F401.96
& d1,im,is,base_level,top_level, GKR0F400.272
& ocnlev_bottom,rmdi,ocwork,vx,vy,vz, GKR0F400.273
& nt_dim,si,istsuparr(sa_idx(1)), ! joc_tracer GKR0F400.274
& istsuparr(sa_idx(2)), ! joc_u GKR0F400.275
& istsuparr(sa_idx(3)), ! joc_v GKR0F400.276
& istsuparr(sa_idx(6)), ! o_cfi1, GKR0F400.277
& istsuparr(sa_idx(7)), ! o_cfi2 GKR0F400.278
& istsuparr(sa_idx(8)), ! o_cfi3 GKR0F400.279
& istsuparr(sa_idx(4)), ! joc_no_seapts GKR0F400.280
& istsuparr(sa_idx(5)), ! joc_no_segs GKR0F400.281
& icode,cmessage) GKR0F400.282
IF (icode.GT.0) GOTO 999 GKR1F401.97
ELSEIF (input_code.eq.1) THEN GKR1F401.98
CALL STOCGT ( GKR1F401.99
*CALL ARGPPX GKR0F400.284
& t_rows,row_length,t_levels, GKR0F400.285
& im_ident,sm_ident, GKR1F401.100
& stash_work,im,is,base_level,top_level, GKR0F400.287
& ocnlev_bottom,rmdi,ocwork,vx,vy,vz, GKR0F400.288
& nt_dim,si,istsuparr(sa_idx(1)), ! joc_tracer GKR0F400.289
& istsuparr(sa_idx(2)), ! joc_u GKR0F400.290
& istsuparr(sa_idx(3)), ! joc_v GKR0F400.291
& istsuparr(sa_idx(6)), ! o_cfi1, GKR0F400.292
& istsuparr(sa_idx(7)), ! o_cfi2 GKR0F400.293
& istsuparr(sa_idx(8)), ! o_cfi3 GKR0F400.294
& istsuparr(sa_idx(4)), ! joc_no_seapts GKR0F400.295
& istsuparr(sa_idx(5)), ! joc_no_segs GKR0F400.296
& icode,cmessage) GKR0F400.297
IF (icode.GT.0) GOTO 999 GKR1F401.101
ENDIF GKR1F401.102
GKR1F401.103
ELSEIF (im_ident .eq. wave_im) THEN GKR1F401.104
GKR1F401.105
IF (input_code.eq.0) THEN GKR1F401.106
CALL STWVGT( GKR1F401.107
*CALL ARGPPX GKR1F401.108
& t_rows,row_length,im_ident,sm_ident, GKR1F401.109
& d1,im,is,rmdi,ocwork,vx,vy,si, GKR1F401.110
& istsuparr(sa_idx(1)), ! land-sea mask GKR1F401.111
& ICODE,CMESSAGE) GKR1F401.112
IF (icode.GT.0) GOTO 999 GKR1F401.113
GKR1F401.114
ELSEIF (input_code.eq.1) THEN GKR1F401.115
CALL STWVGT( GKR1F401.116
*CALL ARGPPX GKR1F401.117
& t_rows,row_length,im_ident,sm_ident, GKR1F401.118
& stash_work,im,is,rmdi,ocwork,vx,vy,si, GKR1F401.119
& istsuparr(sa_idx(1)), ! land-sea mask GKR1F401.120
& ICODE,CMESSAGE) GKR1F401.121
IF (icode.GT.0) GOTO 999 GKR1F401.122
GKR1F401.123
ENDIF GKR1F401.124
ENDIF STWORK1A.856
CL STWORK1A.857
CL 2.2.1 Process a primary field from D1 (or ocwork if OCEAN field) STWORK1A.858
CL STWORK1A.859
IF (input_code.eq.0) THEN STWORK1A.860
if (im_ident .eq. ocean_im) then GKR0F305.538
CALL SPATIAL(ocwork,vx,vy,vz, TJ170993.30
+ grid_type_code,st_grid,lcyclic,lmasswt, GPB0F403.2050
+ n_cols_out,n_rows_out,base_level, STWORK1A.863
+ level_list,index_lev,index_size, STWORK1A.864
& d1(pexner), d1(pstar), GKR0F400.298
& stsuparr(sa_idx(5)), ! a_levdepc(jdelta_ak) GKR0F400.299
& stsuparr(sa_idx(6)), ! a_levdepc(jdelta_bk) GKR0F400.300
& stsuparr(sa_idx(9)), ! cos_p_latitude GKR0F400.301
& stsuparr(sa_idx(10)), ! cos_u_latitude GKR0F400.302
& stsuparr(sa_idx(11)), ! land GKR0F400.303
+ row_length,T_rows,u_rows,T_levels, STWORK1A.867
+ ppfield(addr_out),pphoriz_out, TJ300394.23
+ stlist(1,il),len_stlist,rmdi, STWORK1A.869
+ icode,cmessage) STWORK1A.870
ELSE STWORK1A.871
IF ((what_proc.LT.vert_mean_top .AND. TJ170993.32
& what_proc.GT.vert_mean_base) .OR. TJ170993.33
& (what_proc.LT.global_mean_top .AND. TJ170993.34
& what_proc.GT.global_mean_base)) THEN TJ170993.35
addr=si(im,is,im_index) GKR0F305.539
ELSE TJ170993.37
addr=si(im,is,im_index)+ GKR0F305.540
& (index_lev(kl)-1)*pphoriz_in GKR0F305.541
ENDIF TJ170993.39
IF (addr.lt.1.or.addr.gt.len_tot) THEN STWORK1A.873
icode=st_bad_address STWORK1A.874
cmessage='STWORK : D1 address out of bounds' STWORK1A.875
goto 999 STWORK1A.876
ENDIF STWORK1A.877
CALL SPATIAL(d1(addr),vx,vy,vz, TJ170993.40
+ grid_type_code,st_grid,lcyclic,lmasswt, GPB0F403.2051
+ n_cols_out,n_rows_out,base_level, STWORK1A.879
+ level_list,index_lev,index_size, STWORK1A.880
& d1(pexner), d1(pstar), GKR0F400.304
& stsuparr(sa_idx(5)), ! a_levdepc(jdelta_ak) GKR0F400.305
& stsuparr(sa_idx(6)), ! a_levdepc(jdelta_bk) GKR0F400.306
& stsuparr(sa_idx(9)), ! cos_p_latitude GKR0F400.307
& stsuparr(sa_idx(10)), ! cos_u_latitude GKR0F400.308
& stsuparr(sa_idx(11)), ! land GKR0F400.309
+ row_length,T_rows,u_rows,T_levels, STWORK1A.883
+ ppfield(addr_out),pphoriz_out, TJ300394.24
+ stlist(1,il),len_stlist,rmdi, STWORK1A.885
+ icode,cmessage) STWORK1A.886
ENDIF STWORK1A.887
CL STWORK1A.888
CL 2.2.2 Process a field from STASHWORK (or ocwork if OCEAN) STWORK1A.889
CL STWORK1A.890
ELSEIF (input_code.eq.1) THEN STWORK1A.891
IF (im_ident .eq. ocean_im) THEN GKR0F305.542
CALL SPATIAL(ocwork,vx,vy,vz, TJ170993.42
+ grid_type_code,st_grid,lcyclic,lmasswt, GPB0F403.2052
+ n_cols_out,n_rows_out,base_level, STWORK1A.894
+ level_list,index_lev,index_size, STWORK1A.895
& d1(pexner), d1(pstar), GKR0F400.310
& stsuparr(sa_idx(5)), ! a_levdepc(jdelta_ak) GKR0F400.311
& stsuparr(sa_idx(6)), ! a_levdepc(jdelta_bk) GKR0F400.312
& stsuparr(sa_idx(9)), ! cos_p_latitude GKR0F400.313
& stsuparr(sa_idx(10)), ! cos_u_latitude GKR0F400.314
& stsuparr(sa_idx(11)), ! land GKR0F400.315
+ row_length,T_rows,u_rows,T_levels, STWORK1A.898
+ ppfield(addr_out),pphoriz_out, TJ300394.25
+ stlist(1,il),len_stlist,rmdi, STWORK1A.900
+ icode,cmessage) STWORK1A.901
ELSE STWORK1A.902
IF ((what_proc.LT.vert_mean_top .AND. TJ170993.44
& what_proc.GT.vert_mean_base) .OR. TJ170993.45
& (what_proc.LT.global_mean_top .AND. TJ170993.46
& what_proc.GT.global_mean_base)) THEN TJ170993.47
addr=si(im,is,im_index) GKR0F305.543
ELSE TJ170993.49
addr=si(im,is,im_index)+ GKR0F305.544
& (index_lev(kl)-1)*pphoriz_in GKR0F305.545
ENDIF TJ170993.51
IF (addr.lt.1.or.addr.gt.stash_work_len) THEN STWORK1A.904
icode=st_bad_address STWORK1A.905
cmessage='STWORK : STASHWORK addr out of bounds' STWORK1A.906
goto 999 STWORK1A.907
ENDIF STWORK1A.908
CALL SPATIAL(stash_work(addr),vx,vy,vz, TJ170993.52
+ grid_type_code,st_grid,lcyclic,lmasswt, GPB0F403.2053
+ n_cols_out,n_rows_out,base_level, TJ170993.54
+ level_list,index_lev,index_size, STWORK1A.911
& d1(pexner), d1(pstar), GKR0F400.316
& stsuparr(sa_idx(5)), ! a_levdepc(jdelta_ak) GKR0F400.317
& stsuparr(sa_idx(6)), ! a_levdepc(jdelta_bk) GKR0F400.318
& stsuparr(sa_idx(9)), ! cos_p_latitude GKR0F400.319
& stsuparr(sa_idx(10)), ! cos_u_latitude GKR0F400.320
& stsuparr(sa_idx(11)), ! land GKR0F400.321
+ row_length,T_rows,u_rows,T_levels, STWORK1A.914
+ ppfield(addr_out),pphoriz_out, TJ300394.26
+ stlist(1,il),len_stlist,rmdi, STWORK1A.916
+ icode,cmessage) STWORK1A.917
ENDIF STWORK1A.918
ELSEIF (input_code.lt.0) THEN STWORK1A.919
CL STWORK1A.920
CL 2.2.3 Process a field from previously STASHed position in D1 STWORK1A.921
CL (currently unsupported since diagnostic-of-diagnostic) STWORK1A.922
CL STWORK1A.923
icode=st_not_supported STWORK1A.924
cmessage='STWORK1 : diag-of-diagnostic unsupported' STWORK1A.925
goto 999 STWORK1A.926
ELSE STWORK1A.927
icode=st_unknown STWORK1A.928
write(cmessage,87)'unknown input option',input_code STWORK1A.929
87 format('STWORK1 : >>FATAL ERROR <<',a,1x,i5) GPB0F405.142
goto 999 STWORK1A.931
ENDIF STWORK1A.932
C STWORK1A.933
IF (icode.gt.0) goto 999 ! Trap error STWORK1A.934
C STWORK1A.935
CL compute pphoriz_out TJ140193.43
CL pphoriz_out is the size of the output vector TJ140193.44
CL we should not be doing timeseries processing here. TJ140193.45
CL TJ300394.27
CL NOTE: n_cols_out and n_rows_out should agree with values calculated TJ300394.28
CL before, but are not checked for consistency. TJ300394.29
C TJ140193.46
pphoriz_out=n_cols_out*n_rows_out STWORK1A.936
addr_out=addr_out+pphoriz_out ! increment output address TJ140193.47
ENDDO ! --- End of levels loop --- STWORK1A.939
C STWORK1A.940
ENDIF ! End of multi-spatial/spatial IF block STWORK1A.941
C STWORK1A.942
IF (icode.gt.0) goto 999 ! Trap processing error STWORK1A.943
CL STWORK1A.944
CL 2.3 Set length of output field and check against expected length STWORK1A.945
CL STWORK1A.946
CL check that extrawords are the same as the expected number of extrawor STWORK1A.947
*IF DEF,MPP GPB1F402.98
! Calculate size of global pphoriz_out - the size on disk GPB1F402.99
GPB1F402.100
IF (what_proc .eq. st_time_series_code .OR. GRS1F404.219
& what_proc .eq. st_time_series_mean) THEN GRS1F404.220
global_pphoriz_out=pphoriz_out GPB0F403.2055
global_n_rows_out=n_rows_out GPB1F404.68
global_n_cols_out=n_cols_out GPB1F404.69
ELSE GPB0F403.2056
CALL STASH_GET_GLOBAL_SIZE( GPB0F403.2057
& stlist(st_north_code,il) , stlist(st_east_code,il), GPB0F403.2058
& stlist(st_south_code,il) , stlist(st_west_code,il), GPB0F403.2059
& 1, GPB0F403.2060
& STLIST(st_gridpoint_code,il) , STLIST(st_proc_no_code,il), GPB0F403.2061
& global_pphoriz_out, GPB0F403.2062
& ICODE, CMESSAGE) GPB0F403.2063
GPB1F402.108
IF (icode .ne. 0) goto 999 GPB0F403.2064
GPB0F403.2065
ENDIF GPB0F403.2066
GPB1F402.110
*ENDIF GPB1F402.111
IF (pphoriz_out*num_levs_out.ne.expected_len) THEN STWORK1A.948
icode=st_bad_array_param STWORK1A.949
write(cmessage,88) pphoriz_out*num_levs_out,expected_len STWORK1A.950
88 FORMAT('STWORK : Inconsistent length for output field ', STWORK1A.951
& i8,1x,i8) STWORK1A.952
goto 999 STWORK1A.953
ENDIF STWORK1A.954
ELSE STWORK1A.955
CL---------------------------------------------------------------------- STWORK1A.956
CL 3. No SPATIAL processing - extract output field by direct copy STWORK1A.957
CL STWORK1A.958
IF(MOS) THEN ! Mos OUTPUT STWORK1A.959
CL STWORK1A.960
CL 3.1 MOS output. STWORK1A.961
CL STWORK1A.962
C Establish which grid the data is on ie wind/pts temp/pts ocean etc STWORK1A.963
IF(st_grid.EQ.st_tp_grid.OR.st_grid.EQ.st_cu_grid) THEN STWORK1A.964
POINTS=T_field STWORK1A.965
*IF DEF,MPP GPB0F403.2067
global_NROWS=glsize(2) GPB0F403.2068
*ENDIF GPB0F403.2069
ELSE STWORK1A.966
POINTS=U_FIELD STWORK1A.967
*IF DEF,MPP GPB0F403.2070
global_NROWS=glsize(2)-1 GPB0F403.2071
*ENDIF GPB0F403.2072
ENDIF STWORK1A.968
IF(PPHORIZ_IN.NE.POINTS) THEN STWORK1A.969
ICODE=1 STWORK1A.970
CMESSAGE='STWORK : MOS input must be a complete field' STWORK1A.971
GOTO 999 STWORK1A.972
ENDIF STWORK1A.973
IKOUNT=0 STWORK1A.974
*IF -DEF,MPP GPB0F403.2073
DO 311 KL=1,NUM_LEVS_OUT STWORK1A.975
IF(STLIST(st_input_code,IL).LT.0) THEN ! previous entry STWORK1A.976
LEV_IN_ADDR=(KL-1)*PPHORIZ_IN STWORK1A.977
II=-STLIST(st_input_code,IL) STWORK1A.978
DO JL=1,PPHORIZ_IN STWORK1A.979
IF(MOS_MASK(JL).EQ.1) THEN STWORK1A.980
IKOUNT=IKOUNT+1 STWORK1A.981
POSN=LEV_IN_ADDR+JL-1 STWORK1A.982
PPFIELD(IKOUNT)=D1(STLIST(st_output_addr,II)+POSN) STWORK1A.983
ENDIF STWORK1A.984
ENDDO STWORK1A.985
ELSE ! Current STASH list STWORK1A.986
LEV_IN_ADDR=(INDEX_LEV(KL)-1)*PPHORIZ_IN STWORK1A.987
IF(STLIST(st_input_code,IL).EQ.0) THEN ! DATA in D1 STWORK1A.988
DO JL=1,PPHORIZ_IN STWORK1A.989
IF(MOS_MASK(JL).EQ.1) THEN STWORK1A.990
IKOUNT=IKOUNT+1 STWORK1A.991
POSN=LEV_IN_ADDR+JL-1 STWORK1A.992
PPFIELD(IKOUNT)=D1(SI(IM,IS,im_index)+POSN) GKR0F305.546
ENDIF STWORK1A.994
ENDDO STWORK1A.995
ELSE ! DATA in STWORK STWORK1A.996
DO JL=1,PPHORIZ_IN STWORK1A.997
IF (MOS_MASK(JL).EQ.1) THEN STWORK1A.998
IKOUNT=IKOUNT+1 STWORK1A.999
POSN=LEV_IN_ADDR+JL-1 STWORK1A.1000
PPFIELD(IKOUNT)=STASH_WORK(SI(IM,IS,im_index)+POSN) GKR0F305.547
ENDIF STWORK1A.1002
ENDDO STWORK1A.1003
ENDIF STWORK1A.1004
ENDIF STWORK1A.1005
311 CONTINUE STWORK1A.1006
*ELSE GPB0F403.2074
STWORK1A.1007
! Send the required field to PE 0 (buf), and pack into PPFIELD GPB0F403.2075
DO KL=1,NUM_LEVS_OUT GPB0F403.2076
GPB0F403.2077
! Gather the field into buf1 array on PE 0 GPB0F403.2078
GPB0F403.2079
IF(STLIST(st_input_code,IL).LT.0) THEN ! previous entry GPB0F403.2080
GPB0F403.2081
II=-STLIST(st_input_code,IL) GPB0F403.2082
LEV_IN_ADDR=(KL-1)*PPHORIZ_IN GPB0F403.2083
GPB0F403.2084
CALL GATHER_FIELD( GPB0F403.2085
& D1(STLIST(st_output_addr,II)+LEV_IN_ADDR),buf, GPB0F403.2086
& ROW_LENGTH,T_ROWS, GPB0F403.2087
& glsize(1),global_NROWS, GPB0F403.2088
& 0,gc_all_proc_group, GPB0F403.2089
& info) GPB0F403.2090
GPB0F403.2091
ELSE ! Current STASH list GPB0F403.2092
LEV_IN_ADDR=(INDEX_LEV(KL)-1)*PPHORIZ_IN GPB0F403.2093
GPB0F403.2094
IF (STLIST(st_input_code,IL).EQ.0) THEN ! DATA in D1 GPB0F403.2095
GPB0F403.2096
CALL GATHER_FIELD( GPB0F403.2097
& D1(SI(IM,IS,im_index)+LEV_IN_ADDR),buf, GPB0F403.2098
& ROW_LENGTH,T_ROWS, GPB0F403.2099
& glsize(1),global_NROWS, GPB0F403.2100
& 0,gc_all_proc_group, GPB0F403.2101
& info) GPB0F403.2102
GPB0F403.2103
ELSE ! DATA in STWORK GPB0F403.2104
GPB0F403.2105
CALL GATHER_FIELD( GPB0F403.2106
& STASH_WORK(SI(IM,IS,im_index)+LEV_IN_ADDR),buf, GPB0F403.2107
& ROW_LENGTH,T_ROWS, GPB0F403.2108
& glsize(1),global_NROWS, GPB0F403.2109
& 0,gc_all_proc_group, GPB0F403.2110
& info) GPB0F403.2111
GPB0F403.2112
ENDIF GPB0F403.2113
ENDIF GPB0F403.2114
GPB0F403.2115
! PE 0 must now pack the field using the mask in MOS_MASK GPB0F403.2116
! from the buf array into PPFIELD GPB0F403.2117
GPB0F403.2118
DO JL=1,glsize(1)*global_NROWS GPB0F403.2119
IF (MOS_MASK(JL).EQ.1) THEN GPB0F403.2120
IKOUNT=IKOUNT+1 GPB0F403.2121
GPB0F403.2122
IF (mype .EQ. 0) GPB0F403.2123
& PPFIELD(IKOUNT)=buf(JL) GPB0F403.2124
GPB0F403.2125
ENDIF GPB0F403.2126
ENDDO GPB0F403.2127
GPB0F403.2128
ENDDO ! KL : loop over output levels GPB0F403.2129
GPB0F403.2130
global_PPHORIZ_OUT=PPHORIZ_OUT GPB0F403.2131
global_N_ROWS_OUT=N_ROWS_OUT GPB0F403.2132
global_N_COLS_OUT=N_COLS_OUT GPB0F403.2133
GPB0F403.2134
*ENDIF GPB0F403.2135
GPB0F403.2136
IF(IKOUNT/NUM_LEVS_OUT.NE.PPHORIZ_OUT)THEN STWORK1A.1008
WRITE(6,*)'MOS_OUTPUT_LENGTH ',MOS_OUTPUT_LENGTH GIE0F403.639
WRITE(6,*)'IKOUNT ',IKOUNT GIE0F403.640
ICODE=1 STWORK1A.1011
CMESSAGE='STWORK MOS_OUTPUT_LENGTH not = to MOS_MASK' STWORK1A.1012
GOTO 999 STWORK1A.1013
ENDIF STWORK1A.1014
STWORK1A.1015
ELSE STWORK1A.1016
CL STWORK1A.1017
CL 3.2 Other output - determine input source STWORK1A.1018
CL STWORK1A.1019
input_code=STLIST(st_input_code,IL) STWORK1A.1020
CL STWORK1A.1021
CL 3.2.1 Ocean fields need to be stripped/decompressed using STOCGT STWORK1A.1022
CL if not already processed, and output to ppfield array STWORK1A.1023
CL except when input is already STASHed in D1 (input_code.lt.0) GMC1F403.4
CL STWORK1A.1024
IF ( (im_ident .eq. ocean_im).AND.(input_code.eq.0) ) THEN GMC1F403.5
base_level=stlist(st_input_bottom,il) STWORK1A.1026
C Set base_level to 1 for special level fields STWORK1A.1027
IF (base_level.eq.st_special_code) base_level=1 GKR1F401.127
CALL STOCGT ( GKR1F401.128
*CALL ARGPPX GKR0F400.325
& t_rows,row_length,t_levels, GKR0F400.326
& im_ident,sm_ident, GKR1F401.129
& d1,im,is,base_level,base_level+num_levs_out-1, GKR0F400.328
& base_level,rmdi,ppfield,vx,vy,vz, GKR0F400.329
& nt_dim,si,istsuparr(sa_idx(1)), ! joc_tracer GKR0F400.330
& istsuparr(sa_idx(2)), ! joc_u GKR0F400.331
& istsuparr(sa_idx(3)), ! joc_v GKR0F400.332
& istsuparr(sa_idx(6)), ! o_cfi1, GKR0F400.333
& istsuparr(sa_idx(7)), ! o_cfi2 GKR0F400.334
& istsuparr(sa_idx(8)), ! o_cfi3 GKR0F400.335
& istsuparr(sa_idx(4)), ! joc_no_seapts GKR0F400.336
& istsuparr(sa_idx(5)), ! joc_no_segs GKR0F400.337
& icode,cmessage) GKR0F400.338
IF (icode.GT.0) GOTO 999 GKR1F401.130
ELSEIF ((im_ident.eq.ocean_im).AND.(input_code.eq.1)) THEN GMC1F403.6
base_level=stlist(st_input_bottom,il) GKR1F401.132
C Set base_level to 1 for special level fields or input levels lists TJ010793.14
IF (base_level.LT.0.OR.base_level.EQ.st_special_code) GKR1F401.133
& base_level=1 GKR1F401.134
CALL STOCGT ( GKR0F400.339
*CALL ARGPPX GKR0F400.340
& t_rows,row_length,t_levels, GKR0F400.341
& im_ident,sm_ident, GKR1F401.135
& stash_work,im,is,base_level, GKR0F400.343
& base_level+num_levs_out-1, GKR0F400.344
& base_level,rmdi,ppfield,vx,vy,vz, GKR0F400.345
& nt_dim,si,istsuparr(sa_idx(1)), ! joc_tracer GKR0F400.346
& istsuparr(sa_idx(2)), ! joc_u GKR0F400.347
& istsuparr(sa_idx(3)), ! joc_v GKR0F400.348
& istsuparr(sa_idx(6)), ! o_cfi1, GKR0F400.349
& istsuparr(sa_idx(7)), ! o_cfi2 GKR0F400.350
& istsuparr(sa_idx(8)), ! o_cfi3 GKR0F400.351
& istsuparr(sa_idx(4)), ! joc_no_seapts GKR0F400.352
& istsuparr(sa_idx(5)), ! joc_no_segs GKR0F400.353
& icode,cmessage) GKR0F400.354
IF (icode.GT.0) GOTO 999 GKR1F401.136
CL GKR1F401.138
CL 3.2.1.1 Wave fields need to be stripped/decompressed using STWVGT GKR1F401.139
CL if not already processed, and output to ppfield array GKR1F401.140
CL except when input is already STASHed in D1 (input_code.lt.0) GMC1F403.7
CL GKR1F401.141
ELSEIF ((im_ident.eq.wave_im).AND.(input_code.eq.0)) THEN GMC1F403.8
CALL STWVGT( GKR1F401.145
*CALL ARGPPX GKR1F401.146
& t_rows,row_length,im_ident,sm_ident, GKR1F401.147
& d1,im,is,rmdi,ppfield,vx,vy,si, GKR1F401.148
& istsuparr(sa_idx(1)), ! land-sea mask GKR1F401.149
& ICODE,CMESSAGE) GKR1F401.150
IF (icode.GT.0) GOTO 999 GKR1F401.151
GKR1F401.152
ELSEIF ((im_ident.eq.wave_im).AND.(input_code.eq.1)) THEN GMC1F403.9
CALL STWVGT( GKR1F401.154
*CALL ARGPPX GKR1F401.155
& t_rows,row_length,im_ident,sm_ident, GKR1F401.156
& stash_work,im,is,rmdi,ppfield,vx,vy,si, GKR1F401.157
& istsuparr(sa_idx(1)), ! land-sea mask GKR1F401.158
& ICODE,CMESSAGE) GKR1F401.159
IF (icode.GT.0) GOTO 999 GKR1F401.160
GKR1F401.162
CL STWORK1A.1041
CL 3.2.2 Other fields are simply copied STWORK1A.1042
CL STWORK1A.1043
ELSEIF (input_code.eq.0) THEN STWORK1A.1044
C Simple extraction with no weighting from primary field in D1 STWORK1A.1045
C except for those needing special extraction on funny grids GMC1F403.10
C (Ocean, Wave) GMC1F403.11
addr=si(im,is,im_index) GKR0F305.556
DO JL=1,STLIST(st_output_length,IL) STWORK1A.1047
PPFIELD(JL)=D1(addr+JL-1) STWORK1A.1048
ENDDO STWORK1A.1049
ELSEIF (input_code.eq.1) THEN STWORK1A.1050
C Simple extraction with no weighting from STASH_WORK STWORK1A.1051
C except for those needing special extraction on funny grids GMC1F403.12
C (Ocean, Wave) GMC1F403.13
addr=si(im,is,im_index) GKR0F305.557
DO JL=1,STLIST(st_output_length,IL) STWORK1A.1053
PPFIELD(JL)=STASH_WORK(addr+JL-1) STWORK1A.1054
ENDDO STWORK1A.1055
ELSEIF (input_code.lt.0) THEN STWORK1A.1056
C Previously STASHed entry in D1 STWORK1A.1057
C for all sub-models as diagnostic D1 is always on a proper grid. GMC1F403.14
GMC1F403.15
addr=STLIST(st_output_addr,-input_code) STWORK1A.1058
DO JL=1,STLIST(st_output_length,IL) STWORK1A.1059
PPFIELD(JL)=D1(addr+JL-1) STWORK1A.1060
ENDDO STWORK1A.1061
ELSE STWORK1A.1062
C Illegal input code STWORK1A.1063
ICODE=st_unknown STWORK1A.1064
CMESSAGE='STWORK : Unknown input code encountered' STWORK1A.1065
GOTO 999 STWORK1A.1066
ENDIF STWORK1A.1067
ENDIF ! End of IF for test if MOS output STWORK1A.1068
ENDIF ! End of LLPROC IF BLOCK ************************ STWORK1A.1069
STWORK1A.1070
CL----------------------------------------------------------------- STWORK1A.1071
CL 4. OUTPUT section. STWORK1A.1072
CL STWORK1A.1073
CL The data is in PPFIELD with a length LENOUT. STWORK1A.1074
CL The horizontal field size PPHORIZ_OUT and number of output levels STWORK1A.1075
CL NUM_LEVS_OUT were calculated in section 1. STWORK1A.1076
CL Output option depends on the STLIST code. STWORK1A.1077
CL STWORK1A.1078
CL 4.0 Find mother STASHlist record if necessary. STWORK1A.1079
CL TJ140193.48
C Packing_type not set from PP_FILE in the ELSE IF part of block. GO261093.6
PACKING_TYPE = 0 ! Default is unpacked. GO261093.7
IF(STLIST(st_input_code,IL).LT.0) THEN ! Second of two STLIST STWORK1A.1083
ILPREV=-STLIST(st_input_code,IL) STWORK1A.1084
ELSE STWORK1A.1085
ilprev=IL ! no daughter record STWORK1A.1086
ENDIF STWORK1A.1087
CL STWORK1A.1088
CL 4.0.1 Set up LBPROC sub-components based on STASH processing info. STWORK1A.1089
CL STWORK1A.1090
DO JJ=1,14 STWORK1A.1091
LBPROC_COMP(JJ)=0 STWORK1A.1092
ENDDO STWORK1A.1093
C STWORK1A.1094
IF(STLIST(st_gridpoint_code,ilprev).GE.zonal_mean_base) STWORK1A.1095
& LBPROC_COMP(7)=1 STWORK1A.1096
C STWORK1A.1097
IF((STLIST(st_gridpoint_code,ilprev).GE.vert_mean_base .AND. STWORK1A.1098
& STLIST(st_gridpoint_code,ilprev).LT.vert_mean_top) .OR. STWORK1A.1099
& (STLIST(st_gridpoint_code,ilprev).GE.global_mean_base .AND. STWORK1A.1100
& STLIST(st_gridpoint_code,ilprev).LT.global_mean_top)) STWORK1A.1101
& LBPROC_COMP(12)=1 STWORK1A.1102
C STWORK1A.1103
IF((STLIST(st_proc_no_code,ilprev).EQ.st_accum_code) .OR. STWORK1A.1104
& (STLIST(st_proc_no_code,ilprev).EQ.st_time_mean_code).OR. GRS1F404.221
& (STLIST(st_proc_no_code,ilprev).EQ.st_time_series_mean)) GRS1F404.222
& LBPROC_COMP(8)=1 STWORK1A.1106
C STWORK1A.1107
IF(STLIST(st_proc_no_code,ilprev).EQ.st_min_code) STWORK1A.1108
& LBPROC_COMP(13)=1 STWORK1A.1109
C STWORK1A.1110
IF(STLIST(st_proc_no_code,ilprev).EQ.st_max_code) STWORK1A.1111
& LBPROC_COMP(14)=1 STWORK1A.1112
C STWORK1A.1113
output_code=STLIST(st_output_code,IL) STWORK1A.1114
CL STWORK1A.1115
CL 4.1 OUTPUT to PPfile STWORK1A.1116
CL STWORK1A.1117
IF (output_code.LT.0) THEN ! PP Output STWORK1A.1118
C Find appropriate dump header if a daughter record STWORK1A.1119
IF (il.ne.ilcurr) then STWORK1A.1120
icurrll_dump_ptr=stlist(st_lookup_ptr,ilcurr) STWORK1A.1121
ENDIF STWORK1A.1122
CL STWORK1A.1123
CL 4.1.0 Determine output PP unit and associated filename; OPEN file STWORK1A.1124
CL STWORK1A.1125
C If preattached files are used the file is left open by PPCTL following STWORK1A.1126
C the initial OPEN; if reinitialised files are used the unit must be STWORK1A.1127
C OPENed and CLOSEd explicitly every time it is used. STWORK1A.1128
C STWORK1A.1129
UNITPP=-output_code STWORK1A.1130
IF (FT_STEPS(UNITPP).NE.0) THEN ! Filename generated by model GMG1F404.347
! Check if re-initialised file stream has been opened yet GRR1F404.6
IF(STEP.LT.FT_FIRSTSTEP(UNITPP)) THEN ! File stream opened? GRR1F404.7
ICODE=1 GRR1F404.8
CMESSAGE='STWORK : Re-initialised file not yet created' GRR1F404.9
write(6,*) GRR1F404.10
& 'STWORK : FATAL ERROR. Attempt to write to ', GRR1F404.11
& 're-initialised file stream before file first opened:' GRR1F404.12
write(6,*) GRR1F404.13
& ' : Check that output on unit ',unitpp,' is not', GRR1F404.14
& ' requested before first initialisation of output file:' GRR1F404.15
write(6,*) GRR1F404.16
& ' : See UMUI window (Initialisation of PP file', GRR1F404.17
& 's) accessed from (Post Processing) from (Submodel ', GRR1F404.18
& 'independent).' GRR1F404.19
GO TO 999 GRR1F404.20
ENDIF ! File stream opened? GRR1F404.21
STRING=MODEL_FT_UNIT(UNITPP) STWORK1A.1132
DO JJ=80,1,-1 STWORK1A.1133
IF (STRING(JJ:JJ).EQ.'/') GOTO 411 TJ170993.55
ENDDO STWORK1A.1135
ICODE=1 STWORK1A.1136
CMESSAGE='STWORK : Illegal output PPfile name' STWORK1A.1137
GOTO 999 STWORK1A.1138
411 CONTINUE STWORK1A.1139
IF (JJ.GT.66) THEN STWORK1A.1140
PPNAME=STRING(JJ+1:80) STWORK1A.1141
ELSE STWORK1A.1142
PPNAME=STRING(JJ+1:JJ+14) STWORK1A.1143
ENDIF STWORK1A.1144
LEN_PPNAME=LEN(PPNAME) STWORK1A.1145
CALL FILE_OPEN(UNITPP,PPNAME,LEN_PPNAME,1,1,ICODE) GPB1F305.154
IF(ICODE.NE.0)GOTO990 STWORK1A.1147
ENDIF STWORK1A.1148
CL STWORK1A.1149
CL 4.1.1 Read in the pp fixed-length header STWORK1A.1150
CL STWORK1A.1151
IWA=0 STWORK1A.1152
CALL SETPOS(UNITPP,IWA,ICODE) GTD0F400.128
CALL BUFFIN(UNITPP,PP_FIXHD(1),LEN_FIXHD,LEN_IO,A_IO) STWORK1A.1154
IF(A_IO.NE.-1.0.OR.LEN_IO.NE.LEN_FIXHD) THEN STWORK1A.1155
CALL IOERROR('Buffer in fixed length header',A_IO,LEN_IO, STWORK1A.1156
& LEN_FIXHD) STWORK1A.1157
CMESSAGE='STWORK : I/O error - PP fixed length header' STWORK1A.1158
ICODE=1 STWORK1A.1159
RETURN STWORK1A.1160
ENDIF STWORK1A.1161
CL STWORK1A.1162
CL 4.1.2 Find the first available pp lookup record. GRR1F400.9
CL GRR1F400.10
ICURRLL=FT_LASTFIELD(UNITPP) ! Position of the last field GRR1F400.11
ICURRLL=ICURRLL+1 ! Position of the next field GRR1F400.12
CL GRR1F400.13
CL 4.1.3 Find the first available position for the next data record(s) GRR1F400.14
CL by reading last pp lookup record. GRR1F400.15
CL GRR1F400.16
IWL= PP_FIXHD(150)-1 ! NOTE for BUFFIN I/O the start address GRR1F400.17
C ! is zero for word 1. This is pointer GRR1F400.18
C ! to start of lookups. GRR1F400.19
IF(ICURRLL.EQ.1) THEN ! First record GRR1F400.20
IWA=PP_FIXHD(160)-1 ! Pointer to start of data GRR1F400.21
GRR1F400.22
ELSE GRR1F400.23
GRR1F400.24
C Point to start of last pp lookup record and read GRR1F400.25
CALL SETPOS(UNITPP,IWL+(ICURRLL-2)*LEN1_LOOKUP,ICODE) GRR1F400.26
CALL BUFFIN (UNITPP,IPPLOOK(1,ICURRLL-1), GRR1F400.27
& LEN1_LOOKUP,LEN_IO,A_IO) GRR1F400.28
C GRR1F400.29
IF(A_IO.NE.-1.0.OR.LEN_IO.NE.PP_FIXHD(151)) GRR1F400.30
& THEN GRR1F400.31
CALL IOERROR('Buffer in LOOKUP table ',A_IO,LEN_IO, GRR1F400.32
& PP_FIXHD(151)) GRR1F400.33
CMESSAGE='STWORK : I/O error - PP LOOKUP table ' GRR1F400.34
ICODE=2 GRR1F400.35
RETURN GRR1F400.36
ENDIF GRR1F400.37
C Pointer to next available data location in output file GRR1F400.38
IWA=IPPLOOK(LBEGIN,ICURRLL-1)+IPPLOOK(LBNREC,ICURRLL-1) GRR1F400.39
GRR1F400.40
ENDIF ! Test on first record GRR1F400.41
CL STWORK1A.1190
CL 4.1.4 If a daughter record is being processed then recover STWORK1A.1191
CL size information from dump LOOKUP header referenced by STWORK1A.1192
CL mother record (unless MOS output) STWORK1A.1193
CL STWORK1A.1194
IF (il.NE.ilcurr .AND. .NOT.MOS) THEN STWORK1A.1195
extraw_hdr=lookup(lbext,icurrll_dump_ptr) TJ140193.51
*IF -DEF,MPP GPB0F403.2137
pphoriz_out=lookup(lblrec,icurrll_dump_ptr) STWORK1A.1197
n_rows_out=lookup(lbrow,icurrll_dump_ptr) STWORK1A.1198
n_cols_out=lookup(lbnpt,icurrll_dump_ptr) STWORK1A.1199
*ELSE GPB0F403.2138
global_pphoriz_out=lookup(lblrec,icurrll_dump_ptr) GPB0F403.2139
global_n_rows_out=lookup(lbrow,icurrll_dump_ptr) GPB0F403.2140
global_n_cols_out=lookup(lbnpt,icurrll_dump_ptr) GPB0F403.2141
IF (what_proc.eq.st_time_series_mean) then GRS1F404.223
! As work is done on only PE 0 and copy to buf 3 uses pphoriz_out GRS1F404.224
! this must be reset. GRS1F404.225
pphoriz_out=global_pphoriz_out GRS1F404.226
n_rows_out=global_n_rows_out GRS1F404.227
n_cols_out=global_n_cols_out GRS1F404.228
endif GRS1F404.229
IF (what_proc .EQ. st_time_series_code) THEN GPB1F404.70
pphoriz_out=global_pphoriz_out GPB1F404.71
n_rows_out=global_n_rows_out GPB1F404.72
n_cols_out=global_n_cols_out GPB1F404.73
ENDIF GPB1F404.74
*ENDIF GPB0F403.2142
ENDIF STWORK1A.1200
CL STWORK1A.1201
CL 4.1.5 Check PP_PACK_CODE for GRIB output. Set GRIB flag and reset GO261093.11
CL PP_PACK_CODE to give packing profile. GO261093.12
IF(PP_PACK_CODE(UNITPP).GE.100)THEN GO261093.13
GRIB_OUT=.TRUE. GO261093.14
PP_PACK_CODE(UNITPP)=PP_PACK_CODE(UNITPP)-100 GO261093.15
GRIB_PACKING=PP_PACK_CODE(UNITPP) GRS3F400.279
ELSE GO261093.16
GRIB_OUT=.FALSE. GO261093.17
ENDIF GO261093.18
CL GO261093.19
CL 4.1.6 Set packing accuracy for output data field and buffer length GO261093.20
CL Multiple packing profiles are held in PP_XREF and chosen on a STWORK1A.1203
CL per-unit basis through PP_PACK_CODE. Profile 0 means unpacked. STWORK1A.1204
CL If the field has any extra data switch off packing. STWORK1A.1205
CL STWORK1A.1206
IF (PP_PACK_CODE(UNITPP).EQ.0.OR.extraw_hdr.NE.0) THEN TJ010793.18
PACKING=.FALSE. STWORK1A.1208
COMP_ACCRCY=-99 APS1F304.6
ELSE STWORK1A.1210
PACKING=.TRUE. STWORK1A.1211
comp_accrcy= EXPPXI( im_ident, IS, IM, GKR0F400.322
& ppx_packing_acc+PP_PACK_CODE(UNITPP)-1, GKR0F400.323
*CALL ARGPPX GKR0F305.559
& icode, cmessage) GKR0F305.560
ENDIF STWORK1A.1213
IF(GRIB_OUT) THEN ! reset packing code GRS3F304.187
PP_PACK_CODE(UNITPP)=PP_PACK_CODE(UNITPP)+100 GRS3F304.188
ENDIF GRS3F304.189
C STWORK1A.1214
*IF -DEF,MPP GPB1F402.112
LENBUF=((PPHORIZ_OUT+um_sector_size-1)/um_sector_size)* GBC0F403.66
2 um_sector_size ! Output length before pack GBC0F403.67
*ELSE GPB1F402.113
LENBUF=((global_PPHORIZ_OUT+um_sector_size-1)/um_sector_size)* GBC0F403.68
2 um_sector_size GBC0F403.69
! ! Output length before pack GPB1F402.115
*ENDIF GPB1F402.116
CL STWORK1A.1216
CL 4.2 Select routine to output data using logical GRIB. GO261093.8
CL If data to be output in grib code then call GRIB_FILE GO261093.9
CL If data to be output in PP code then call PP_FILE GO261093.10
CL STWORK1A.1218
*IF DEF,T3E,AND,DEF,MPP GDS3F403.13
IF(MOS.OR.GRIB_OUT.OR.NPROC.LT.NUM_LEVS_OUT.OR. GDS3F403.14
& NUM_LEVS_OUT.EQ.1)THEN GDS3F403.15
c GDS3F403.16
c Only use parallelised COEX if : GDS3F403.17
c GDS3F403.18
c (1) not MOS GDS3F403.19
c (2) not GRIB GDS3F403.20
c (3) NPROC > NUM_LEVS_OUT GDS3F403.21
c (4) NUM_LEVS_OUT > 1 GDS3F403.22
c GDS3F403.23
*ENDIF GDS3F403.24
DO II=1,NUM_LEVS_OUT ! --- Start of levels loop --- STWORK1A.1219
GPB1F402.117
*IF DEF,MPP GPB1F402.118
! Gather together distributed field to PE 0 GPB1F402.119
! Distributed data is in PP_FIELD, gathered data will be GPB1F402.120
! in the buf array GPB1F402.121
GPB1F402.122
IF ( MOS .OR. (what_proc.eq.st_time_series_code) .OR. GRS1F404.230
& (what_proc.eq.st_time_series_mean) ) THEN GRS1F404.231
! if it's either MOS or timeseries output - just copy on PE 0 GPB0F403.2144
GPB1F402.132
IF (mype .EQ. 0) THEN GPB0F403.2145
DO I=1,PPHORIZ_OUT GPB0F403.2146
buf(I)=PPFIELD(I+(II-1)*PPHORIZ_OUT) GPB0F403.2147
ENDDO GPB0F403.2148
ENDIF GPB0F403.2149
GPB0F403.2150
ELSE ! not MOS or timeseries output GPB0F403.2151
GPB0F403.2152
CALL STASH_GATHER_FIELD ( GPB0F403.2153
& PPFIELD(1+(II-1)*PPHORIZ_OUT) , buf, GPB0F403.2154
& PPHORIZ_OUT , global_PPHORIZ_OUT , 1, GPB0F403.2155
& stlist(st_north_code,il) , GPB0F403.2156
& stlist(st_west_code,il)+global_N_COLS_OUT-1, GPB0F403.2157
& stlist(st_north_code,il)+global_N_ROWS_OUT-1, GPB0F403.2158
& stlist(st_west_code,il), GPB0F403.2159
& grid_type_code,0,.TRUE., GPB0F403.2160
& ICODE,CMESSAGE) GPB0F403.2161
GPB0F403.2162
IF (ICODE .GT. 0) THEN GPB0F403.2163
WRITE(6,*) 'Error occured in STASH while gathering ', GPB0F403.2164
& 'data for output.' GPB0F403.2165
GOTO 999 GPB0F403.2166
ENDIF GPB0F403.2167
GPB0F403.2168
ENDIF ! IF (MOS) GPB0F403.2169
*ENDIF GPB1F402.138
GPB1F402.139
! Reset index for PP_HEAD if there is a levels list of hybrid levels GAB1F400.161
IF (stlist(st_output_bottom,il).lt.0.and.lbvcl.eq.9) THEN GAB1F400.162
JJ = level_list(II) GAB1F400.163
! or a range of model levels, as they may not be consecutive, GAB1F400.164
ELSE IF (stlist(st_output_bottom,il).ge.1.and. GAB1F400.165
& stlist(st_output_top,il).le.T_levels) THEN GAB1F400.166
JJ = level_list(II) GAB1F400.167
! otherwise use of level index is alright GAB1F400.168
ELSE GAB1F400.169
JJ = II GAB1F400.170
END IF GAB1F400.171
C GRR0F304.4
C Check that PP output file has sufficient headers pre-allocated GRR0F304.5
IF(ICURRLL.GT.PP_FIXHD(152)) THEN GRR0F304.6
ICODE=4 GRR0F304.7
WRITE(6,*) 'ERROR detected in routine STWORK: stop model' GRR0F304.8
WRITE(6,*) ': No. of output fields (=',ICURRLL,')', GRR0F304.9
& ' exceeds no. of reserved PP headers for unit ',UNITPP GRR0F304.10
CMESSAGE='STWORK : NO. OF FIELDS EXCEEDS RESERVED HEADERS' GRR0F304.11
GOTO 999 GRR0F304.12
ENDIF ! end no. of pp fields check GRR0F304.13
C GRR0F304.14
IF(GRIB_OUT) THEN GO261093.21
! GRS3F304.190
! NOTE cannot pack data into grib before pphead correctly setup GRS3F304.191
! GRS3F304.192
NUM_WORDS = -99 ! ie unset before call to pp_head GRS3F304.193
PACKING_TYPE=3 GO261093.23
ELSE GO261093.50
CL Pack data into PP code. GO261093.51
*IF -DEF,MPP GPB1F402.140
CALL PP_FILE(PPFIELD(1+(II-1)*PPHORIZ_OUT), STWORK1A.1220
*ELSE GPB1F402.141
*IF DEF,MPP,AND,DEF,T3E GBCQF405.49
c--call the parallel version of 'COEX' GBCQF405.50
*ELSE GBCQF405.51
IF (mype .EQ. 0) THEN GPB1F402.142
*ENDIF GBCQF405.52
GPB1F402.143
CALL PP_FILE(buf, GPB1F402.144
*ENDIF GPB1F402.145
1 LENBUF,NUM_WORDS,RMDI,COMP_ACCRCY, STWORK1A.1221
*IF -DEF,MPP GPB1F402.146
2 PPHORIZ_OUT,UNITPP,IWA,N_COLS_OUT,N_ROWS_OUT, STWORK1A.1222
*ELSE GPB1F402.147
2 global_PPHORIZ_OUT,UNITPP,IWA, GPB0F403.2170
& global_N_COLS_OUT,global_N_ROWS_OUT, GPB0F403.2171
*ENDIF GPB1F402.149
*IF DEF,MPP,AND,DEF,T3E GBCQF405.53
3 PACKING,PACKING_TYPE,current_io_pe,ICODE,CMESSAGE) GBCQF405.54
*ELSE GBCQF405.55
3 PACKING,PACKING_TYPE,ICODE,CMESSAGE) GO261093.52
*ENDIF GBCQF405.56
*IF DEF,MPP GPB1F402.150
*IF DEF,MPP,AND,DEF,T3E GBCQF405.57
GBCQF405.58
*ELSE GBCQF405.59
ENDIF ! (IF mype.eq.0) GPB1F402.151
*ENDIF GBCQF405.60
! Make sure all processors get the return code GPB1F402.152
GPB1F402.153
CALL GC_IBCAST(101,1,0,nproc,info,ICODE) GPB1F402.154
GPB1F402.155
*ENDIF GPB1F402.156
C Num_words is the no of 64 bit words required STWORK1A.1224
IF(ICODE.gt.0) THEN STWORK1A.1225
CMESSAGE='STWORK : Error in PP_FILE' STWORK1A.1226
GOTO 999 STWORK1A.1227
ENDIF STWORK1A.1228
ENDIF GO261093.53
LEN_BUF_WORDS=((NUM_WORDS+um_sector_size-1)/um_sector_size)* GBC0F403.70
2 um_sector_size ! No of words output GBC0F403.71
CL STWORK1A.1230
CL 4.2.1 Set STASH processing codes and sampling period for PPheader STWORK1A.1231
CL STWORK1A.1232
GR=STLIST(st_gridpoint_code,ILPREV)! Grid point code STWORK1A.1233
C Any time-processed field has a (non-zero) sample_prd set - STWORK1A.1234
C this will be translated by PP_HEAD into an LBTIM subcode IB of 2 STWORK1A.1235
sample_prd=0.0 STWORK1A.1236
IF(STLIST(st_proc_no_code,ILPREV).GT.st_replace_code) THEN STWORK1A.1237
sample_prd=REAL(STLIST(st_freq_code,ILPREV)*secs_per_period) STWORK1A.1238
& /REAL(steps_per_period*3600) STWORK1A.1239
ENDIF STWORK1A.1240
CL STWORK1A.1241
CL 4.2.2 Verification time comes from fixhd(28), current time fixhd(21) STWORK1A.1242
CL 2 cases that require consideration here: STWORK1A.1243
CL STWORK1A.1244
CL (1) this record is not a daughter record. STWORK1A.1245
CL in which case, set start_step=.true., verif time from fixhd STWORK1A.1246
CL present time also from fixhd STWORK1A.1247
CL STWORK1A.1248
CL (2) this record IS a daughter record. STWORK1A.1249
CL in which case, will need to retreive info on start_time STWORK1A.1250
CL from dump STWORK1A.1251
CL STWORK1A.1252
start_step=.true. STWORK1A.1253
IF (il.eq.ilcurr) THEN ! not daughter record STWORK1A.1254
CALL PP_HEAD( GKR0F305.561
*CALL ARGPPX GKR0F305.562
* im_ident,FIXHD,INTHD,REALHD, GKR0F305.563
1 LEN_FIXHD,LEN_INTHD,LEN_REALHD, STWORK1A.1257
2 IM,IS,GR,lfullfield, STWORK1A.1258
3 level(II),pseudo_level(II), GKR0F305.564
4 samples,start_step,fixhd(28),fixhd(21),LEN1_LOOKUP, STWORK1A.1260
5 extraw_hdr,IPPLOOK(1,ICURRLL),IPPLOOK(1,ICURRLL), TJ140193.52
*IF -DEF,MPP GPB1F402.157
6 N_COLS_OUT,NUM_WORDS,LEN_BUF_WORDS, STWORK1A.1262
7 N_ROWS_OUT,NROW_IN,SROW_IN,WCOL_IN,ECOL_IN, STWORK1A.1263
*ELSE GPB1F402.158
6 global_N_COLS_OUT,NUM_WORDS,LEN_BUF_WORDS, GPB1F402.159
7 global_N_ROWS_OUT,NROW_IN,SROW_IN,WCOL_IN,ECOL_IN, GPB1F402.160
*ENDIF GPB1F402.161
7 lbproc_comp,sample_prd, STWORK1A.1264
8 FCST_PRD,COMP_ACCRCY,PACKING_TYPE, GAB1F400.172
& st_grid,IWA,stsuparr(sa_idx(1)),stsuparr(sa_idx(2)), GAB1F400.173
& stsuparr(sa_idx(3)),stsuparr(sa_idx(4)), GAB1F400.174
& T_levels,JJ,ROTATE,ELF, GAB1F400.175
A OCEAN,LEVDEPC,LEN1_LEVDEPC, STWORK1A.1267
B ICODE,CMESSAGE) STWORK1A.1268
ELSE ! daughter record so start time is in dump STWORK1A.1269
C set up start_time from data in LOOKUP(lbyr,icurrll_dump_ptr) STWORK1A.1270
start_time(1)=LOOKUP(lbyr,icurrll_dump_ptr) STWORK1A.1271
start_time(2)=LOOKUP(lbmon,icurrll_dump_ptr) STWORK1A.1272
start_time(3)=LOOKUP(lbdat,icurrll_dump_ptr) STWORK1A.1273
start_time(4)=LOOKUP(lbhr,icurrll_dump_ptr) STWORK1A.1274
start_time(5)=LOOKUP(lbmin,icurrll_dump_ptr) STWORK1A.1275
start_time(7)=LOOKUP(lbday,icurrll_dump_ptr) STWORK1A.1276
CALL PP_HEAD( GKR0F305.565
*CALL ARGPPX GKR0F305.566
* im_ident,FIXHD,INTHD,REALHD, GKR0F305.567
1 LEN_FIXHD,LEN_INTHD,LEN_REALHD, STWORK1A.1279
2 IM,IS,GR,lfullfield, STWORK1A.1280
3 level(II),pseudo_level(II), GKR0F305.568
4 samples,start_step,start_time, STWORK1A.1282
4 fixhd(28),LEN1_LOOKUP, STWORK1A.1283
5 extraw_hdr,IPPLOOK(1,ICURRLL),IPPLOOK(1,ICURRLL), TJ140193.53
*IF -DEF,MPP GPB1F402.162
6 N_COLS_OUT,NUM_WORDS,LEN_BUF_WORDS, STWORK1A.1285
7 N_ROWS_OUT,NROW_IN,SROW_IN,WCOL_IN,ECOL_IN, STWORK1A.1286
*ELSE GPB1F402.163
6 global_N_COLS_OUT,NUM_WORDS,LEN_BUF_WORDS, GPB1F402.164
7 global_N_ROWS_OUT,NROW_IN,SROW_IN,WCOL_IN,ECOL_IN, GPB1F402.165
*ENDIF GPB1F402.166
7 lbproc_comp,sample_prd, STWORK1A.1287
8 FCST_PRD,COMP_ACCRCY,PACKING_TYPE, GAB1F400.176
& st_grid,IWA,stsuparr(sa_idx(1)),stsuparr(sa_idx(2)), GAB1F400.177
& stsuparr(sa_idx(3)),stsuparr(sa_idx(4)),T_levels,JJ, GAB1F400.178
A ROTATE,ELF,OCEAN,LEVDEPC,LEN1_LEVDEPC, STWORK1A.1290
B ICODE,CMESSAGE) STWORK1A.1291
ENDIF ! end if block over daughter/mother record STWORK1A.1292
GAB1F400.179
IF(ICODE.gt.0) GOTO 999 ! An error has occured GAB1F400.180
GRS3F304.194
IF(GRIB_OUT) THEN GRS3F304.195
! Now safe to call grib coder as pphead correctly set apart from GRS3F304.196
! length of data GRS3F304.197
CL Pack data into grib code GRS3F304.198
*IF -DEF,MPP GPB1F402.180
CALL GRIB_FILE(LEN1_LOOKUP,PP_LEN2_LOOKUP, GRS3F304.199
1 IPPLOOK,IPPLOOK,ICURRLL, GRS3F304.200
2 PPFIELD(1+(II-1)*PPHORIZ_OUT),PPHORIZ_OUT, GRS3F304.201
3 LENBUF,NUM_WORDS,UNITPP,IWA,GRIB_PACKING, GRS3F400.280
& ICODE,CMESSAGE) GRS3F400.281
*ELSE GPB1F402.181
IF (mype .EQ. 0) THEN GPB1F402.182
CALL GRIB_FILE(LEN1_LOOKUP,PP_LEN2_LOOKUP, GPB1F402.183
& IPPLOOK,IPPLOOK,ICURRLL, GPB1F402.184
& buf,global_PPHORIZ_OUT, GPB1F402.185
& LENBUF,NUM_WORDS,UNITPP,IWA,GRIB_PACKING, GPB1F402.186
& ICODE,CMESSAGE) GPB1F402.187
ENDIF ! (IF mype.eq.0) GPB1F402.188
GPB1F402.189
! Make sure all processors get the return code GPB1F402.190
GPB1F402.191
CALL GC_IBCAST(101,1,0,nproc,info,ICODE) GPB1F402.192
*ENDIF GPB1F402.193
IF(ICODE.gt.0)THEN GRS3F304.203
CMESSAGE='STWORK : Error in GRIB_FILE' GRS3F304.204
GOTO 990 GRS3F304.205
ENDIF GRS3F304.206
GRS3F304.207
ENDIF ! end of grib_out GRS3F304.208
GRS3F304.209
IWA=IPPLOOK(LBEGIN,ICURRLL)+IPPLOOK(LBNREC,ICURRLL) STWORK1A.1297
ICURRLL=ICURRLL+1 ! Update the counter STWORK1A.1298
icurrll_dump_ptr=icurrll_dump_ptr+1 STWORK1A.1299
C strictly only needs doing if a daughter record STWORK1A.1300
C STWORK1A.1301
ENDDO ! --- End of levels loop --- STWORK1A.1302
*IF DEF,T3E,AND,DEF,MPP GDS3F403.25
GDS3F403.26
ELSE ! PARALLELISE COEX GDS3F403.27
GDS3F403.28
DO II=1,NUM_LEVS_OUT ! --- Start of levels loop --- GDS3F403.29
GDS3F403.30
! Gather together distributed field to PE 0 GDS3F403.31
! Distributed data is in PP_FIELD, gathered data will be GDS3F403.32
! in the buf array GDS3F403.33
GDS3F403.34
CALL STASH_GATHER_FIELD ( GDS3F403.35
& PPFIELD(1+(II-1)*PPHORIZ_OUT) , buf, GDS3F403.36
& PPHORIZ_OUT , global_PPHORIZ_OUT , 1, GDS3F403.37
& stlist(st_north_code,il) , GDS3F403.38
& stlist(st_west_code,il)+global_N_COLS_OUT-1, GDS3F403.39
& stlist(st_north_code,il)+global_N_ROWS_OUT-1, GDS3F403.40
& stlist(st_west_code,il), GDS3F403.41
& grid_type_code,II-1,.TRUE., GDS3F403.42
& ICODE,CMESSAGE) GDS3F403.43
GDS3F403.44
IF (ICODE .GT. 0) THEN GDS3F403.45
WRITE(6,*) 'Error occured in STASH while gathering ', GDS3F403.46
& 'data for output.' GDS3F403.47
GOTO 999 GDS3F403.48
ENDIF GDS3F403.49
GDS3F403.50
ENDDO ! --- End of levels loop --- GDS3F403.51
c GDS3F403.52
c Code from PP_FILE GDS3F403.53
c GDS3F403.54
IF (mype .lt. NUM_LEVS_OUT) THEN GDS3F403.55
GDS3F403.56
LENGTH_FULLWRD=64 ! LENGTH IN BITS OF FULLWORD VAR GDS3F403.57
CL At this point packing,if required,will be done using the WGDOS GDS3F403.58
CL method of packing. GDS3F403.59
PACKING_TYPE=0 GDS3F403.60
C Note the value of -26 corresponds to -15 (F) in ppxref. GDS3F403.61
C The packing acuracy is scaled to allow greater accuracy. GDS3F403.62
C Packing will only be attempted if there are at least 2 points per row GDS3F403.63
C in the PPfield. GDS3F403.64
C GDS3F403.65
IF(PACKING.AND.COMP_ACCRCY.GT.-99.AND.global_N_COLS_OUT.GE.2) GDS3F403.66
& PACKING_TYPE=1 GDS3F403.67
C GDS3F403.68
IF(PACKING_TYPE.EQ.1)THEN GDS3F403.69
CALL COEX(buf,global_PPHORIZ_OUT,buf3,LENBUF, GDS3F403.70
& global_N_COLS_OUT, GDS3F403.71
& global_N_ROWS_OUT, GDS3F403.72
& NUM_OUT,COMP_ACCRCY,.TRUE.,RMDI,LENGTH_FULLWRD) GDS3F403.73
GDS3F403.74
NUM_WORDS=(NUM_OUT+1)/2 ! Round up to the nearest 64 Bit CRAY Wd GDS3F403.75
C COEX returns the number of IBM words needed to hold the packed data GDS3F403.76
C ~~~ GDS3F403.77
LEN_BUF_WORDS=((NUM_WORDS+um_sector_size-1)/um_sector_size)* GDS3F403.78
& um_sector_size ! No of words output GDS3F403.79
GDS3F403.80
GDS3F403.81
GDS3F403.83
ELSE ! No packing required. GDS3F403.84
DO 1 JJJ=1,global_PPHORIZ_OUT GDS3F403.85
buf3(JJJ) = buf(JJJ) GDS3F403.86
1 CONTINUE GDS3F403.87
NUM_WORDS=global_PPHORIZ_OUT GDS3F403.88
LEN_BUF_WORDS=LENBUF GDS3F403.89
ENDIF GDS3F403.90
DO JJJ=NUM_WORDS+1,LEN_BUF_WORDS GDS3F403.91
buf3(JJJ)= 0.0 GDS3F403.92
ENDDO GDS3F403.93
NUM_WORDS_com=NUM_WORDS GDS3F403.94
LEN_BUF_WORDS_com=LEN_BUF_WORDS GDS3F403.95
GDS3F403.96
endif GDS3F403.97
GDS3F403.98
call barrier() GDS3F403.99
GDS3F403.100
DO II=1,NUM_LEVS_OUT ! --- Start of levels loop --- GDS3F403.101
! Reset index for PP_HEAD if there is a levels list of hybrid levels GDS3F403.102
IF (stlist(st_output_bottom,il).lt.0.and.lbvcl.eq.9) THEN GDS3F403.103
JJ = level_list(II) GDS3F403.104
! or a range of model levels, as they may not be consecutive, GDS3F403.105
ELSE IF (stlist(st_output_bottom,il).ge.1.and. GDS3F403.106
& stlist(st_output_top,il).le.T_levels) THEN GDS3F403.107
JJ = level_list(II) GDS3F403.108
! otherwise use of level index is alright GDS3F403.109
ELSE GDS3F403.110
JJ = II GDS3F403.111
END IF GDS3F403.112
C GDS3F403.113
C Check that PP output file has sufficient headers pre-allocated GDS3F403.114
IF(ICURRLL.GT.PP_FIXHD(152)) THEN GDS3F403.115
ICODE=4 GDS3F403.116
WRITE(6,*) 'ERROR detected in routine STWORK: stop model' GDS3F403.117
WRITE(6,*) ': No. of output fields (=',ICURRLL,')', GDS3F403.118
& ' exceeds no. of reserved PP headers for unit ',UNITPP GDS3F403.119
CMESSAGE='STWORK : NO. OF FIELDS EXCEEDS RESERVED HEADERS' GDS3F403.120
GOTO 999 GDS3F403.121
ENDIF ! end no. of pp fields check GDS3F403.122
C GDS3F403.123
if(mype.eq.0)then GDS3F403.124
GDS3F403.125
GPB2F405.287
! Get the address of buf3 on the remote PE GPB2F405.288
CALL shmem_get(ptr_buf3,address,1,ii-1) GPB2F405.289
! So now, remote_buf3 on PE 0 will have the same address as buf3 on GPB2F405.290
! PE (ii-1) GPB2F405.291
if(num_levs_out.gt.1)then GDS3F403.126
call shmem_get(NUM_WORDS,NUM_WORDS_com,1,ii-1) GDS3F403.127
call shmem_get(LEN_BUF_WORDS,LEN_BUF_WORDS_com,1,ii-1) GDS3F403.128
call shmem_get(buf3,remote_buf3,LEN_BUF_WORDS,II-1) GPB2F405.292
endif GDS3F403.130
GDS3F403.131
CALL SETPOS_single(UNITPP,IWA,ICODE) GDS3F403.132
CALL BUFFOUT_single(UNITPP,buf3,LEN_BUF_WORDS,LEN_IO,IX) GDS3F403.133
GDS3F403.134
C GBC3F404.22
IF (IX.NE.-1.0.OR.LEN_IO.NE.LEN_BUF_WORDS) THEN GBC3F404.23
CALL IOERROR('Buffer out Data Field',IX,LEN_IO, GBC3F404.24
& LEN_BUF_WORDS) GBC3F404.25
CMESSAGE='STWORK : I/O error - PP Data Field Output' GBC3F404.26
ICODE=8 GBC3F404.27
RETURN GBC3F404.28
ENDIF GBC3F404.29
GBC3F404.30
endif GDS3F403.135
GDS3F403.136
! Make sure all processors get the return code GDS3F403.137
GDS3F403.138
CALL GC_IBCAST(101,1,0,nproc,info,ICODE) GDS3F403.139
GDS3F403.140
C Num_words is the no of 64 bit words required GDS3F403.141
IF(ICODE.gt.0) THEN GDS3F403.142
CMESSAGE='STWORK : Error in PP_FILE' GDS3F403.143
GOTO 999 GDS3F403.144
ENDIF GDS3F403.145
LEN_BUF_WORDS=((NUM_WORDS+um_sector_size-1)/um_sector_size)* GDS3F403.146
& um_sector_size ! No of words output GDS3F403.147
CL GDS3F403.148
CL 4.2.1 Set STASH processing codes and sampling period for PPheader GDS3F403.149
CL GDS3F403.150
GR=STLIST(st_gridpoint_code,ILPREV)! Grid point code GDS3F403.151
C Any time-processed field has a (non-zero) sample_prd set - GDS3F403.152
C this will be translated by PP_HEAD into an LBTIM subcode IB of 2 GDS3F403.153
sample_prd=0.0 GDS3F403.154
IF(STLIST(st_proc_no_code,ILPREV).GT.st_replace_code) THEN GDS3F403.155
sample_prd=REAL(STLIST(st_freq_code,ILPREV)*secs_per_period) GDS3F403.156
& /REAL(steps_per_period*3600) GDS3F403.157
ENDIF GDS3F403.158
CL GDS3F403.159
CL 4.2.2 Verification time comes from fixhd(28), current time fixhd(21) GDS3F403.160
CL 2 cases that require consideration here: GDS3F403.161
CL GDS3F403.162
CL (1) this record is not a daughter record. GDS3F403.163
CL in which case, set start_step=.true., verif time from fixhd GDS3F403.164
CL present time also from fixhd GDS3F403.165
CL GDS3F403.166
CL (2) this record IS a daughter record. GDS3F403.167
CL in which case, will need to retreive info on start_time GDS3F403.168
CL from dump GDS3F403.169
CL GDS3F403.170
start_step=.true. GDS3F403.171
IF (il.eq.ilcurr) THEN ! not daughter record GDS3F403.172
CALL PP_HEAD( GDS3F403.173
*CALL ARGPPX GDS3F403.174
* im_ident,FIXHD,INTHD,REALHD, GDS3F403.175
1 LEN_FIXHD,LEN_INTHD,LEN_REALHD, GDS3F403.176
2 IM,IS,GR,lfullfield, GDS3F403.177
3 level(II),pseudo_level(II), GDS3F403.178
4 samples,start_step,fixhd(28),fixhd(21),LEN1_LOOKUP, GDS3F403.179
5 extraw_hdr,IPPLOOK(1,ICURRLL),IPPLOOK(1,ICURRLL), GDS3F403.180
6 global_N_COLS_OUT,NUM_WORDS,LEN_BUF_WORDS, GDS3F403.181
7 global_N_ROWS_OUT,NROW_IN,SROW_IN,WCOL_IN,ECOL_IN, GDS3F403.182
7 lbproc_comp,sample_prd, GDS3F403.183
8 FCST_PRD,COMP_ACCRCY,PACKING_TYPE, GDS3F403.184
& st_grid,IWA,stsuparr(sa_idx(1)),stsuparr(sa_idx(2)), GDS3F403.185
& stsuparr(sa_idx(3)),stsuparr(sa_idx(4)), GDS3F403.186
& T_levels,JJ,ROTATE,ELF, GDS3F403.187
A OCEAN,LEVDEPC,LEN1_LEVDEPC, GDS3F403.188
B ICODE,CMESSAGE) GDS3F403.189
ELSE ! daughter record so start time is in dump GDS3F403.190
C set up start_time from data in LOOKUP(lbyr,icurrll_dump_ptr) GDS3F403.191
start_time(1)=LOOKUP(lbyr,icurrll_dump_ptr) GDS3F403.192
start_time(2)=LOOKUP(lbmon,icurrll_dump_ptr) GDS3F403.193
start_time(3)=LOOKUP(lbdat,icurrll_dump_ptr) GDS3F403.194
start_time(4)=LOOKUP(lbhr,icurrll_dump_ptr) GDS3F403.195
start_time(5)=LOOKUP(lbmin,icurrll_dump_ptr) GDS3F403.196
start_time(7)=LOOKUP(lbday,icurrll_dump_ptr) GDS3F403.197
CALL PP_HEAD( GDS3F403.198
*CALL ARGPPX GDS3F403.199
* im_ident,FIXHD,INTHD,REALHD, GDS3F403.200
1 LEN_FIXHD,LEN_INTHD,LEN_REALHD, GDS3F403.201
2 IM,IS,GR,lfullfield, GDS3F403.202
3 level(II),pseudo_level(II), GDS3F403.203
4 samples,start_step,start_time, GDS3F403.204
4 fixhd(28),LEN1_LOOKUP, GDS3F403.205
5 extraw_hdr,IPPLOOK(1,ICURRLL),IPPLOOK(1,ICURRLL), GDS3F403.206
6 global_N_COLS_OUT,NUM_WORDS,LEN_BUF_WORDS, GDS3F403.207
7 global_N_ROWS_OUT,NROW_IN,SROW_IN,WCOL_IN,ECOL_IN, GDS3F403.208
7 lbproc_comp,sample_prd, GDS3F403.209
8 FCST_PRD,COMP_ACCRCY,PACKING_TYPE, GDS3F403.210
& st_grid,IWA,stsuparr(sa_idx(1)),stsuparr(sa_idx(2)), GDS3F403.211
& stsuparr(sa_idx(3)),stsuparr(sa_idx(4)),T_levels,JJ, GDS3F403.212
A ROTATE,ELF,OCEAN,LEVDEPC,LEN1_LEVDEPC, GDS3F403.213
B ICODE,CMESSAGE) GDS3F403.214
ENDIF ! end if block over daughter/mother record GDS3F403.215
GDS3F403.216
IF(ICODE.gt.0) GOTO 999 ! An error has occured GDS3F403.217
GDS3F403.218
IWA=IPPLOOK(LBEGIN,ICURRLL)+IPPLOOK(LBNREC,ICURRLL) GDS3F403.219
ICURRLL=ICURRLL+1 ! Update the counter GDS3F403.220
icurrll_dump_ptr=icurrll_dump_ptr+1 GDS3F403.221
C strictly only needs doing if a daughter record GDS3F403.222
C GDS3F403.223
ENDDO ! --- End of levels loop --- GDS3F403.224
ENDIF ! PARALLELISE COEX GDS3F403.225
*ENDIF GDS3F403.226
FT_LASTFIELD(UNITPP)=ICURRLL-1 ! Position of the last field STWORK1A.1303
CL STWORK1A.1304
CL 4.3 Write out the pp lookup table IPPLOOK (RPPLOOK) and close file STWORK1A.1305
CL if reinitialisation possible. STWORK1A.1306
CL Otherwise force last buffer to be written to file to avoid GDR8F405.34
CL problems with continuation runs following hard failures. GDR8F405.35
CL STWORK1A.1307
CL Write out only pp lookups for records written this call. GRR1F400.42
CL Point to the start of the current lookup record. GRR1F400.43
IWA = IWL + (ICURRLL-NUM_LEVS_OUT-1)*LEN1_LOOKUP GRR1F400.44
CALL SETPOS(UNITPP,IWA,ICODE) GTD0F400.130
CALL BUFFOUT (UNITPP,IPPLOOK(1,ICURRLL-NUM_LEVS_OUT), GRR1F400.45
* LEN1_LOOKUP*NUM_LEVS_OUT,LEN_IO,A_IO) GRR1F400.46
C GRR1F400.47
IF (A_IO.NE.-1.0.OR.LEN_IO.NE.PP_FIXHD(151)*NUM_LEVS_OUT) GRR1F400.48
& THEN STWORK1A.1314
CALL IOERROR('Buffer out LOOKUP table ',A_IO,LEN_IO, STWORK1A.1315
& PP_FIXHD(151)) STWORK1A.1316
CMESSAGE='STWORK : I/O error - PP LOOKUP table ' STWORK1A.1317
ICODE=3 STWORK1A.1318
RETURN STWORK1A.1319
ENDIF STWORK1A.1320
IF (FT_STEPS(UNITPP).NE.0) THEN GMG1F404.348
LEN_PPNAME=LEN(PPNAME) STWORK1A.1322
CALL FILE_CLOSE(UNITPP,PPNAME,LEN_PPNAME,1,0,ICODE) GTD0F400.37
ELSE GDR8F405.36
CALL FLUSH_BUFFER(UNITPP,ICODE) GDR8F405.37
IF(ICODE.NE.0) THEN GDR8F405.38
CMESSAGE='STWORK: Problem flushing buffer' GDR8F405.39
ICODE=10 GDR8F405.40
RETURN GDR8F405.41
ENDIF GDR8F405.42
GDR8F405.43
ENDIF STWORK1A.1324
C STWORK1A.1325
ELSEIF (output_code.EQ.st_dump.OR.output_code.EQ.st_secondary) STWORK1A.1326
* THEN STWORK1A.1327
CL STWORK1A.1328
CL 4.4 OUTPUT to dump or secondary D1 space - this implies some STWORK1A.1329
CL TEMPORAL processing possibly. If destination is secondary D1 STWORK1A.1330
CL space, there will be no associated LOOKUP header to update. STWORK1A.1331
CL STWORK1A.1332
C Length is calculated from STASHlist STWORK1A.1333
C NB: Full field length must be coded here, even for partial timeseries STWORK1A.1334
C STWORK1A.1335
*IF -DEF,MPP GPB1F402.167
NUM_WORDS=STLIST(st_output_length,IL)/NUM_LEVS_OUT STWORK1A.1336
*ELSE GPB1F402.168
NUM_WORDS=STLIST(st_dump_output_length,IL)/NUM_LEVS_OUT GPB1F402.169
*ENDIF GPB1F402.170
ICURRLL=STLIST(st_lookup_ptr,IL) ! Location of DUMP header STWORK1A.1337
C STWORK1A.1338
DO II=1,NUM_LEVS_OUT ! --- Start of levels loop --- STWORK1A.1339
! Reset index for PP_HEAD if there is a levels list of hybrid levels GAB1F400.181
IF (stlist(st_output_bottom,il).lt.0.and.lbvcl.eq.9) THEN GAB1F400.182
JJ = level_list(II) GAB1F400.183
! or a range of model levels, as they may not be consecutive, GAB1F400.184
ELSE IF (stlist(st_output_bottom,il).ge.1.and. GAB1F400.185
& stlist(st_output_top,il).le.T_levels) THEN GAB1F400.186
JJ = level_list(II) GAB1F400.187
! otherwise use of level index is alright GAB1F400.188
ELSE GAB1F400.189
JJ = II GAB1F400.190
END IF GAB1F400.191
addr=stlist(st_output_addr,il) ! start address STWORK1A.1340
IF (what_proc.eq.st_time_series_code.or. GRS1F404.232
& what_proc.eq.st_time_series_mean) THEN GRS1F404.233
GRS1F404.234
CL STWORK1A.1343
CL 4.4.1 Timeseries addresses are incremented according to timestep STWORK1A.1344
CL STWORK1A.1345
IF (stlist(st_freq_code,il).lt.1) THEN STWORK1A.1346
icode=st_not_supported STWORK1A.1347
cmessage= STWORK1A.1348
+ 'STWORK : STASHtime for timeseries not supported' STWORK1A.1349
goto 999 ! got an error so jump to return STWORK1A.1350
ENDIF STWORK1A.1351
elap_time=step-stlist(st_start_time_code,il) STWORK1A.1352
elap_time=(mod(elap_time,stlist(st_period_code,il)))/ STWORK1A.1353
+ stlist(st_freq_code,il) STWORK1A.1354
addr=addr+(elap_time*pphoriz_out) TJ140193.55
CL on the first time step of a timeseries processing TJ140193.56
CL pphoriz_out is the length of the entire output vector TJ140193.57
CL including extra data -- on other timesteps it is TJ140193.58
CL the length of a single record (data for just one timestep) TJ140193.59
ENDIF STWORK1A.1356
CL STWORK1A.1357
CL 4.4.2 TEMPORAL processing from ppfield array to D1 STWORK1A.1358
CL STWORK1A.1359
CALL TEMPORAL(ppfield(1+(ii-1)*pphoriz_out), STWORK1A.1360
+ d1(addr+(ii-1)*pphoriz_out),pphoriz_out,extraw, STWORK1A.1361
+ stlist(1,il),len_stlist,OCEAN,step, STWORK1A.1362
+ icode,cmessage,start_step,rmdi) STWORK1A.1363
STWORK1A.1364
IF (icode.gt.0) goto 999 STWORK1A.1365
CL STWORK1A.1366
CL 4.4.3 Set up LOOKUP header if destination is main part of D1 STWORK1A.1367
CL STWORK1A.1368
IF (output_code.EQ.st_dump) THEN STWORK1A.1369
CL STWORK1A.1370
CL 4.4.3 Set other information for input to PPHEAD STWORK1A.1371
CL STWORK1A.1372
GR=STLIST(st_gridpoint_code,ILPREV)! Grid point code STWORK1A.1373
C Any time-processed field has a (non-zero) sample_prd set - STWORK1A.1374
C this will be translated by PP_HEAD into an LBTIM subcode IB of 2 STWORK1A.1375
sample_prd=0.0 STWORK1A.1376
IF (STLIST(st_proc_no_code,ILPREV).GT.st_replace_code) STWORK1A.1377
* THEN STWORK1A.1378
sample_prd=REAL(STLIST(st_freq_code,ILPREV)* STWORK1A.1379
& secs_per_period)/REAL(steps_per_period*3600) STWORK1A.1380
ENDIF STWORK1A.1381
C Address of whole field is calculated from STASHlist STWORK1A.1382
*IF -DEF,MPP GPB1F402.171
IWA=STLIST(st_output_addr,IL)+(II-1)*NUM_WORDS STWORK1A.1383
*ELSE GPB1F402.172
IWA=STLIST(st_dump_output_addr,IL)+(II-1)*NUM_WORDS GPB1F402.173
*ENDIF GPB1F402.174
CL STWORK1A.1384
CL 4.4.4 Call PPHEAD to set LOOKUP header for field STASHed to D1. STWORK1A.1385
CL Here pass previous_time as well as start_step from temporal STWORK1A.1386
CL if start_step is true then start time will be updated. STWORK1A.1387
CL Value of end time is unimportant as that is handled properly STWORK1A.1388
CL when data is written out to pp file. STWORK1A.1389
CL Note that LBNREC is hardwired to 0 and so too is BACC. STWORK1A.1390
CL STWORK1A.1391
CALL PP_HEAD( GKR0F305.569
*CALL ARGPPX GKR0F305.570
* im_ident,FIXHD,INTHD,REALHD, GKR0F305.571
1 LEN_FIXHD,LEN_INTHD,LEN_REALHD, STWORK1A.1394
2 IM,IS,GR,lfullfield, STWORK1A.1395
3 level(II),pseudo_level(II), GKR0F305.572
4 samples,start_step,previous_time,fixhd(28),LEN1_LOOKUP, STWORK1A.1397
5 extraw_hdr,LOOKUP(1,ICURRLL),RLOOKUP(1,ICURRLL), TJ140193.60
*IF -DEF,MPP GPB1F402.175
6 N_COLS_OUT,NUM_WORDS,0, STWORK1A.1399
7 N_ROWS_OUT,NROW_IN,SROW_IN,WCOL_IN,ECOL_IN, STWORK1A.1400
*ELSE GPB1F402.176
6 global_N_COLS_OUT,NUM_WORDS,0, GPB1F402.177
7 global_N_ROWS_OUT,NROW_IN,SROW_IN,WCOL_IN,ECOL_IN, GPB1F402.178
*ENDIF GPB1F402.179
7 lbproc_comp,sample_prd, STWORK1A.1401
8 FCST_PRD,0,PACKING_TYPE, GAB1F400.192
& st_grid,IWA,stsuparr(sa_idx(1)),stsuparr(sa_idx(2)), GAB1F400.193
& stsuparr(sa_idx(3)),stsuparr(sa_idx(4)),T_levels,JJ, GAB1F400.194
A ROTATE,ELF,OCEAN,LEVDEPC,LEN1_LEVDEPC, STWORK1A.1404
B ICODE,CMESSAGE) STWORK1A.1405
C STWORK1A.1406
IF(ICODE.gt.0) goto 999 ! An error has occured GAB1F400.195
GAB1F400.196
C Only (optionally) pack fields if no extra words of data STWORK1A.1411
IF (extraw_hdr .eq. 0) THEN TJ140193.61
LOOKUP(LBPACK,ICURRLL) = GKR0F305.573
& EXPPXI( im_ident, IS, IM, ppx_dump_packing, GKR0F305.574
*CALL ARGPPX GKR0F305.575
& icode, cmessage) GKR0F305.576
IF (DUMP_PACK.eq.3 ) THEN GDR2F401.60
! Override packing indicator from PPXREF GDR2F401.61
N1 = 0 ! No packing GDR2F401.62
LOOKUP(LBPACK,ICURRLL) = GDR2F401.63
& (LOOKUP(LBPACK,ICURRLL)/10)*10 + N1 GDR2F401.64
ENDIF GDR2F401.65
ELSE STWORK1A.1414
LOOKUP(LBPACK,ICURRLL)=0 STWORK1A.1415
ENDIF STWORK1A.1416
C Set data type (REAL/INTEGER) from PP_XREF (-ve for timeseries) STWORK1A.1417
IF (STLIST(st_series_ptr,ilprev).GT.0.OR. GRS1F404.235
& STLIST(st_proc_no_code,ilprev).eq.st_time_series_mean) THEN GRS1F404.236
LOOKUP(DATA_TYPE,ICURRLL) = GKR0F305.577
& -EXPPXI( im_ident, IS, IM, ppx_data_type, GKR0F305.578
*CALL ARGPPX GKR0F305.579
& icode, cmessage) GKR0F305.580
ELSE STWORK1A.1420
LOOKUP(DATA_TYPE,ICURRLL) = GKR0F305.581
& EXPPXI( im_ident, IS, IM, ppx_data_type, GKR0F305.582
*CALL ARGPPX GKR0F305.583
& icode, cmessage) GKR0F305.584
ENDIF STWORK1A.1422
ICURRLL=ICURRLL+1 ! Update the counter for the next field STWORK1A.1423
C STWORK1A.1424
ENDIF ! End of IF output_code=dump STWORK1A.1425
C STWORK1A.1426
ENDDO ! --- End of levels loop --- STWORK1A.1427
C STWORK1A.1428
ELSE STWORK1A.1429
ICODE=9 STWORK1A.1430
CMESSAGE='STWORK : Illegal output destination in STLIST' STWORK1A.1431
GOTO 999 STWORK1A.1432
ENDIF ! End of STLIST output destination IF block STWORK1A.1433
C STWORK1A.1434
ENDIF ! END OF S_F IF Block --------------------------------- STWORK1A.1435
CL STWORK1A.1436
CL 5. End of loop over STASHlist entries - RETURN to calling routine STWORK1A.1437
CL STWORK1A.1438
200 CONTINUE STWORK1A.1439
C STWORK1A.1440
999 CONTINUE STWORK1A.1441
RETURN STWORK1A.1442
CL STWORK1A.1443
CL 9. IO error exits STWORK1A.1444
CL STWORK1A.1445
990 WRITE(CMESSAGE,'("STWORK : Error opening output PP file on unit " STWORK1A.1446
& ,I2)') UNITPP STWORK1A.1447
RETURN STWORK1A.1448
END STWORK1A.1449
*ENDIF STWORK1A.1450