*IF DEF,CONTROL MEANPS1.2
C ******************************COPYRIGHT****************************** GTS2F400.5887
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.5888
C GTS2F400.5889
C Use, duplication or disclosure of this code is subject to the GTS2F400.5890
C restrictions as set forth in the contract. GTS2F400.5891
C GTS2F400.5892
C Meteorological Office GTS2F400.5893
C London Road GTS2F400.5894
C BRACKNELL GTS2F400.5895
C Berkshire UK GTS2F400.5896
C RG12 2SZ GTS2F400.5897
C GTS2F400.5898
C If no contract has been raised with this copy of the code, the use, GTS2F400.5899
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.5900
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.5901
C Modelling at the above address. GTS2F400.5902
C ******************************COPYRIGHT****************************** GTS2F400.5903
C GTS2F400.5904
CLL MEANPS1.3
CLL Subroutine: MEANPS1.4
CLL MEANPS MEANPS1.5
CLL MEANPS1.6
CLL Purpose: MEANPS1.7
CLL To mean partial sums and create dumps MEANPS1.8
CLL MEANPS1.9
CLL Tested under compiler cft77 MEANPS1.10
CLL Tested under OS version: MEANPS1.11
CLL UNICOS 5.1 MEANPS1.12
CLL MEANPS1.13
CLL T.J., D.R. <- programmer of some or all of previous code or changes MEANPS1.14
CLL MEANPS1.15
CLL Model Modification history from model version 3.0: MEANPS1.16
CLL version Date MEANPS1.17
CLL 3.1 19/02/93 Use FIXHD(12) not FIXHD(1) as Version no in P21BITS TJ190293.4
CLL 3.1 25/01/93 : Corrected LBPACK after change to definition. RS250193.6
CLL 3.4 16/6/94 : Change CHARACTER*(*) to CHARACTER*(80) N.Farnon ANF0F304.30
! 4.1 18/06/96 Changes to cope with changes in STASH addressing GDG0F401.870
! Author D.M. Goddard. GDG0F401.871
!LL 4.2 27/11/96 MPP changes for T3E. Using READDUMP to GKR1F402.289
!LL read in partial mean files. K Rogers GKR1F402.290
CLL 4.3 23/01/97 Use MPP_LOOKUP adresses when on MPP GSM1F403.213
CLL 17/04/97 And pass D1_ADDR to UM_READDUMP GSM1F403.214
CLL S.D.Mullerworth GSM1F403.215
!LL 4.3 10/04/97 Add READHDR argument to READDUMP. K Rogers GKR3F403.23
CLL MEANPS1.18
CLL Programming standard: MEANPS1.19
CLL UM Doc Paper 3 MEANPS1.20
CLL MEANPS1.21
CLL Logical system components covered: MEANPS1.22
CLL C5 MEANPS1.23
CLL MEANPS1.24
CLL Project tasks: MEANPS1.25
CLL C5,C51,C52 MEANPS1.26
CLL MEANPS1.27
CLL External documentation: MEANPS1.28
CLL On-line UM document C5 - Control of means calculations MEANPS1.29
CLL MEANPS1.30
C*L Interface and arguments: MEANPS1.31
SUBROUTINE MEANPS( FIXHD,LEN_FIXHD 4,1GKR1F402.291
& ,INTHD,LEN_INTHD GKR1F402.292
& ,REALHD,LEN_REALHD GKR1F402.293
& ,LEVDEPC,LEN1_LEVDEPC,LEN2_LEVDEPC GKR1F402.294
& ,ROWDEPC,LEN1_ROWDEPC,LEN2_ROWDEPC GKR1F402.295
& ,COLDEPC,LEN1_COLDEPC,LEN2_COLDEPC GKR1F402.296
& ,FLDDEPC,LEN1_FLDDEPC,LEN2_FLDDEPC GKR1F402.297
& ,EXTCNST,LEN_EXTCNST GKR1F402.298
& ,DUMPHIST,LEN_DUMPHIST GKR1F402.299
& ,CFI1,LEN_CFI1 GKR1F402.300
& ,CFI2,LEN_CFI2 GKR1F402.301
& ,CFI3,LEN_CFI3 GKR1F402.302
& ,LOOKUP,LEN1_LOOKUP,LEN2_LOOKUP GKR1F402.304
& ,SUBM,N_OBJS_D1,D1_ADDR GSM1F403.216
*IF DEF,MPP GSM1F403.217
& ,MPP_LOOKUP,MPP_LEN1_LOOKUP GSM1F403.218
*ENDIF GKR1F402.307
& ,LEN_DATA,D1,LD1,ID1,IBUFLEN, GKR1F402.308
& NFTIN,MEANING_PERIOD, GDG0F401.874
*CALL ARGPPX 
GDG0F401.875
& ICODE,CMESSAGE) GDG0F401.876
C MEANPS1.37
IMPLICIT NONE MEANPS1.38
*CALL D1_ADDR GSM1F403.219
C MEANPS1.39
INTEGER GKR1F402.309
* LEN_FIXHD !IN Length of fixed length header GKR1F402.310
*,LEN_INTHD !IN Length of integer header GKR1F402.311
*,LEN_REALHD !IN Length of real header GKR1F402.312
*,LEN1_LEVDEPC !IN 1st dim of level dep consts GKR1F402.313
*,LEN2_LEVDEPC !IN 2nd dim of level dep consts GKR1F402.314
*,LEN1_ROWDEPC !IN 1st dim of row dep consts GKR1F402.315
*,LEN2_ROWDEPC !IN 2nd dim of row dep consts GKR1F402.316
&,LEN1_COLDEPC !IN 1st dim of column dep consts GKR1F402.317
&,LEN2_COLDEPC !IN 2nd dim of column dep consts GKR1F402.318
&,LEN1_FLDDEPC !IN 1st dim of field dep consts GKR1F402.319
&,LEN2_FLDDEPC !IN 2nd dim of field dep consts GKR1F402.320
&,LEN_EXTCNST !IN Length of extra constants GKR1F402.321
&,LEN_DUMPHIST !IN Length of history block GKR1F402.322
&,LEN_CFI1 !IN Length of comp field index 1 GKR1F402.323
&,LEN_CFI2 !IN Length of comp field index 2 GKR1F402.324
&,LEN_CFI3 !IN Length of comp field index 3 GKR1F402.325
&,LEN1_LOOKUP !IN 1st dim of lookup GKR1F402.326
&,LEN2_LOOKUP !IN 2nd dim of lookup GKR1F402.327
&,N_OBJS_D1 GSM1F403.220
&,SUBM GSM1F403.221
*IF DEF,MPP GSM1F403.222
&,MPP_LEN1_LOOKUP !IN 1st dim of MPP lookup GSM1F403.223
*ENDIF GSM1F403.224
GKR1F402.328
INTEGER GKR1F402.329
* FIXHD(LEN_FIXHD) !IN Fixed length header GKR1F402.330
*,INTHD(LEN_INTHD) !IN Integer header GKR1F402.331
*,LOOKUP(LEN1_LOOKUP,LEN2_LOOKUP) !IN PP lookup tables GKR1F402.332
&,D1_ADDR(D1_LIST_LEN,N_OBJS_D1) GSM1F403.225
*IF DEF,MPP GKR1F402.333
C Local addressing of D1 GSM1F403.226
*,MPP_LOOKUP(MPP_LEN1_LOOKUP,LEN2_LOOKUP) ! OUT GSM1F403.227
*ENDIF GKR1F402.338
*,CFI1(LEN_CFI1+1) !IN Compressed field index no 1 GKR1F402.339
*,CFI2(LEN_CFI2+1) !IN Compressed field index no 2 GKR1F402.340
*,CFI3(LEN_CFI3+1) !IN Compressed field index no 3 GKR1F402.341
GKR1F402.342
REAL GKR1F402.343
& REALHD(LEN_REALHD) !IN Real header GKR1F402.344
&,LEVDEPC(1+LEN1_LEVDEPC*LEN2_LEVDEPC) !IN Lev dep consts GKR1F402.345
&,ROWDEPC(1+LEN1_ROWDEPC*LEN2_ROWDEPC) !IN Row dep consts GKR1F402.346
&,COLDEPC(1+LEN1_COLDEPC*LEN2_COLDEPC) !IN Col dep consts GKR1F402.347
&,FLDDEPC(1+LEN1_FLDDEPC*LEN2_FLDDEPC) !IN Field dep consts GKR1F402.348
&,EXTCNST(LEN_EXTCNST+1) !IN Extra constants GKR1F402.349
&,DUMPHIST(LEN_DUMPHIST+1) !IN History block GKR1F402.350
INTEGER MEANPS1.40
& IBUFLEN, ! IN dimension of largest data field MEANPS1.44
& LEN_DATA, ! IN Length of model data MEANPS1.45
& NFTIN, ! IN Unit no for partial sum read MEANPS1.46
& MEANING_PERIOD, ! IN Meaning period (in multiples MEANPS1.47
* ! of restart frequency) MEANPS1.48
& ICODE ! OUT Return code; successful=0 MEANPS1.49
* ! error>0 MEANPS1.50
C MEANPS1.51
CHARACTER*(80) ANF0F304.31
& CMESSAGE ! OUT Error message if ICODE>0 MEANPS1.53
C MEANPS1.54
INTEGER MEANPS1.55
& ID1(LEN_DATA) ! IN Integer equivalence of data block MEANPS1.58
C MEANPS1.59
REAL MEANPS1.60
& D1(LEN_DATA) ! IN Real equivalence of data block MEANPS1.61
C MEANPS1.62
LOGICAL MEANPS1.63
& LD1(LEN_DATA) ! IN Logical equivalence of data block MEANPS1.64
C MEANPS1.65
C Common blocks MEANPS1.66
C MEANPS1.67
*CALL CLOOKADD MEANPS1.68
*CALL C_MDI MEANPS1.69
*CALL CSUBMODL GDG0F401.877
*CALL CPPXREF GDG0F401.878
*CALL PPXLOOK GDG0F401.879
*IF DEF,MPP GKR1F402.351
*CALL PARVARS GKR1F402.352
*ENDIF GKR1F402.353
C MEANPS1.70
C*L MEANPS1.71
C*L External subroutines called: MEANPS1.72
EXTERNAL IOERROR,PR_LOOK,EXPAND21,BUFFIN,P21BITS,UM_READDUMP GSM1F403.228
INTEGER P21BITS MEANPS1.74
C MEANPS1.75
C Cray specific functions UNIT,LENGTH MEANPS1.76
MEANPS1.77
C MEANPS1.78
C Local variables MEANPS1.79
C MEANPS1.80
INTEGER MEANPS1.81
& LEN_IO, ! No of 64-bit words buffered in/out MEANPS1.82
& IP1,IP2, ! I/O buffer indices (=1 or 2) MEANPS1.83
& IPTS_IN,IPTS_OUT, ! No of 64-bit words requested to MEANPS1.84
* ! be buffered in/out MEANPS1.85
& I,K, ! Loop indices MEANPS1.86
& extraw ! no of extra wors MEANPS1.87
&, info GKR1F402.355
&, LREC,ADDR ! Address and record length of field GSM1F403.229
C MEANPS1.88
REAL MEANPS1.89
& FACTOR, ! Meaning period (real) MEANPS1.90
& RFACTOR, ! Reciprocal of FACTOR MEANPS1.91
& A ! Error code from UNIT MEANPS1.92
&, D1_DATA(IBUFLEN) ! GKR1F402.356
GKR1F402.357
C MEANPS1.93
C Local arrays MEANPS1.94
C MEANPS1.95
REAL MEANPS1.96
& BUF(IBUFLEN,2), ! I/O buffer space (real) MEANPS1.97
& FIELD_DATA(IBUFLEN) ! Work area for fields MEANPS1.98
* ! of real data MEANPS1.99
C MEANPS1.100
C Constants MEANPS1.101
C MEANPS1.102
REAL MEANPS1.103
& ONE ! 1.0 MEANPS1.104
C MEANPS1.105
IF(ICODE.NE.0)GOTO 999 MEANPS1.106
C MEANPS1.107
ONE=1.0 MEANPS1.108
FACTOR=MEANING_PERIOD MEANPS1.109
RFACTOR=ONE/FACTOR MEANPS1.110
C MEANPS1.111
C Initialise pointers used for I/O buffers MEANPS1.112
C MEANPS1.113
IP1=1 MEANPS1.114
IP2=2 MEANPS1.115
CL MEANPS1.116
CL********************************************************************** MEANPS1.117
CL Start of loop over number of fields in data blocks MEANPS1.118
CL********************************************************************** MEANPS1.119
GKR1F402.358
CALL UM_READDUMP(NFTIN, FIXHD, LEN_FIXHD, GSM1F403.230
& INTHD, LEN_INTHD, GKR1F402.360
& REALHD, LEN_REALHD, GKR1F402.361
& LEVDEPC, LEN1_LEVDEPC, LEN2_LEVDEPC, GKR1F402.362
& ROWDEPC, LEN1_ROWDEPC, LEN2_ROWDEPC, GKR1F402.363
& COLDEPC, LEN1_COLDEPC, LEN2_COLDEPC, GKR1F402.364
& FLDDEPC, LEN1_FLDDEPC, LEN2_FLDDEPC, GKR1F402.365
& EXTCNST, LEN_EXTCNST, GKR1F402.366
& DUMPHIST, LEN_DUMPHIST, GKR1F402.367
& CFI1, LEN_CFI1, GKR1F402.368
& CFI2, LEN_CFI2, GKR1F402.369
& CFI3, LEN_CFI3, GKR1F402.370
& LOOKUP,LEN1_LOOKUP,LEN2_LOOKUP, GSM1F403.231
*IF DEF,MPP GSM1F403.232
& MPP_LOOKUP,MPP_LEN1_LOOKUP, GSM1F403.233
*ENDIF GKR1F402.376
& SUBM,N_OBJS_D1,D1_ADDR, GSM1F403.234
& LEN_DATA,D1, GKR1F402.377
*CALL ARGPPX GKR1F402.378
& .false.,ICODE,CMESSAGE) GKR3F403.24
GKR1F402.380
*IF DEF,MPP GKR1F402.381
! Broadcast return code to all processors. GKR1F402.382
CALL GC_IBCAST(679,1,0,nproc,info,icode) GKR1F402.383
*ENDIF GKR1F402.384
GKR1F402.385
CL---------------------------------------------------------------------- MEANPS1.157
CL Process data (real only) MEANPS1.158
CL---------------------------------------------------------------------- MEANPS1.159
CL MEANPS1.160
DO 200 K=1,FIXHD(152)+1 GKR1F402.386
GKR1F402.387
IF(K.NE.1)THEN MEANPS1.161
CL MEANPS1.179
CL Create required time-mean data and copy MEANPS1.180
CL to main COMMON area for diagnostics to be performed MEANPS1.181
CL MEANPS1.182
IF(LOOKUP(DATA_TYPE,K-1).EQ.1.OR. MEANPS1.183
& LOOKUP(DATA_TYPE,K-1).EQ.-1.OR.LOOKUP(DATA_TYPE,K-1).EQ.4) THEN MEANPS1.184
CL MEANPS1.185
CL Time-mean data and copy to main data block, leaving missing data MEANPS1.186
CL untouched MEANPS1.187
CL MEANPS1.188
*IF DEF,MPP GSM1F403.235
LREC = MPP_LOOKUP(P_LBLREC,K-1) GSM1F403.236
ADDR = MPP_LOOKUP(P_NADDR,K-1) GSM1F403.237
*ELSE GSM1F403.238
LREC = LOOKUP(LBLREC,K-1) GSM1F403.239
ADDR = LOOKUP(NADDR,K-1) GSM1F403.240
*ENDIF GSM1F403.241
IF (lookup(lbext,k-1).eq.imdi) THEN MEANPS1.189
extraw=0 MEANPS1.190
ELSE MEANPS1.191
extraw=lookup(lbext,k-1) MEANPS1.192
ENDIF MEANPS1.193
DO 220 I=1,LREC-extraw GSM1F403.242
CL don't process extra data. MEANPS1.195
D1_DATA(I) = D1(ADDR+I-1) GSM1F403.243
IF (D1_DATA(I).NE.RMDI) THEN GJC0F405.32
D1_DATA(I)=D1_DATA(I)*RFACTOR GKR1F402.390
ENDIF MEANPS1.198
220 CONTINUE MEANPS1.199
DO 230 i=1,lrec GSM1F403.244
CL we do want to copy the extra data though MEANPS1.201
D1(ADDR+I-1)=D1_DATA(I) GSM1F403.245
230 CONTINUE MEANPS1.203
C MEANPS1.204
ENDIF MEANPS1.205
C MEANPS1.206
ENDIF MEANPS1.207
CL MEANPS1.208
CL---------------------------------------------------------------------- MEANPS1.209
CL Check for errors in data transfer from disk MEANPS1.210
CL---------------------------------------------------------------------- MEANPS1.211
CL MEANPS1.212
C MEANPS1.222
C Toggle pointers used for I/O buffers on next pass of loop MEANPS1.223
C MEANPS1.224
IP1=3-IP1 MEANPS1.225
IP2=3-IP2 MEANPS1.226
C MEANPS1.227
200 CONTINUE MEANPS1.228
CL MEANPS1.229
CL********************************************************************** MEANPS1.230
CL End of loop over number of fields MEANPS1.231
CL********************************************************************** MEANPS1.232
CL MEANPS1.233
999 CONTINUE MEANPS1.234
RETURN MEANPS1.235
END MEANPS1.236
*ENDIF MEANPS1.237