*IF DEF,CONTROL MEANDIA2.2
C ******************************COPYRIGHT****************************** GTS2F400.5869
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.5870
C GTS2F400.5871
C Use, duplication or disclosure of this code is subject to the GTS2F400.5872
C restrictions as set forth in the contract. GTS2F400.5873
C GTS2F400.5874
C Meteorological Office GTS2F400.5875
C London Road GTS2F400.5876
C BRACKNELL GTS2F400.5877
C Berkshire UK GTS2F400.5878
C RG12 2SZ GTS2F400.5879
C GTS2F400.5880
C If no contract has been raised with this copy of the code, the use, GTS2F400.5881
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.5882
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.5883
C Modelling at the above address. GTS2F400.5884
C ******************************COPYRIGHT****************************** GTS2F400.5885
C GTS2F400.5886
CLL Routine: MEANDIAG ------------------------------------------------- MEANDIA2.3
CLL MEANDIA2.4
CLL Purpose: Outputs mean diagnostic PPfiles from within the means MEANDIA2.5
CLL program. Fields are generated by the normal operation of MEANDIA2.6
CLL the climate meaning system (ie. all fields in D1 except MEANDIA2.7
CLL integer and logical data are averaged). Section 0 fields MEANDIA2.8
CLL and fields which can be derived from them by the PCR's MEANDIA2.9
CLL DYN_DIAG and PHY_DIAG (as used in sections 15/16 for MEANDIA2.10
CLL instantaneous diagnostics) are available to STASH as MEANDIA2.11
CLL section 21-24 diagnostics in this routine, but the UI MEANDIA2.12
CLL ensures that only spatial processing is requested and the MEANDIA2.13
CLL output is forced to go to the designated mean PPfile. In MEANDIA2.14
CLL the case of the ocean model, there is no equivalent of MEANDIA2.15
CLL DYN_DIAG and PHY_DIAG so only "section 0" fields can be MEANDIA2.16
CLL processed (but now as sections 41-44). MEANDIA2.17
CLL Fields which were already processed by STASH, stored in D1 MEANDIA2.18
CLL and then meaned further by the meaning system are only MEANDIA2.19
CLL extracted to the mean PPfile if the STASH usage profile of MEANDIA2.20
CLL the original diagnostic processing record so indicates. MEANDIA2.21
CLL This is determined by a loop over all STASH records with a MEANDIA2.22
CLL check on the STASH tag field, with a further loop over the MEANDIA2.23
CLL number of output levels associated with the STASH record. MEANDIA2.24
CLL MEANDIA2.25
CLL Tested under compiler: cft77 MEANDIA2.26
CLL Tested under OS version: UNICOS 6.1.5A MEANDIA2.27
CLL MEANDIA2.28
CLL Author: T.C.Johns MEANDIA2.29
CLL MEANDIA2.30
CLL Model Modification history from model version 3.0: MEANDIA2.31
CLL version Date MEANDIA2.32
CLL 3.1 3/02/93 : added comdeck CHSUNITS to define NUNITS for i/o RS030293.121
CLL 3.4 16/6/94 : Change CHARACTER*(*) to CHARACTER*(80) N.Farnon ANF0F304.28
CLL 3.3 08/02/94 Modify calls to TIME2SEC/SEC2TIME to output/input TJ080294.219
CLL elapsed times in days & secs, for portability. TCJ TJ080294.220
CLL 3.3 26/10/93 M. Carter. Part of an extensive mod that: MC261093.225
CLL 1.Removes the limit on primary STASH item numbers. MC261093.226
CLL 2.Removes the assumption that (section,item) MC261093.227
CLL defines the sub-model. MC261093.228
CLL 3.Thus allows for user-prognostics. MC261093.229
CLL 3.4 04/08/94 No packing indicator change from -26 to -99 PJS APS1F304.1
CLL 3.4 17/06/94 Argument LCAL360 added and passed to SEC2TIME, GSS1F304.472
CLL TIME2SEC GSS1F304.473
CLL S.J.Swarbrick GSS1F304.474
CLL 3.4 10/10/94 : Add option to encode output in GRIB (R A Stratton) GRS3F304.210
CLL 3.5 24/03/95 Changed OPEN to FILE_OPEN and GPB1F305.82
CLL CLOSE to FILE_CLOSE P.Burton GPB1F305.83
CLL 3.5 May 95 Submodels project. GSS1F305.546
CLL Internal model identifiers now read from STASH list GSS1F305.547
CLL array; reference to INDEX_PPXREF removed. GSS1F305.548
CLL References to PP_XREF array replaced by EXPPXI GSS1F305.549
CLL function calls. GSS1F305.550
CLL *CALLs introduced in conjunction with the above - GSS1F305.551
CLL ARGPPX, PPXLOOK. GSS1F305.552
CLL S.J.Swarbrick GSS1F305.553
! 4.0 10/03/95 : Allow alternative packing method for grib (R A GRS3F400.290
! Stratton). GRS3F400.291
CLL 4.0 06/09/95 Correct setting up of im_index. D. Robinson GDR5F400.1
CLL 4.3 31-01-97 Parallelise writes to the pipe. LCWiles GLW2F403.25
!LL 4.3 30/04/97 Added code to use UM_SECTOR_SIZE to make transfers GBC0F403.89
!LL well-formed. GBC0F403.90
!LL B. Carruthers Cray Research. GBC0F403.91
CLL 4.3 30/05/96 Correction to dumps being wrongly deleted L Wiles GLW6F403.1
!LL 4.4 06/05/97 Correct header timestamps for real-period means GMG1F404.287
!LL Author: M. Gallani GMG1F404.288
CLL 4.4 15/10/97 Enable slab mean diagnostics be processed for SDR1F404.179
CLL a MEAN PP file. D. Robinson. SDR1F404.180
CLL MEANDIA2.33
!LL 4.4 04/09/97 Use GENERAL_GATHER_FIELD to get fields to be written GSM2F404.6
!LL out by PP_FILE and GRIB_FILE. S.D.Mullerworth GSM2F404.7
!LL 4.5 21/04/97 Pass ARGFLDPT to ST_MEAN. S.D.Mullerworth GSM1F405.484
!LL 4.5 13/01/98 Add MAX_SIZE argument, and use to dimension dynamic GPB2F405.123
!LL array for I/O buffer, and remove SHMEM common GPB2F405.124
!LL block. P.Burton GPB2F405.125
!LL 4.5 28/05/98 Code for parallel processing in COEX Packing GBCQF405.25
!LL Author: Paul Burton & Bob Carruthers GBCQF405.26
!LL 4.5 29/07/98 Rename CINTF to CINTFA. D. Robinson. GDR2F405.118
!LL 4.5 10/10/98 Add ARGINFO to argument list. Pass ARGINFO/ARGPPX GMB1F405.407
!LL to PPCTL. D. Robinson. GMB1F405.408
CLL Programming standard: UM Doc Paper 3, version 2 (7/9/90) MEANDIA2.34
CLL MEANDIA2.35
CLL Logical components covered: C5 MEANDIA2.36
CLL MEANDIA2.37
CLL Project task: C5 MEANDIA2.38
CLL MEANDIA2.39
CLL External documentation: MEANDIA2.40
CLL UM Doc Paper C0 - The top-level control system MEANDIA2.41
CLL UM Doc Paper C5 - Calculation of means MEANDIA2.42
CLL MEANDIA2.43
CLL ------------------------------------------------------------------- MEANDIA2.44
C*L Interface and arguments: ------------------------------------------ MEANDIA2.45
C MEANDIA2.46
SUBROUTINE MEANDIAG ( 2,29@DYALLOC.2378
*CALL ARGSIZE 
@DYALLOC.2379
*CALL ARGD1 @DYALLOC.2380
*CALL ARGDUMA @DYALLOC.2381
*CALL ARGDUMO @DYALLOC.2382
*CALL ARGDUMW GKR1F401.231
*CALL ARGSTS @DYALLOC.2383
*CALL ARGPTRA @DYALLOC.2384
*CALL ARGPTRO @DYALLOC.2385
*CALL ARGCONA @DYALLOC.2386
*CALL ARGINFA @DYALLOC.2387
*CALL ARGINFO GMB1F405.409
*CALL ARGPPX GSS1F305.554
*IF DEF,ATMOS GSM1F405.485
*CALL ARGFLDPT GSM1F405.486
*ENDIF GSM1F405.487
* I_AO,MEANLEV,PP_LEN_MEAN,STEP_DUMPS,MEAN_PERIOD, @DYALLOC.2388
*IF DEF,MPP GPB2F405.126
& MAX_SIZE, GPB2F405.127
*ENDIF GPB2F405.128
* ICODE,CMESSAGE) GDR3F305.272
C MEANDIA2.50
IMPLICIT NONE MEANDIA2.51
C MEANDIA2.52
*CALL CMAXSIZE @DYALLOC.2390
*CALL CSUBMODL GSS1F305.555
*CALL CINTFA GDR2F405.119
*CALL TYPSIZE @DYALLOC.2391
*CALL TYPD1 @DYALLOC.2392
*CALL TYPDUMA @DYALLOC.2393
*CALL TYPDUMO @DYALLOC.2394
*CALL TYPDUMW GKR1F401.232
*CALL TYPSTS ! Contains *CALL CPPXREF GSS1F305.556
*CALL TYPPTRA @DYALLOC.2396
*CALL TYPPTRO @DYALLOC.2397
*CALL TYPCONA @DYALLOC.2398
*CALL TYPINFA @DYALLOC.2399
*IF DEF,ATMOS GSM1F405.488
*CALL TYPFLDPT GSM1F405.489
*ENDIF GSM1F405.490
*CALL TYPINFO GMB1F405.410
*IF DEF,MPP GSM1F403.269
*CALL PARVARS GSM1F403.270
*CALL DECOMPTP GSM1F403.271
*ENDIF GSM1F403.274
@DYALLOC.2400
INTEGER MEANDIA2.53
* I_AO, ! IN Atmosphere/Ocean indicator MEANDIA2.54
* MEANLEV, ! IN Mean level indicator MEANDIA2.55
* PP_LEN_MEAN, ! IN Number of fields in output PPfile MEANDIA2.60
* STEP_DUMPS, ! IN Timestep in multiples of restart MEANDIA2.61
C ! dump frequency. MEANDIA2.62
* MEAN_PERIOD, ! IN meaning frequency. MEANDIA2.63
*IF DEF,MPP GPB2F405.129
& MAX_SIZE, ! IN maximum dump field size GPB2F405.130
*ENDIF GPB2F405.131
* ICODE ! OUT return code; successful=0, error> 0 MEANDIA2.64
C MEANDIA2.65
CHARACTER*(80) ANF0F304.29
* CMESSAGE ! OUT Error message if ICODE > 0 MEANDIA2.67
C* MEANDIA2.68
C MEANDIA2.69
C Common blocks and parameters MEANDIA2.70
C MEANDIA2.71
*CALL CLOOKADD MEANDIA2.75
*CALL STPARAM MEANDIA2.76
*CALL CHSUNITS RS030293.122
*CALL CHISTORY GDR3F305.273
*CALL CCONTROL GDR3F305.274
*CALL CTIME MEANDIA2.80
*CALL C_MDI MEANDIA2.81
GSS1F305.557
! PPXREF lookup arrays GSS1F305.558
*CALL PPXLOOK GSS1F305.559
GSS1F305.560
C External subroutines called: MEANDIA2.83
INTEGER EXPPXI GSS1F305.561
EXTERNAL PPCTL,PP_FILE,SETPOS,IOERROR,SEC2TIME,TIME2SEC,STP2TIME, TJ080294.221
* BUFFIN,BUFFOUT,GRIB_FILE,EXPPXI GSS1F305.562
*IF DEF,ATMOS MEANDIA2.87
EXTERNAL ST_MEAN MEANDIA2.88
*ENDIF MEANDIA2.89
*IF DEF,OCEAN MEANDIA2.90
EXTERNAL STASH MEANDIA2.91
*ENDIF MEANDIA2.92
C MEANDIA2.93
C Dynamic allocated workspace @DYALLOC.2401
C MEANDIA2.95
INTEGER PP_FIXHD(LEN_FIXHD) ! PPfile fixed length header @DYALLOC.2402
INTEGER PPLOOK(LEN1_LOOKUP,PP_LEN_MEAN) !PPfile lookup headers @DYALLOC.2403
*IF DEF,MPP GPB2F405.132
REAL buf(MAX_SIZE) ! I/O buffer space GPB2F405.133
CDIR$ CACHE_ALIGN buf GPB2F405.134
*ENDIF GPB2F405.135
C MEANDIA2.98
cdir$ cache_align pplook, pp_fixhd GBC0F403.92
*CALL CNTL_IO GBC0F403.93
C GBC0F403.94
INTEGER IPPLOOK(LEN1_LOOKUP) ! Copy of D1 field header MEANDIA2.99
C Local variables and arrays MEANDIA2.103
C MEANDIA2.104
CHARACTER*14 MEANDIA2.105
* PPNAME ! Name of PPfile MEANDIA2.106
REAL MEANDIA2.107
* A_IO ! IO error return code on BUFFER IO MEANDIA2.108
INTEGER MEANDIA2.109
* WORD_ADDRESS, ! IO word address on BUFFER IO MEANDIA2.110
* LEN_IO, ! IO transfer length on BUFFER IO MEANDIA2.111
* NFTPIPE, ! FORTRAN unit number for named pipe MEANDIA2.112
* PPUNIT, ! FORTRAN unit number for PPfile MEANDIA2.113
* INDEXM, ! Mean level index MEANDIA2.114
* FIELD, ! Index over field number in LOOKUP MEANDIA2.115
* FIELD_ADDRESS, ! Address of field in D1 MEANDIA2.116
* FIELD_LENGTH, ! Length of single field MEANDIA2.117
* BUFFER_LENGTH, ! Length of buffer for field MEANDIA2.118
* IS,IM, ! STASH section,item codes for field MEANDIA2.119
* IE, ! STLIST index over entries MEANDIA2.120
* modl, ! Int. model no. read from STASH record GSS1F305.563
* TAG, ! STLIST tag used to identify field MEANDIA2.123
* N_ROWS, ! No of rows in field MEANDIA2.124
* N_COLS, ! No of columns in field MEANDIA2.125
* NO,N_LEVS, ! Bottom level and number of levels MEANDIA2.126
* LEVEL, ! Index over levels MEANDIA2.127
* COMP_ACCRCY, ! Packing accracy MEANDIA2.128
* LBTIM_IA, ! Sampling period in hours for LBTIM MEANDIA2.129
* IWA, ! Word address used in SETPOS MEANDIA2.130
* ICURRLL, ! Current position in PP LOOKUP table MEANDIA2.131
* ICURRL1, ! Current position in PP LOOKUP table GRS3F304.212
* LEN_BUF_WORDS, ! NUM_WORDS rounded to 512 MEANDIA2.132
* NUM_WORDS, ! Number of words reqd to hold the data MEANDIA2.133
* I, ! Loop index MEANDIA2.134
* START_DAY, ! Start time for mean period (days) TJ080294.223
* START_SECOND, ! Start time for mean period (seconds) MEANDIA2.135
* PERIOD_DAYS, ! Start time for mean period (days) TJ080294.224
* PERIOD_SECS, ! Start time for mean period (seconds) TJ080294.225
* START_TIME(7) ! Start time for mean period(date/time) MEANDIA2.136
& ,im_ident ! Internal Model Identifier GDR4F305.122
& ,im_index ! Internal Model Index for stash GDR4F305.123
& ,LEN_PPNAME GO261093.74
& ,PACKING_TYPE ! 0=unpacked, 1=WGDOS, 3=GRIB GO261093.75
& ,GRIB_PACKING ! packing profile used for grib packing GRS3F400.292
& ,D1POS ! Position of info in D1_ADDR array GSM2F404.8
& ,orig_decomp ! Used to check for change in GSM2F404.9
& ,new_decomp ! decomposition GSM2F404.10
LOGICAL MEANDIA2.138
* PACKING, ! Switch to enable optional packing MEANDIA2.139
& LPACKFIELD ! Per-field packing indicator GO261093.76
& ,GRIB_OUT ! .True. if output to be in grib GRS3F304.213
@DYALLOC.2404
*IF DEF,MPP GSM1F403.275
INTEGER GSM1F403.276
& GR ! Gridtype code GSM1F403.277
&, GLOBAL_PPHORIZ_OUT ! Size of global field GSM1F403.278
&, info ! Unused arg in GCOM calls GSM1F403.279
&, LOCAL_LEN ! Length of field: GSM2F404.11
& ! from GENERAL_GATHER_FIELD GSM2F404.12
&, SUBM ! Submodel number for internal model id GSM1F403.282
GSM1F403.283
REAL A ! To hold return code GSM2F404.13
& ! from GENERAL_GATHER_FIELD GSM2F404.14
*ENDIF GSM1F403.285
GSM1F403.286
INTEGER IPPVAL @DYALLOC.2405
REAL RPPVAL @DYALLOC.2406
EQUIVALENCE (IPPVAL,RPPVAL) @DYALLOC.2407
C @DYALLOC.2408
im_ident = I_AO GDR4F305.124
im_index = internal_model_index(im_ident) GDR5F400.2
GDR4F305.126
CL---------------------------------------------------------------------- MEANDIA2.143
CL 1. Initialise output ppfile for mean data at level MEANLEV. MEANDIA2.144
CL OPEN the file ready to receive mean PPfields from STASH. MEANDIA2.145
CL MEANDIA2.146
CALL PPCTL ( @DYALLOC.2409
*CALL ARGSIZE @DYALLOC.2410
*CALL ARGD1 @DYALLOC.2411
*CALL ARGDUMA @DYALLOC.2412
*CALL ARGDUMO @DYALLOC.2413
*CALL ARGDUMW GKR1F401.233
*CALL ARGINFA @DYALLOC.2414
*CALL ARGINFO GMB1F405.411
*CALL ARGPPX GMB1F405.412
* I_AO,MEANLEV,.FALSE.,PPNAME,ICODE,CMESSAGE) @DYALLOC.2415
IF (ICODE.GT.0) GOTO 999 MEANDIA2.148
IF (I_AO.EQ.1 .or. I_AO.EQ.2) THEN GDR3F305.275
PPUNIT = FT_MEANim(I_AO) GDR3F305.276
ELSE GDR3F305.277
ICODE = 311 GDR3F305.278
CMESSAGE='MEANDIAG : I_AO has invalid value' GDR3F305.279
GOTO 999 GDR3F305.280
ENDIF GDR3F305.281
LEN_PPNAME=LEN(PPNAME) MEANDIA2.155
CALL FILE_OPEN(PPUNIT,PPNAME,LEN_PPNAME,1,1,ICODE) GPB1F305.84
IF(ICODE.NE.0)GOTO999 MEANDIA2.157
CL---------------------------------------------------------------------- MEANDIA2.158
CL 2. Extract mean fields from mean dump fields in D1, and append to MEANDIA2.159
CL mean PPfile. The fields dealt with in this section are the MEANDIA2.160
CL prognostic fields as meaned by the climate meaning system, plus MEANDIA2.161
CL fields derived from them (in the case of the atmosphere). MEANDIA2.162
CL The STASH section number depends on the mean level and whether MEANDIA2.163
CL atmosphere or ocean. Different sets of fields can be requested MEANDIA2.164
CL from different mean periods. MEANDIA2.165
CL MEANDIA2.166
*IF DEF,ATMOS MEANDIA2.167
IF (I_AO.EQ.1) THEN MEANDIA2.168
CALL ST_MEAN ( @DYALLOC.2416
*CALL ARGSIZE @DYALLOC.2417
*CALL ARGD1 @DYALLOC.2418
*CALL ARGDUMA @DYALLOC.2419
*CALL ARGDUMO @DYALLOC.2420
*CALL ARGDUMW GKR1F401.234
*CALL ARGSTS @DYALLOC.2421
*CALL ARGPTRA @DYALLOC.2422
*CALL ARGPTRO @DYALLOC.2423
*CALL ARGCONA @DYALLOC.2424
*CALL ARGPPX GKR0F305.950
*CALL ARGFLDPT GSM1F405.491
* 20+MEANLEV,STASH_MAXLEN(20+MEANLEV,im_index), GDR4F305.127
& NUM_STASH_LEVELS, P_FIELD, ! for dynamic array NF171193.55
* ICODE,CMESSAGE) @DYALLOC.2426
ENDIF MEANDIA2.171
*ENDIF MEANDIA2.172
*IF DEF,OCEAN MEANDIA2.173
IF (I_AO.EQ.2) THEN MEANDIA2.174
CALL STASH(o_sm,o_im,40+MEANLEV,D1, GKR0F305.951
*CALL ARGSIZE @DYALLOC.2428
*CALL ARGD1 @DYALLOC.2429
*CALL ARGDUMA @DYALLOC.2430
*CALL ARGDUMO @DYALLOC.2431
*CALL ARGDUMW GKR1F401.235
*CALL ARGSTS @DYALLOC.2432
*CALL ARGPPX GKR0F305.952
* ICODE,CMESSAGE) @DYALLOC.2436
ENDIF MEANDIA2.176
*ENDIF MEANDIA2.177
IF (ICODE.GT.0) GOTO 999 MEANDIA2.178
CL---------------------------------------------------------------------- MEANDIA2.179
CL 3. Loop over STASHlist entries and extract tagged fields which are MEANDIA2.180
CL already processed into D1 by STASH to the mean PP file MEANDIA2.181
CL MEANDIA2.182
CL 3.1 Buffer in PPfile fixed length header to get address of lookup MEANDIA2.183
CL MEANDIA2.184
CALL SETPOS(PPUNIT,0,ICODE) GTD0F400.102
CALL BUFFIN(PPUNIT,PP_FIXHD(1),LEN_FIXHD,LEN_IO,A_IO) MEANDIA2.186
IF(A_IO.NE.-1.0.OR.LEN_IO.NE.LEN_FIXHD) THEN MEANDIA2.187
CALL IOERROR('Buffer in fixed length header',A_IO,LEN_IO, MEANDIA2.188
* LEN_FIXHD) MEANDIA2.189
CMESSAGE='MEANDIAG: Error reading PPfile header' MEANDIA2.190
ICODE=1 MEANDIA2.191
GOTO 999 MEANDIA2.192
ENDIF MEANDIA2.193
WORD_ADDRESS=PP_FIXHD(150)-1 MEANDIA2.194
CL MEANDIA2.195
CL 3.2 Buffer in PPfile lookup header to PPLOOK work array MEANDIA2.196
CL MEANDIA2.197
CALL SETPOS(PPUNIT,WORD_ADDRESS,ICODE) GTD0F400.103
CALL BUFFIN(PPUNIT,PPLOOK(1,1),LEN1_LOOKUP*PP_LEN_MEAN,LEN_IO,A_IO MEANDIA2.199
* ) MEANDIA2.200
IF(A_IO.NE.-1.0.OR.LEN_IO.NE.LEN1_LOOKUP*PP_LEN_MEAN) THEN MEANDIA2.201
CALL IOERROR('Buffer in of LOOKUP table ',A_IO,LEN_IO, MEANDIA2.202
* LEN1_LOOKUP*PP_LEN_MEAN) MEANDIA2.203
CMESSAGE='MEANDIAG: Error reading PPfile LOOKUP table' MEANDIA2.204
ICODE=1 MEANDIA2.205
GOTO 999 MEANDIA2.206
ENDIF MEANDIA2.207
CL MEANDIA2.208
CL 3.3 Initialise output address and LOOKUP entry number in the PPfile MC261093.231
CL MEANDIA2.213
C MEANDIA2.236
ICURRLL=FT_LASTFIELD(PPUNIT) MEANDIA2.237
ICURRL1=FT_LASTFIELD(PPUNIT) ! required if grib output GRS3F304.214
IF (ICURRLL.EQ.0) THEN ! this is the first field MEANDIA2.238
IWA=PP_FIXHD(150)-1+LEN1_LOOKUP*PP_LEN_MEAN MEANDIA2.239
! round address up to um_sector_size-words GBC0F403.95
IWA=((IWA+um_sector_size-1)/um_sector_size)*um_sector_size GBC0F403.96
ELSE ! append to the previous field MEANDIA2.241
IWA=PPLOOK(LBEGIN,ICURRLL)+PPLOOK(LBNREC,ICURRLL) MEANDIA2.242
ENDIF GRS3F304.215
GRS3F304.216
! Use PP_PACK_CODE to set packing type and GRIB flag GRS3F304.217
! For GRB output reset PP_PACK_CODE to give packing profile. GRS3F304.218
IF (PP_PACK_CODE(PPUNIT).GE.100) THEN GRS3F304.219
GRIB_OUT=.TRUE. GRS3F304.220
PP_PACK_CODE(PPUNIT)=PP_PACK_CODE(PPUNIT)-100 GRS3F304.221
GRIB_PACKING=PP_PACK_CODE(PPUNIT) GRS3F400.293
PACKING_TYPE=3 GRS3F304.222
ELSE GRS3F304.223
GRIB_OUT=.FALSE. GRS3F304.224
ENDIF MEANDIA2.243
C MEANDIA2.244
C Set packing switch : profile 0 means no packing MEANDIA2.245
C MEANDIA2.246
IF (PP_PACK_CODE(PPUNIT).EQ.0) THEN MEANDIA2.247
PACKING=.FALSE. MEANDIA2.248
ELSE MEANDIA2.249
PACKING=.TRUE. MEANDIA2.250
ENDIF MEANDIA2.251
CL MEANDIA2.252
CL 3.4 Start loop over STASHlist entries. MEANDIA2.253
CL MEANDIA2.254
! Note in the case of grib output this loop is used to set up pp headers GRS3F304.225
! only GRS3F304.226
! GRS3F304.227
DO IE =1,TOTITEMS GSS1F305.564
modl=STLIST(st_model_code ,IE) GSS1F305.565
IS =STLIST(st_sect_no_code,IE) GSS1F305.566
IM =STLIST(st_item_code ,IE) GSS1F305.567
TAG =STLIST(st_macrotag ,IE)/1000 GSS1F305.568
IF ( (MOD(TAG/(2**(MEANLEV-1)),2) .EQ.1) .AND. GSS1F305.569
*IF DEF,SLAB SDR1F404.181
& ((modl.eq.atmos_im .or. modl.eq.slab_im) .and. SDR1F404.182
& (I_AO.EQ.atmos_sm)) ) THEN SDR1F404.183
*ELSE SDR1F404.184
& (I_AO.EQ.modl) ) THEN SDR1F404.185
*ENDIF SDR1F404.186
SDR1F404.187
GSS1F305.571
C The Tag matches this mean period and the item is in this dump . MC261093.235
C MEANDIA2.263
C Determine the number of output levels and starting LOOKUP header MEANDIA2.264
C (Number of levels now includes possible pseudo_levels) MEANDIA2.265
C NB: Note that vertical means (single output level) are a special case MEANDIA2.266
C as are timeseries (also single output level) MEANDIA2.267
C MEANDIA2.268
IF (STLIST(st_input_bottom,IE).EQ.st_special_code) THEN MEANDIA2.269
N_LEVS=1 ! Output is a special level MEANDIA2.270
ELSEIF (STLIST(st_gridpoint_code,IE).LT.vert_mean_top .AND. MEANDIA2.271
& STLIST(st_gridpoint_code,IE).GT.vert_mean_base) THEN MEANDIA2.272
N_LEVS=1 ! Output is a vertical mean MEANDIA2.273
ELSEIF (STLIST(st_series_ptr,IE).GT.0) THEN MEANDIA2.274
N_LEVS=1 ! Output is a timeseries MEANDIA2.275
ELSE MEANDIA2.276
NO=STLIST(st_output_bottom,IE) MEANDIA2.277
IF (NO.LT.0) THEN ! Output is level list MEANDIA2.278
N_LEVS=STASH_LEVELS(1,-NO) MEANDIA2.279
ELSE ! Output is level range MEANDIA2.280
N_LEVS=STLIST(st_output_top,IE)- MEANDIA2.281
& STLIST(st_output_bottom,IE)+1 MEANDIA2.282
ENDIF MEANDIA2.283
ENDIF MEANDIA2.284
IF (STLIST(st_pseudo_out,IE).GT.0) THEN MEANDIA2.285
NO=STLIST(st_pseudo_out,IE) MEANDIA2.286
N_LEVS=N_LEVS*STASH_PSEUDO_LEVELS(1,NO) MEANDIA2.287
ENDIF MEANDIA2.288
FIELD=STLIST(st_lookup_ptr,IE) MEANDIA2.289
*IF DEF,MPP GSM1F403.287
C Address of distributed field in D1 GSM1F403.288
FIELD_ADDRESS=stlist(st_output_addr,IE) GSM1F403.289
*ENDIF GSM1F403.290
C MEANDIA2.290
C Loop over the number of output levels MEANDIA2.291
DO LEVEL=1,N_LEVS MEANDIA2.292
C Copy LOOKUP header for field from A_LOOKUP or O_LOOKUP to work header MEANDIA2.293
*IF DEF,ATMOS MEANDIA2.294
IF (I_AO.EQ.1) THEN MEANDIA2.295
DO I=1,LEN1_LOOKUP MEANDIA2.296
IPPLOOK(I)=A_LOOKUP(I,FIELD+LEVEL-1) MEANDIA2.297
ENDDO MEANDIA2.298
ENDIF MEANDIA2.299
*ENDIF MEANDIA2.300
*IF DEF,OCEAN MEANDIA2.301
IF (I_AO.EQ.2) THEN MEANDIA2.302
DO I=1,LEN1_LOOKUP MEANDIA2.303
IPPLOOK(I)=O_LOOKUP(I,FIELD+LEVEL-1) MEANDIA2.304
ENDDO MEANDIA2.305
ENDIF MEANDIA2.306
*ENDIF MEANDIA2.307
C Field and buffer sizes, and field address in D1 MEANDIA2.308
FIELD_LENGTH =IPPLOOK(LBLREC) MEANDIA2.309
*IF DEF,MPP GPB2F405.136
IF (FIELD_LENGTH .GT. MAX_SIZE) THEN GPB2F405.137
WRITE(6,*) 'Error in MEANDIAG : MAX_SIZE too small.' GPB2F405.138
WRITE(6,*) 'MAX_SIZE= ',MAX_SIZE GPB2F405.139
WRITE(6,*) 'FIELD_LENGTH= ',FIELD_LENGTH GPB2F405.140
ICODE=1 GPB2F405.141
CMESSAGE='MEANDIAG: MAX_SIZE too small' GPB2F405.142
GOTO 999 GPB2F405.143
ENDIF GPB2F405.144
*ENDIF GPB2F405.145
N_ROWS=IPPLOOK(LBROW) MEANDIA2.310
N_COLS=IPPLOOK(LBNPT) MEANDIA2.311
*IF -DEF,MPP GSM1F403.291
FIELD_ADDRESS=IPPLOOK(NADDR) MEANDIA2.313
*ENDIF GSM1F403.292
BUFFER_LENGTH=((FIELD_LENGTH+um_sector_size-1)/ GBC0F403.97
2 um_sector_size)*um_sector_size GBC0F403.98
C Section/Item codes MEANDIA2.314
IS=IPPLOOK(ITEM_CODE)/1000 MEANDIA2.315
IM=IPPLOOK(ITEM_CODE)-1000*IS MEANDIA2.316
C Packing accuracy of the data :- MEANDIA2.317
C NB: Presence of extra data disables packing for this field MEANDIA2.318
IF (PACKING.AND.(IPPLOOK(LBEXT).LE.0)) THEN MEANDIA2.319
COMP_ACCRCY= GSS1F305.572
& EXPPXI(modl,IS,IM,ppx_packing_acc+PP_PACK_CODE(PPUNIT)-1, GSS1F305.573
*CALL ARGPPX GSS1F305.574
& ICODE,CMESSAGE) GSS1F305.575
LPACKFIELD=.TRUE. MEANDIA2.322
ELSE MEANDIA2.323
COMP_ACCRCY=-99 APS1F304.2
LPACKFIELD=.FALSE. MEANDIA2.325
ENDIF MEANDIA2.326
IF (.NOT.GRIB_OUT) THEN GRS3F304.228
*IF DEF,MPP GSM1F403.293
IF(mype.eq.0)THEN GSM1F403.294
CALL SETPOS_single(PPUNIT,IWA,ICODE) GSM1F403.295
ENDIF GSM1F403.296
SUBM=SUBMODEL_FOR_SM(im_ident) GSM2F404.15
! Reuse decomposition type if it is unchanged. Otherwise GSM2F404.16
! change it to the new type. GSM2F404.17
D1POS=STLIST(st_d1pos,IE) GSM2F404.18
orig_decomp=current_decomp_type GSM2F404.19
new_decomp=orig_decomp GSM2F404.20
GSM2F404.21
IF ((D1_ADDR(d1_imodl,D1POS,SUBM) .EQ. ATMOS_IM) .AND. GSM2F404.22
& (orig_decomp .NE. decomp_standard_atmos)) THEN GSM2F404.23
GSM2F404.24
new_decomp=decomp_standard_atmos GSM2F404.25
GSM2F404.26
ELSEIF ((D1_ADDR(d1_imodl,D1POS,SUBM) .EQ. OCEAN_IM) .AND. GSM2F404.27
& (D1_ADDR(d1_object_type,D1POS,SUBM) .EQ. prognostic) GSM2F404.28
& .AND. (orig_decomp .NE. decomp_standard_ocean)) THEN GSM2F404.29
GSM2F404.30
new_decomp=decomp_standard_ocean GSM2F404.31
GSM2F404.32
ELSEIF ((D1_ADDR(d1_imodl,D1POS,SUBM) .EQ. OCEAN_IM) .AND. GSM2F404.33
& (D1_ADDR(d1_object_type,D1POS,SUBM) .NE. prognostic) GSM2F404.34
& .AND. (orig_decomp .NE. decomp_nowrap_ocean)) THEN GSM2F404.35
GSM2F404.36
new_decomp=decomp_nowrap_ocean GSM2F404.37
GSM2F404.38
ENDIF GSM2F404.39
GSM2F404.40
IF (new_decomp .NE. orig_decomp) THEN GSM2F404.41
icode=0 GSM2F404.42
CALL CHANGE_DECOMPOSITION(new_decomp,icode) GSM2F404.43
GSM2F404.44
IF (icode .NE. 0) THEN GSM2F404.45
IF (mype .EQ. 0) THEN GSM2F404.46
WRITE(6,*) 'ERROR : MEAN_DIAG' GSM2F404.47
WRITE(6,*) 'Failed to change decomposition to ', GSM2F404.48
& new_decomp GSM2F404.49
WRITE(6,*) 'Field M,S,I ', GSM2F404.50
& D1_ADDR(d1_imodl,D1POS,SUBM), GSM2F404.51
& D1_ADDR(d1_section,D1POS,SUBM), GSM2F404.52
& D1_ADDR(d1_item,D1POS,SUBM) GSM2F404.53
ENDIF GSM2F404.54
CMESSAGE='MEANDIA2 : Failed to change decomposition' GSM2F404.55
GOTO 999 GSM2F404.56
ENDIF GSM2F404.57
GSM2F404.58
ENDIF GSM2F404.59
! Gather full field to PE0 GSM2F404.60
CALL GENERAL_GATHER_FIELD(D1(FIELD_ADDRESS),buf,LOCAL_LEN, GSM2F404.61
& FIELD_LENGTH,D1_ADDR(1,STLIST(st_d1pos,IE),SUBM),0, GSM2F404.62
& ICODE,CMESSAGE) GSM2F404.63
IF (ICODE .EQ. 1) THEN GSM2F404.64
WRITE(6,*)'MEANDIA2: Field number ',IS, GSM2F404.65
& 'with dimensions ', N_COLS,' x ', GSM2F404.66
& N_ROWS,' and gridtype ', GSM2F404.67
& D1_ADDR(d1_grid_type,STLIST(st_d1pos,IE),SUBM), GSM2F404.68
& 'was unrecognized and not gathered.' GSM2F404.69
CMESSAGE='MEANDIA2: Unrecognized field on write' GSM2F404.70
GOTO 999 GSM2F404.71
ELSEIF (ICODE .NE. 0) THEN GSM2F404.72
GOTO 999 GSM2F404.73
ENDIF GSM2F404.74
ICODE=0 GBCQF405.27
*IF DEF,MPP,AND,DEF,T3E GBCQF405.28
c--call the parallel version of 'COEX' GBCQF405.29
*ELSE GBCQF405.30
IF (mype .EQ. 0) THEN GSM2F404.75
*ENDIF GBCQF405.31
CALL PP_FILE(BUF,BUFFER_LENGTH,NUM_WORDS,RMDI, GSM2F404.76
& COMP_ACCRCY,FIELD_LENGTH,PPUNIT,IWA,N_COLS,N_ROWS, GSM2F404.77
*IF DEF,MPP,AND,DEF,T3E GBCQF405.32
& PACKING,PACKING_TYPE,0,ICODE,CMESSAGE) GBCQF405.33
*ELSE GBCQF405.34
& PACKING,PACKING_TYPE,ICODE,CMESSAGE) GSM2F404.78
*ENDIF GBCQF405.35
*IF DEF,MPP,AND,DEF,T3E GBCQF405.36
c--end of the call to the parallel version of COEX GBCQF405.37
*ELSE GBCQF405.38
ENDIF GSM2F404.79
*ENDIF GBCQF405.39
CALL GC_ISUM(1, nproc, info, icode) GBCQF405.40
GSM2F404.81
IF(ICODE.GT.0) THEN GSM2F404.82
CMESSAGE= GSM2F404.83
& 'MEANDIA2: Error in PP_FILE - see ICODE for item' GSM2F404.84
ICODE=1000*IS+IM GSM2F404.85
GOTO 999 GSM2F404.86
ENDIF GSM2F404.87
GSM2F404.88
C Increment field address to point to next level if there is one. GSM1F403.316
FIELD_ADDRESS=FIELD_ADDRESS+LOCAL_LEN GSM1F403.317
*ELSE GSM1F403.318
C Output the field from D1 to the PPfile with the requisite packing MEANDIA2.327
CALL PP_FILE(D1(FIELD_ADDRESS),BUFFER_LENGTH,NUM_WORDS, GRS3F304.229
& RMDI,COMP_ACCRCY,FIELD_LENGTH,PPUNIT,IWA,N_COLS,N_ROWS, MEANDIA2.329
& PACKING,PACKING_TYPE,ICODE,CMESSAGE) GO261093.77
IF(ICODE.GT.0) THEN GRS3F304.230
CMESSAGE='MEANDIA1: Error in PP_FILE - see ICODE for item' GRS3F304.231
ICODE=1000*IS+IM GRS3F304.232
GOTO 999 GRS3F304.233
ENDIF GRS3F304.234
*ENDIF GSM1F403.319
ENDIF MEANDIA2.335
C Copy work header for field to next PPfile header MEANDIA2.336
ICURRLL=ICURRLL+1 ! Next field MEANDIA2.337
DO I=1,LEN1_LOOKUP MEANDIA2.338
PPLOOK(I,ICURRLL)=IPPLOOK(I) MEANDIA2.339
ENDDO MEANDIA2.340
C Reset PPheader words that differ from dump LOOKUP header conventions MEANDIA2.341
PPLOOK(LBREL,ICURRLL)=2 ! PP release no MEANDIA2.342
PPLOOK(DATA_TYPE,ICURRLL)=1 ! Real field MEANDIA2.343
IF (PACKING_TYPE.EQ.1) THEN GO261093.78
PPLOOK(LBPACK,ICURRLL)=02001 ! WGDOS packed MEANDIA2.347
ELSE IF (PACKING_TYPE.EQ.3) THEN GRS3F304.235
PPLOOK(LBPACK,ICURRLL)=02003 ! GRIB packed GRS3F304.236
ELSE MEANDIA2.348
PPLOOK(LBPACK,ICURRLL)=02000 ! Unpacked MEANDIA2.349
ENDIF MEANDIA2.350
RPPVAL = COMP_ACCRCY ! Accuracy @DYALLOC.2437
PPLOOK(BACC,ICURRLL) = IPPVAL @DYALLOC.2438
RPPVAL=RMDI ! Missing data @DYALLOC.2439
PPLOOK(BMDI,ICURRLL)=IPPVAL @DYALLOC.2440
RPPVAL = 1.0 ! MKS scale fac @DYALLOC.2441
PPLOOK(BMKS,ICURRLL)=IPPVAL @DYALLOC.2442
IF (.NOT.GRIB_OUT) THEN GRS3F304.237
PPLOOK(LBLREC,ICURRLL)=NUM_WORDS ! Packed length GRS3F304.238
PPLOOK(LBNREC,ICURRLL)=((NUM_WORDS+um_sector_size-1)/ GBC0F403.99
2 um_sector_size)*um_sector_size GBC0F403.100
C ! Rounded length GRS3F304.240
PPLOOK(LBEGIN,ICURRLL)=IWA ! Address GRS3F304.241
PPLOOK(NADDR,ICURRLL)=IWA ! Address GRS3F304.242
IWA=IWA+PPLOOK(LBNREC,ICURRLL) ! Next address GRS3F304.243
ENDIF GRS3F304.244
ENDDO ! End of loop over levels MEANDIA2.361
ENDIF MEANDIA2.362
C MEANDIA2.363
ENDDO ! End of loop over STASHlist entries MEANDIA2.364
C Update FT_LASTFIELD MEANDIA2.365
FT_LASTFIELD(PPUNIT)=ICURRLL MEANDIA2.366
CL---------------------------------------------------------------------- MEANDIA2.367
CL 4. Finally loop over PP headers and set correct timestamps for the MEANDIA2.368
CL mean period concerned, and also reset LBTIM and LBPROC codes to MEANDIA2.369
CL reflect the mean period for the individual fields. MEANDIA2.370
CL NB: This loop deals with fields from both sections 2 and 3 above. MEANDIA2.371
CL MEANDIA2.372
CL 4.1 Calculate start time of meaning period from current time MEANDIA2.373
CL MEANDIA2.374
CALL TIME2SEC(I_YEAR,I_MONTH,I_DAY,I_HOUR,I_MINUTE,I_SECOND, MEANDIA2.375
& BASIS_TIME_DAYS,BASIS_TIME_SECS, TJ080294.226
& START_DAY,START_SECOND,LCAL360) GSS1F304.477
C MEANDIA2.377
I=1 MEANDIA2.378
IF (I_AO.EQ.1 .or. I_AO.EQ.2) THEN GDR3F305.282
DO INDEXM=1,MEANLEV GDR3F305.283
I=I*MEANFREQim(INDEXM,I_AO) GDR3F305.284
ENDDO GDR3F305.285
CALL STP2TIME(I*DUMPFREQim(I_AO), GDR3F305.286
& STEPS_PER_PERIODim(I_AO),SECS_PER_PERIODim(I_AO), GDR3F305.287
& PERIOD_DAYS,PERIOD_SECS) TJ080294.231
ELSE MEANDIA2.390
ICODE=312 MEANDIA2.391
CMESSAGE='MEANDIAG : I_AO has invalid value' MEANDIA2.392
GOTO 999 MEANDIA2.393
ENDIF MEANDIA2.394
START_SECOND=START_SECOND - PERIOD_SECS TJ080294.232
START_DAY =START_DAY - PERIOD_DAYS TJ080294.233
C MEANDIA2.395
C Note: START_TIME(6) is set to Day Number, not seconds MEANDIA2.396
CALL SEC2TIME(START_DAY,START_SECOND, TJ080294.234
& BASIS_TIME_DAYS,BASIS_TIME_SECS, TJ080294.235
& START_TIME(1),START_TIME(2),START_TIME(3), MEANDIA2.398
& START_TIME(4),START_TIME(5),START_TIME(7), MEANDIA2.399
& START_TIME(6),LCAL360) GSS1F304.478
CL MEANDIA2.401
CL 4.2 Set start and end times in mean PP headers from START_TIME MEANDIA2.402
CL and current time from CTIME. MEANDIA2.403
CL Recalculate LBTIM and LBPROC if necessary. MEANDIA2.404
CL MEANDIA2.405
DO INDEXM=1,FT_LASTFIELD(PPUNIT) MEANDIA2.406
DO I=LBYR,LBDAY MEANDIA2.407
PPLOOK(I,INDEXM)=START_TIME(I) MEANDIA2.408
ENDDO MEANDIA2.409
PPLOOK(LBYRD ,INDEXM)=I_YEAR MEANDIA2.410
PPLOOK(LBMOND,INDEXM)=I_MONTH MEANDIA2.411
PPLOOK(LBDATD,INDEXM)=I_DAY MEANDIA2.412
PPLOOK(LBHRD ,INDEXM)=I_HOUR MEANDIA2.413
PPLOOK(LBMIND,INDEXM)=I_MINUTE MEANDIA2.414
PPLOOK(LBDAYD,INDEXM)=I_DAY_NUMBER MEANDIA2.415
IF (lclimrealyr) then ! real-period means always start GMG1F404.289
PPLOOK(LBDAT,INDEXM)=1 ! on 1st of month GMG1F404.290
if (PPLOOK(LBMON,INDEXM) .eq. 1 .and. GMG1F404.291
& PPLOOK(LBMOND,INDEXM) .eq. 3) then GMG1F404.292
PPLOOK(LBMON,INDEXM)=2 ! correct start month for Feb mean GMG1F404.293
endif GMG1F404.294
ENDIF GMG1F404.295
C MEANDIA2.416
LBTIM_IA=PPLOOK(LBTIM,INDEXM)/100 ! Sample period MEANDIA2.417
IF (LBTIM_IA.EQ.0) THEN ! Reset to dump MEANDIA2.418
LBTIM_IA = (DUMPFREQim(I_AO)*SECS_PER_PERIODim(I_AO))/ GDR3F305.288
& (STEPS_PER_PERIODim(I_AO)*3600) GDR3F305.289
ENDIF MEANDIA2.425
*IF DEF,ATMOS MEANDIA2.426
IF (I_AO.EQ.1) MEANDIA2.427
& PPLOOK(LBTIM,INDEXM)=A_FIXHD(8)+20+ ! Calendar+20+ MEANDIA2.428
& 100*LBTIM_IA ! 100*sample_prd MEANDIA2.429
*ENDIF MEANDIA2.430
*IF DEF,OCEAN MEANDIA2.431
IF (I_AO.EQ.2) MEANDIA2.432
& PPLOOK(LBTIM,INDEXM)=O_FIXHD(8)+20+ ! Calendar+20+ MEANDIA2.433
& 100*LBTIM_IA ! 100*sample_prd MEANDIA2.434
*ENDIF MEANDIA2.435
MEANDIA2.436
C MEANDIA2.437
IF (MOD(PPLOOK(LBPROC,INDEXM)/128,2).EQ.0) ! not a mean MEANDIA2.438
& PPLOOK(LBPROC,INDEXM)=PPLOOK(LBPROC,INDEXM)+128 MEANDIA2.439
ENDDO MEANDIA2.440
! -------------------------------------------------------------------- GRS3F304.245
! 4.2A Section to output fields in grib code GRS3F304.246
! NOTE - pp headers must be correct in everything except field lengths GRS3F304.247
! before call to GRIB_FILE GRS3F304.248
GRS3F304.249
IF (GRIB_OUT) THEN GRS3F304.250
GRS3F304.251
!L loop over STASHlist entries. GRS3F304.252
!L GRS3F304.253
DO IE =1,TOTITEMS GSS1F305.576
modl =STLIST(st_model_code ,IE) GSS1F305.577
IS =STLIST(st_sect_no_code,IE) GSS1F305.578
IM =STLIST(st_item_code ,IE) GSS1F305.579
TAG =STLIST(st_macrotag ,IE)/1000 GSS1F305.580
IF ( (MOD(TAG/(2**(MEANLEV-1)),2).EQ.1) .AND. GSS1F305.581
& (I_AO.EQ.modl) ) THEN GSS1F305.582
C The Tag matches this mean period and the item is in this dump . GRS3F304.261
C GRS3F304.262
C Determine the number of output levels and starting LOOKUP header GRS3F304.263
C (Number of levels now includes possible pseudo_levels) GRS3F304.264
C NB: Note that vertical means (single output level) are a special case GRS3F304.265
C as are timeseries (also single output level) GRS3F304.266
C GRS3F304.267
IF (STLIST(st_input_bottom,IE).EQ.st_special_code) THEN GRS3F304.268
N_LEVS=1 ! Output is a special level GRS3F304.269
ELSEIF (STLIST(st_gridpoint_code,IE).LT.vert_mean_top .AND. GRS3F304.270
& STLIST(st_gridpoint_code,IE).GT.vert_mean_base) THEN GRS3F304.271
N_LEVS=1 ! Output is a vertical mean GRS3F304.272
ELSEIF (STLIST(st_series_ptr,IE).GT.0) THEN GRS3F304.273
N_LEVS=1 ! Output is a timeseries GRS3F304.274
ELSE GRS3F304.275
NO=STLIST(st_output_bottom,IE) GRS3F304.276
IF (NO.LT.0) THEN ! Output is level list GRS3F304.277
N_LEVS=STASH_LEVELS(1,-NO) GRS3F304.278
ELSE ! Output is level range GRS3F304.279
N_LEVS=STLIST(st_output_top,IE)- GRS3F304.280
& STLIST(st_output_bottom,IE)+1 GRS3F304.281
ENDIF GRS3F304.282
ENDIF GRS3F304.283
IF (STLIST(st_pseudo_out,IE).GT.0) THEN GRS3F304.284
NO=STLIST(st_pseudo_out,IE) GRS3F304.285
N_LEVS=N_LEVS*STASH_PSEUDO_LEVELS(1,NO) GRS3F304.286
ENDIF GRS3F304.287
FIELD=STLIST(st_lookup_ptr,IE) GRS3F304.288
*IF DEF,MPP GSM2F404.89
! Address of distributed field in D1 GSM2F404.90
FIELD_ADDRESS=stlist(st_output_addr,IE) GSM2F404.91
*ENDIF GSM2F404.92
C GRS3F304.289
C Loop over the number of output levels GRS3F304.290
DO LEVEL=1,N_LEVS GRS3F304.291
! Copy header for field ready to extract address information GRS3F304.292
ICURRL1=ICURRL1+1 ! Next field GRS3F304.293
DO I=1,LEN1_LOOKUP GRS3F304.294
IPPLOOK(I)=PPLOOK(I,ICURRL1) GRS3F304.295
ENDDO GRS3F304.296
C Field and buffer sizes, and field address in D1 GRS3F304.297
FIELD_LENGTH =IPPLOOK(LBLREC) GRS3F304.298
BUFFER_LENGTH=((FIELD_LENGTH+um_sector_size-1)/ GBC0F403.101
2 um_sector_size)*um_sector_size GBC0F403.102
*IF -DEF,MPP GSM2F404.93
FIELD_ADDRESS=IPPLOOK(NADDR) GRS3F304.300
*ENDIF GSM2F404.94
C Section/Item codes GRS3F304.301
IS=IPPLOOK(ITEM_CODE)/1000 GRS3F304.302
IM=IPPLOOK(ITEM_CODE)-1000*IS GRS3F304.303
C Packing accuracy of the data :- GRS3F304.304
C NB: Presence of extra data disables packing for this field GRS3F304.305
IF (PACKING.AND.(IPPLOOK(LBEXT).LE.0)) THEN GRS3F304.306
COMP_ACCRCY= GRS3F304.307
& EXPPXI(modl,IS,IM,ppx_packing_acc+PP_PACK_CODE(PPUNIT)-1, GSS1F305.583
*CALL ARGPPX GSS1F305.584
& ICODE,CMESSAGE) GSS1F305.585
LPACKFIELD=.TRUE. GRS3F304.309
ELSE GRS3F304.310
COMP_ACCRCY=-99 GRS3F304.311
LPACKFIELD=.FALSE. GRS3F304.312
ENDIF GRS3F304.313
*IF DEF,MPP GSM2F404.95
IF(mype.eq.0)THEN GSM2F404.96
CALL SETPOS_single(PPUNIT,IWA,ICODE) GSM2F404.97
ENDIF GSM2F404.98
SUBM=SUBMODEL_FOR_SM(im_ident) GSM2F404.99
! Check that decomposition type is up to date. GSM2F404.100
D1POS=STLIST(st_d1pos,IE) GSM2F404.101
orig_decomp=current_decomp_type GSM2F404.102
new_decomp=orig_decomp GSM2F404.103
GSM2F404.104
IF ((D1_ADDR(d1_imodl,D1POS,SUBM) .EQ. ATMOS_IM) .AND. GSM2F404.105
& (orig_decomp .NE. decomp_standard_atmos)) THEN GSM2F404.106
GSM2F404.107
new_decomp=decomp_standard_atmos GSM2F404.108
GSM2F404.109
ELSEIF ((D1_ADDR(d1_imodl,D1POS,SUBM) .EQ. OCEAN_IM) .AND. GSM2F404.110
& (D1_ADDR(d1_object_type,D1POS,SUBM) .EQ. prognostic) GSM2F404.111
& .AND. (orig_decomp .NE. decomp_standard_ocean)) THEN GSM2F404.112
GSM2F404.113
new_decomp=decomp_standard_ocean GSM2F404.114
GSM2F404.115
ELSEIF ((D1_ADDR(d1_imodl,D1POS,SUBM) .EQ. OCEAN_IM) .AND. GSM2F404.116
& (D1_ADDR(d1_object_type,D1POS,SUBM) .NE. prognostic) GSM2F404.117
& .AND. (orig_decomp .NE. decomp_nowrap_ocean)) THEN GSM2F404.118
GSM2F404.119
new_decomp=decomp_nowrap_ocean GSM2F404.120
GSM2F404.121
ENDIF GSM2F404.122
GSM2F404.123
IF (new_decomp .NE. orig_decomp) THEN GSM2F404.124
GSM2F404.125
icode=0 GSM2F404.126
CALL CHANGE_DECOMPOSITION(new_decomp,icode) GSM2F404.127
GSM2F404.128
IF (icode .NE. 0) THEN GSM2F404.129
IF (mype .EQ. 0) THEN GSM2F404.130
WRITE(6,*) 'ERROR : MEAN_DIAG' GSM2F404.131
WRITE(6,*) 'Failed to change decomposition to ', GSM2F404.132
& new_decomp GSM2F404.133
WRITE(6,*) 'Field M,S,I ', GSM2F404.134
& D1_ADDR(d1_imodl,D1POS,SUBM), GSM2F404.135
& D1_ADDR(d1_section,D1POS,SUBM), GSM2F404.136
& D1_ADDR(d1_item,D1POS,SUBM) GSM2F404.137
ENDIF GSM2F404.138
CMESSAGE='MEANDIA2 : Failed to change decomposition' GSM2F404.139
GOTO 999 GSM2F404.140
ENDIF GSM2F404.141
GSM2F404.142
ENDIF GSM2F404.143
! Gather full field to PE0 GSM2F404.144
CALL GENERAL_GATHER_FIELD(D1(FIELD_ADDRESS),buf,LOCAL_LEN, GSM2F404.145
& FIELD_LENGTH,D1_ADDR(1,STLIST(st_d1pos,IE),SUBM),0, GSM2F404.146
& ICODE,CMESSAGE) GSM2F404.147
IF (ICODE .EQ. 1) THEN GSM2F404.148
WRITE(6,*)'MEANDIA2: Field number ',IS, GSM2F404.149
& 'with dimensions ', N_COLS,' x ', GSM2F404.150
& N_ROWS,' and gridtype ', GSM2F404.151
& D1_ADDR(d1_grid_type,STLIST(st_d1pos,IE),SUBM), GSM2F404.152
& 'was unrecognized and not gathered.' GSM2F404.153
CMESSAGE='MEANDIA2: Unrecognized field on write' GSM2F404.154
GOTO 999 GSM2F404.155
ELSEIF (ICODE .NE. 0) THEN GSM2F404.156
GOTO 999 GSM2F404.157
ENDIF GSM2F404.158
IF (mype .EQ. 0) THEN GSM2F404.159
CALL GRIB_FILE(LEN1_LOOKUP,PP_LEN_MEAN,PPLOOK,PPLOOK, GSM2F404.160
& ICURRL1,BUF,FIELD_LENGTH, GSM2F404.161
& BUFFER_LENGTH,NUM_WORDS,PPUNIT,IWA, GSM2F404.162
& GRIB_PACKING,ICODE,CMESSAGE) GSM2F404.163
ENDIF GSM2F404.164
GSM2F404.165
CALL GC_IBCAST(999,1,0,nproc,info,ICODE) GSM2F404.166
IF(ICODE.GT.0) THEN GSM2F404.167
CMESSAGE= GSM2F404.168
& 'MEANDIA2: Error in GRIB_FILE - see ICODE for item' GJC0F405.31
ICODE=1000*IS+IM GSM2F404.170
GOTO 999 GSM2F404.171
ENDIF GSM2F404.172
IWA=IWA+PPLOOK(LBNREC,ICURRL1) ! Next address GSM2F404.173
*ELSE GSM2F404.174
C Output the field from D1 to the PPfile with the requisite packing GRS3F304.314
CALL GRIB_FILE(LEN1_LOOKUP,PP_LEN_MEAN,PPLOOK,PPLOOK, GRS3F304.315
& ICURRL1,D1(FIELD_ADDRESS),FIELD_LENGTH, GRS3F304.316
& BUFFER_LENGTH,NUM_WORDS,PPUNIT,IWA, GRS3F304.317
& GRIB_PACKING,ICODE,CMESSAGE) GRS3F400.294
IF(ICODE.GT.0) THEN GRS3F304.319
CMESSAGE='MEANDIA1: Error in GRIB_FILE - see ICODE for item' GRS3F304.320
ICODE=1000*IS+IM GRS3F304.321
GOTO 999 GRS3F304.322
ENDIF GRS3F304.323
IWA=IWA+PPLOOK(LBNREC,ICURRL1) ! Next address GRS3F304.324
*ENDIF GSM2F404.175
ENDDO ! End of loop over levels GRS3F304.325
ENDIF GRS3F304.326
C GRS3F304.327
ENDDO ! End of loop over STASHlist entries GRS3F304.328
GRS3F304.329
! reset PP_PACK_CODE for future use GRS3F304.330
GRS3F304.331
PP_PACK_CODE(PPUNIT)=PP_PACK_CODE(PPUNIT)+100 GRS3F304.332
ENDIF GRS3F304.333
! -------------------------------------------------------------------- GRS3F304.334
CL MEANDIA2.441
CL 4.3 Buffer LOOKUP headers from work array back to file and close it MEANDIA2.442
CL MEANDIA2.443
CALL SETPOS(PPUNIT,WORD_ADDRESS,ICODE) GTD0F400.104
CALL BUFFOUT(PPUNIT,PPLOOK(1,1),LEN1_LOOKUP*PP_LEN_MEAN,LEN_IO, MEANDIA2.445
* A_IO) MEANDIA2.446
IF(A_IO.NE.-1.0.OR.LEN_IO.NE.LEN1_LOOKUP*PP_LEN_MEAN) THEN MEANDIA2.447
CALL IOERROR('Buffer out of LOOKUP table ',A_IO,LEN_IO, MEANDIA2.448
* LEN1_LOOKUP*PP_LEN_MEAN) MEANDIA2.449
CMESSAGE='MEANDIAG : Error writing PPfile LOOKUP table' MEANDIA2.450
ICODE=314 MEANDIA2.451
GOTO 999 MEANDIA2.452
ENDIF MEANDIA2.453
LEN_PPNAME=LEN(PPNAME) MEANDIA2.454
CALL FILE_CLOSE(PPUNIT,PPNAME,LEN_PPNAME,1,0,ICODE) GTD0F400.23
CL---------------------------------------------------------------------- MEANDIA2.456
CL 5. Construct mean PPfile processing requests and output to server MEANDIA2.457
!L This deals with both "normal" and section 21-24 etc period means GMG1F404.296
CL MEANDIA2.458
NFTPIPE = 8 MEANDIA2.459
INDEXM = MEANLEV MEANDIA2.460
*IF DEF,MPP GLW2F403.26
IF(mype.eq.0) THEN GLW2F403.27
*ENDIF GLW2F403.28
IF (I_AO.EQ.1 .or. I_AO.EQ.2) THEN GDR3F305.290
IF (PPSELECTim(INDEXM,I_AO).EQ.1) THEN GDR3F305.291
IF (ARCHPPSELim(INDEXM,I_AO).EQ.1) THEN PXMEAND.1
IF (PLOTSELim(INDEXM,I_AO).GE.1) THEN PXMEAND.2
IF (MOD(STEP_DUMPS,MEAN_PERIOD*PLOTSELim(INDEXM,I_AO)) PXMEAND.3
& .EQ.0) THEN PXMEAND.4
WRITE(NFTPIPE,410) PPNAME ! Archive and plot charts PXMEAND.5
ELSE PXMEAND.6
WRITE(NFTPIPE,420) PPNAME ! Archive without plotting PXMEAND.7
ENDIF PXMEAND.8
ELSE PXMEAND.9
WRITE(NFTPIPE,420) PPNAME ! Archive without plotting PXMEAND.10
ENDIF PXMEAND.11
ELSE PXMEAND.12
IF (PLOTSELim(INDEXM,I_AO).GE.1) THEN PXMEAND.13
IF (MOD(STEP_DUMPS,MEAN_PERIOD*PLOTSELim(INDEXM,I_AO)) PXMEAND.14
& .EQ.0) THEN PXMEAND.15
WRITE(NFTPIPE,430) PPNAME ! No archiving but plot PXMEAND.16
ENDIF PXMEAND.17
ENDIF PXMEAND.18
ENDIF PXMEAND.19
IF (MEANWSim(INDEXM,I_AO).EQ."Y") THEN GDR3F305.297
WRITE(NFTPIPE,450) PPNAME ! Transfer to workstation MEANDIA2.478
ENDIF MEANDIA2.479
IF (PPUNIT.EQ.22.OR.PPUNIT.EQ.42.OR.(PPUNIT.GT.59.AND. GLW6F403.2
& PPUNIT.LT.68)) THEN GLW6F403.3
IF (FT_SELECT(PPUNIT).EQ."Y") THEN GLW6F403.4
WRITE(NFTPIPE,440) PPNAME ! Delete from Cray GLW6F403.5
ENDIF GLW6F403.6
ELSE GLW6F403.7
WRITE(NFTPIPE,440) PPNAME ! Delete from Cray MEANDIA2.480
ENDIF GLW6F403.8
ENDIF MEANDIA2.481
ENDIF MEANDIA2.482
*IF DEF,MPP GLW2F403.29
ENDIF GLW2F403.30
*ENDIF GLW2F403.31
410 FORMAT("%%% ",A14," ARCHIVE PPCHART") MEANDIA2.507
420 FORMAT("%%% ",A14," ARCHIVE PPNOCHART") MEANDIA2.508
430 FORMAT("%%% ",A14," PLOTONLY PPCHART") MEANDIA2.509
440 FORMAT("%%% ",A14," DELETE") MEANDIA2.510
450 FORMAT("%%% ",A14," HPSEND") MEANDIA2.511
CL---------------------------------------------------------------------- MEANDIA2.512
999 CONTINUE MEANDIA2.513
RETURN MEANDIA2.514
END MEANDIA2.515
*ENDIF MEANDIA2.516