*IF DEF,CONTROL ACUMPS1.2
C ******************************COPYRIGHT****************************** GTS2F400.127
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.128
C GTS2F400.129
C Use, duplication or disclosure of this code is subject to the GTS2F400.130
C restrictions as set forth in the contract. GTS2F400.131
C GTS2F400.132
C Meteorological Office GTS2F400.133
C London Road GTS2F400.134
C BRACKNELL GTS2F400.135
C Berkshire UK GTS2F400.136
C RG12 2SZ GTS2F400.137
C GTS2F400.138
C If no contract has been raised with this copy of the code, the use, GTS2F400.139
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.140
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.141
C Modelling at the above address. GTS2F400.142
C ******************************COPYRIGHT****************************** GTS2F400.143
C GTS2F400.144
CLL ACUMPS1.3
CLL Subroutine: ACUMPS1.4
CLL ACUMPS ACUMPS1.5
CLL ACUMPS1.6
CLL Purpose: ACUMPS1.7
CLL To accumulate partial sums and create dumps ACUMPS1.8
CLL ACUMPS1.9
CLL Tested under compiler: ACUMPS1.10
CLL cft77 ACUMPS1.11
CLL ACUMPS1.12
CLL Tested under OS version: ACUMPS1.13
CLL UNICOS 5.1 ACUMPS1.14
CLL ACUMPS1.15
CLL AD, DR <- programmer of some or all of previous code or changes ACUMPS1.16
CLL ACUMPS1.17
CLL Model Modification history from model version 3.0: ACUMPS1.18
CLL version Date ACUMPS1.19
CLL 3.1 19/02/93 Use FIXHD(12) not FIXHD(1) as Version no in P21BITS TJ190293.1
CLL 3.1 25/01/93 : Correct LBPACK for 32 bit dumps after changes. RS250193.1
CLL 3.4 16/6/94 : Change CHARACTER*(*) to CHARACTER*(80) N.Farnon ANF0F304.1
! 4.1 18/06/96 Changes to cope with changes in STASH addressing GDG0F401.32
! Author D.M. Goddard. GDG0F401.33
!LL 4.2 27/11/96 MPP changes for T3E. Using READDUMP and GKR1F402.120
!LL WRITDUMP with partial mean files. K Rogers GKR1F402.121
CLL 4.3 22/01/97 Use MPP_LOOKUP to address D1 on MPP GSM1F403.91
CLL S.D.Mullerworth GSM1F403.92
!LL 4.3 10/04/97 Call READDUMP without reading header to avoid GKR3F403.13
!LL overwriting REALHD with previous values. K Rogers GKR3F403.14
!LL 4.4 22/09/97 Remove superfluous arrays. Add extra error trap GSM2F404.176
!LL S.D. Mullerworth GSM2F404.177
!LL 4.4 26/06/97 Changes to allow climate means with Gregorian GMG1F404.1
!LL calendar. Author: M. Gallani GMG1F404.2
!LL 4.4 16/06/97 Add Broadcast after the WRITDUMP, so GBC3F404.1
!LL that all the processors know the answer GBC3F404.2
!LL Author: Bob Carruthers, Cray Rsearch. GBC3F404.3
!LL 4.5 23/10/98 Remove unused arrays. S.D.Mullerworth GSM2F405.35
CLL ACUMPS1.20
CLL Programming standard: ACUMPS1.21
CLL UM Doc Paper 3 ACUMPS1.22
CLL ACUMPS1.23
CLL Logical system components covered: ACUMPS1.24
CLL C5 ACUMPS1.25
CLL ACUMPS1.26
CLL Project tasks: ACUMPS1.27
CLL C5,C51,C52 ACUMPS1.28
CLL ACUMPS1.29
CLL External documentation: ACUMPS1.30
CLL On-line UM document C5 - Control of means calculations ACUMPS1.31
CLL ACUMPS1.32
C*L Interface and arguments: ACUMPS1.33
SUBROUTINE ACUMPS( FIXHD,LEN_FIXHD 4,3GKR1F402.122
& ,INTHD,LEN_INTHD GKR1F402.123
& ,REALHD,LEN_REALHD GKR1F402.124
& ,LEVDEPC,LEN1_LEVDEPC,LEN2_LEVDEPC GKR1F402.125
& ,ROWDEPC,LEN1_ROWDEPC,LEN2_ROWDEPC GKR1F402.126
& ,COLDEPC,LEN1_COLDEPC,LEN2_COLDEPC GKR1F402.127
& ,FLDDEPC,LEN1_FLDDEPC,LEN2_FLDDEPC GKR1F402.128
& ,EXTCNST,LEN_EXTCNST GKR1F402.129
& ,DUMPHIST,LEN_DUMPHIST GKR1F402.130
& ,CFI1,LEN_CFI1 GKR1F402.131
& ,CFI2,LEN_CFI2 GKR1F402.132
& ,CFI3,LEN_CFI3 GKR1F402.133
& ,LOOKUP,LEN1_LOOKUP,LEN2_LOOKUP GKR1F402.135
& ,SUBM,N_OBJS_D1,D1_ADDR GSM1F403.93
*IF DEF,MPP GSM1F403.94
& ,MPP_LOOKUP,MPP_LEN1_LOOKUP GSM1F403.95
*ENDIF GKR1F402.138
& ,LEN_DATA,D1,LD1,ID1,IBUFLEN GKR1F402.139
& ,FLAG,NFTIN,NFTOUT,LCLIMREALYR,MEANLEV GMG1F404.3
& ,I_MONTH,I_YEAR, GMG1F404.4
*CALL ARGPPX 
GDG0F401.38
& ICODE,CMESSAGE) GDG0F401.39
C ACUMPS1.39
IMPLICIT NONE ACUMPS1.40
C ACUMPS1.41
*CALL D1_ADDR GSM1F403.103
INTEGER ACUMPS1.42
* LEN_FIXHD !IN Length of fixed length header GKR1F402.141
*,LEN_INTHD !IN Length of integer header GKR1F402.142
*,LEN_REALHD !IN Length of real header GKR1F402.143
*,LEN1_LEVDEPC !IN 1st dim of level dep consts GKR1F402.144
*,LEN2_LEVDEPC !IN 2nd dim of level dep consts GKR1F402.145
*,LEN1_ROWDEPC !IN 1st dim of row dep consts GKR1F402.146
*,LEN2_ROWDEPC !IN 2nd dim of row dep consts GKR1F402.147
&,LEN1_COLDEPC !IN 1st dim of column dep consts GKR1F402.148
&,LEN2_COLDEPC !IN 2nd dim of column dep consts GKR1F402.149
&,LEN1_FLDDEPC !IN 1st dim of field dep consts GKR1F402.150
&,LEN2_FLDDEPC !IN 2nd dim of field dep consts GKR1F402.151
&,LEN_EXTCNST !IN Length of extra constants GKR1F402.152
&,LEN_DUMPHIST !IN Length of history block GKR1F402.153
&,LEN_CFI1 !IN Length of comp field index 1 GKR1F402.154
&,LEN_CFI2 !IN Length of comp field index 2 GKR1F402.155
&,LEN_CFI3 !IN Length of comp field index 3 GKR1F402.156
&,LEN1_LOOKUP !IN 1st dim of lookup GKR1F402.157
&,LEN2_LOOKUP !IN 2nd dim of lookup GKR1F402.158
&,N_OBJS_D1 !IN No objects in D1 array GSM1F403.96
&,SUBM !IN Submodel id GSM1F403.97
*IF DEF,MPP GSM1F403.98
&,MPP_LEN1_LOOKUP !IN 1st dim of MPP lookup GSM1F403.99
*ENDIF GSM1F403.100
GKR1F402.159
INTEGER GKR1F402.160
* FIXHD(LEN_FIXHD) !IN Fixed length header GKR1F402.161
*,INTHD(LEN_INTHD) !IN Integer header GKR1F402.162
*,LOOKUP(LEN1_LOOKUP,LEN2_LOOKUP) !IN PP lookup tables GKR1F402.163
&,D1_ADDR(D1_LIST_LEN,N_OBJS_D1) !IN Addressing of D1 array GSM1F403.104
*IF DEF,MPP GKR1F402.164
C Local addressing of D1 GSM1F403.101
*,MPP_LOOKUP(MPP_LEN1_LOOKUP,LEN2_LOOKUP) ! OUT GSM1F403.102
*ENDIF GKR1F402.169
*,CFI1(LEN_CFI1+1) !IN Compressed field index no 1 GKR1F402.170
*,CFI2(LEN_CFI2+1) !IN Compressed field index no 2 GKR1F402.171
*,CFI3(LEN_CFI3+1) !IN Compressed field index no 3 GKR1F402.172
GKR1F402.173
REAL GKR1F402.174
& REALHD(LEN_REALHD) !IN Real header GKR1F402.175
&,LEVDEPC(1+LEN1_LEVDEPC*LEN2_LEVDEPC) !IN Lev dep consts GKR1F402.176
&,ROWDEPC(1+LEN1_ROWDEPC*LEN2_ROWDEPC) !IN Row dep consts GKR1F402.177
&,COLDEPC(1+LEN1_COLDEPC*LEN2_COLDEPC) !IN Col dep consts GKR1F402.178
&,FLDDEPC(1+LEN1_FLDDEPC*LEN2_FLDDEPC) !IN Field dep consts GKR1F402.179
&,EXTCNST(LEN_EXTCNST+1) !IN Extra constants GKR1F402.180
&,DUMPHIST(LEN_DUMPHIST+1) !IN History block GKR1F402.181
INTEGER GKR1F402.182
& IBUFLEN, ! IN dimension of largest data field ACUMPS1.46
& LEN_DATA, ! IN Length of model data ACUMPS1.47
& FLAG, ! IN Flag for reading partial sum dump ACUMPS1.48
& NFTIN, ! IN Unit no for reading partial sums ACUMPS1.49
& NFTOUT, ! IN Unit no for writing partial sums ACUMPS1.50
& ICODE, ! OUT Return code; successful=0 GMG1F404.5
& ! error>0 GMG1F404.6
& MEANLEV, ! IN level of climate meaning GMG1F404.7
& I_MONTH, ! IN Current model time (months) GMG1F404.8
& I_YEAR ! IN Current model time (years) GMG1F404.9
C ACUMPS1.53
CHARACTER *(80) ANF0F304.2
& CMESSAGE ! OUT Error message if ICODE>0 ACUMPS1.55
C ACUMPS1.56
INTEGER ACUMPS1.57
& ID1(LEN_DATA) ! IN Integer equivalence of data block ACUMPS1.60
C ACUMPS1.61
REAL ACUMPS1.62
& D1(LEN_DATA) ! IN Real equivalence of data block ACUMPS1.63
C ACUMPS1.64
LOGICAL ACUMPS1.65
& LD1(LEN_DATA), ! IN Logical equivalence of data block GMG1F404.10
& LCLIMREALYR ! IN Real-period climate meaning GMG1F404.11
C ACUMPS1.67
C Common blocks ACUMPS1.68
C ACUMPS1.69
*CALL CLOOKADD ACUMPS1.70
*CALL C_MDI ACUMPS1.71
*CALL CSUBMODL GDG0F401.40
*CALL CPPXREF GDG0F401.41
*CALL PPXLOOK GDG0F401.42
*IF DEF,MPP GKR1F402.183
*CALL PARVARS GKR1F402.184
*ENDIF GKR1F402.185
C ACUMPS1.72
C*L ACUMPS1.73
C*L External subroutines called: ACUMPS1.74
EXTERNAL IOERROR,PR_LOOK,EXPAND21,PACK21,BUFFIN,BUFFOUT ACUMPS1.75
&, P21BITS,READDUMP,WRITDUMP,SETPERLEN GMG1F404.12
INTEGER P21BITS ACUMPS1.77
C ACUMPS1.78
C Cray specific functions UNIT,LENGTH ACUMPS1.79
C ACUMPS1.80
C Local variables ACUMPS1.81
C ACUMPS1.82
INTEGER ACUMPS1.83
& LEN_IO_IN, ACUMPS1.84
& LEN_IO_OUT, ACUMPS1.85
& IP1,IP2, ! I/O buffer indices (=1 or 2) ACUMPS1.86
& IPTS_IN,IPTS_OUT, ! No of 64-bit words requested to ACUMPS1.87
* ! be buffered in/out ACUMPS1.88
& ADDR,LREC, ! address and record length of field GSM1F403.105
& I,K, ! Loop indices GMG1F404.13
& PERIODLEN ! length of current meaning period GMG1F404.14
! in days GMG1F404.15
C ACUMPS1.90
REAL ACUMPS1.91
& A_IO_IN, ACUMPS1.92
& A_IO_OUT, GMG1F404.16
& REALPERIODLEN ! explicitly real equivalent GMG1F404.17
! of PERIODLEN GMG1F404.18
C ACUMPS1.94
C Local arrays ACUMPS1.95
C ACUMPS1.96
INTEGER ACUMPS1.97
& extraw ! no of extra words ACUMPS1.99
&, info ! Arg in call (not used) GKR1F402.188
REAL ACUMPS1.101
& D1_DATA(IBUFLEN) ! Work area for fields GSM2F405.36
* ! of real data ACUMPS1.105
&, D1_PSUM(LEN_DATA) ! Partial sum copy of D1 GKR1F402.189
&, D1_PSUM_DATA(IBUFLEN) ! GKR1F402.190
LOGICAL ACUMPS1.106
& TYPREAL ! True if data type is GSM2F405.37
! ! real ie. to be meaned GKR1F402.193
C ACUMPS1.109
IF(ICODE.NE.0)GOTO 999 ACUMPS1.110
C ACUMPS1.111
C Initialise pointers used for I/O buffers ACUMPS1.112
C ACUMPS1.113
IP1=1 ACUMPS1.114
IP2=2 ACUMPS1.115
! GMG1F404.19
! Set up variables needed for weighting accumulations if real-period GMG1F404.20
! climate meaning is selected. Partial sums are normalised elsewhere. GMG1F404.21
! GMG1F404.22
if (lclimrealyr) then GMG1F404.23
call setperlen(meanlev,i_month,i_year,periodlen) GMG1F404.24
realperiodlen=real(periodlen) GMG1F404.25
endif GMG1F404.26
CL ACUMPS1.116
CL********************************************************************** ACUMPS1.117
CL Start of loop over number of fields in data blocks ACUMPS1.118
CL********************************************************************** ACUMPS1.119
!L---------------------------------------------------------------------- GMG1F404.27
!L If partial sum data exist on disk (because this period has GMG1F404.28
!L already been started) then read in data from disk, otherwise get GMG1F404.29
!L data directly from D1 array. GMG1F404.30
!L---------------------------------------------------------------------- GMG1F404.31
GKR1F402.194
IF (FLAG.NE.1) THEN ! PS data exist on disk GMG1F404.32
GKR1F402.196
C Initialise D1 array to zero GSM1F403.106
GSM1F403.107
DO I = 1,LEN_DATA GSM1F403.108
D1_PSUM(I)=0.0 GSM1F403.109
ENDDO GSM1F403.110
! Call READDUMP without reading header to avoid overwriting GKR3F403.15
! header values associated with the current D1. GKR3F403.16
GKR3F403.17
CALL UM_READDUMP(NFTIN, FIXHD, LEN_FIXHD, GSM1F403.111
& INTHD, LEN_INTHD, GKR1F402.198
& REALHD, LEN_REALHD, GKR1F402.199
& LEVDEPC, LEN1_LEVDEPC, LEN2_LEVDEPC, GKR1F402.200
& ROWDEPC, LEN1_ROWDEPC, LEN2_ROWDEPC, GKR1F402.201
& COLDEPC, LEN1_COLDEPC, LEN2_COLDEPC, GKR1F402.202
& FLDDEPC, LEN1_FLDDEPC, LEN2_FLDDEPC, GKR1F402.203
& EXTCNST, LEN_EXTCNST, GKR1F402.204
& DUMPHIST, LEN_DUMPHIST, GKR1F402.205
& CFI1, LEN_CFI1, GKR1F402.206
& CFI2, LEN_CFI2, GKR1F402.207
& CFI3, LEN_CFI3, GKR1F402.208
& LOOKUP,LEN1_LOOKUP,LEN2_LOOKUP, GSM1F403.112
*IF DEF,MPP GSM1F403.113
& MPP_LOOKUP,MPP_LEN1_LOOKUP, GSM1F403.114
*ENDIF GKR1F402.214
& SUBM,N_OBJS_D1,D1_ADDR, GSM1F403.115
& LEN_DATA,D1_PSUM, GKR1F402.215
*CALL ARGPPX GDG0F401.44
& .FALSE.,ICODE,CMESSAGE) GKR3F403.18
GKR1F402.217
*IF DEF,MPP GKR1F402.218
! Broadcast return code to all processors. GKR1F402.219
CALL GC_IBCAST(678,1,0,nproc,info,icode) GKR1F402.220
IF (ICODE.GT.0) GOTO 999 GSM2F404.178
*ENDIF GKR1F402.221
GKR1F402.222
CL---------------------------------------------------------------------- ACUMPS1.165
CL Process data (real only) ACUMPS1.166
CL---------------------------------------------------------------------- ACUMPS1.167
CL ACUMPS1.168
GKR1F402.223
! Start of loop over number of fields in data blocks GKR1F402.224
GKR1F402.225
DO 100 K=1,FIXHD(152)+1 GKR1F402.226
IF(K.NE.1)THEN ACUMPS1.169
extraw=lookup(lbext,k-1) ACUMPS1.170
IF (extraw .eq. imdi) THEN ACUMPS1.171
extraw=0 ACUMPS1.172
ENDIF ACUMPS1.173
IF(LOOKUP(DATA_TYPE,K-1).EQ.1.OR.LOOKUP(DATA_TYPE,K-1).EQ.4 GKR1F402.227
* .OR.LOOKUP(DATA_TYPE,K-1).EQ.-1) THEN GKR1F402.228
TYPREAL=.TRUE. GKR1F402.229
ELSE GKR1F402.230
TYPREAL=.FALSE. GKR1F402.231
END IF GKR1F402.232
CL ACUMPS1.192
CL Accumulate required partial sum data (except missing data) ACUMPS1.193
CL (N.B. For period 1; D1 will contain instantaneous data ACUMPS1.194
CL For period>1; D1 will contain time-mean data) ACUMPS1.195
CL ACUMPS1.196
*IF DEF,MPP GSM1F403.116
LREC = MPP_LOOKUP(P_LBLREC,K-1) GSM1F403.117
ADDR = MPP_LOOKUP(P_NADDR,K-1) GSM1F403.118
*ELSE GSM1F403.119
LREC = LOOKUP(LBLREC,K-1) GSM1F403.120
ADDR = LOOKUP(NADDR,K-1) GSM1F403.121
*ENDIF GSM1F403.122
IF(TYPREAL) THEN GSM1F403.123
DO I=1,LREC-extraw GSM1F403.124
C Don't process extra data. ACUMPS1.198
D1_DATA(I)=D1(ADDR+I-1) GSM1F403.125
D1_PSUM_DATA(I)=D1_PSUM(ADDR+I-1) GSM1F403.126
IF ( D1_PSUM_DATA(I) .EQ .RMDI .OR. GSM1F403.127
& D1_DATA(I) .EQ .RMDI ) THEN GSM1F403.128
D1_PSUM(ADDR+I-1)=RMDI GSM1F403.129
ELSE ! add D1 data to partial sum data from disk GMG1F404.33
if (lclimrealyr) then ! weight partial sum by period GMG1F404.34
D1_PSUM(ADDR+I-1) = GMG1F404.35
& D1_PSUM_DATA(I) + (realperiodlen*D1_DATA(I)) GMG1F404.36
else GMG1F404.37
D1_PSUM(ADDR+I-1) = GMG1F404.38
& D1_PSUM_DATA(I) + D1_DATA(I) GMG1F404.39
endif GMG1F404.40
ENDIF GSM1F403.133
ENDDO GSM1F403.134
ELSE GSM1F403.135
C Just copy non-REAL data to D1_PSUM. So land sea mask is GSM1F403.136
C accessible when partial sum dump later reread in over D1 GSM1F403.137
DO I=1,LREC-extraw GSM1F403.138
D1_PSUM(ADDR+I-1) = D1(ADDR+I-1) GSM1F403.139
ENDDO GSM1F403.140
ENDIF GSM1F403.141
120 CONTINUE GKR1F402.248
C --------------------------------------------------------------------- GMG1F404.41
CL Copy the extra data from dump array to field data ACUMPS1.207
!L "Extra" data are integers & logicals; don't accumulate or normalise GMG1F404.42
C --------------------------------------------------------------------- GMG1F404.43
DO i=LREC-extraw+1,LREC GSM1F403.142
D1_PSUM(ADDR+I-1) = D1(ADDR+i-1) GSM1F403.143
ENDDO GKR1F402.252
ENDIF ! end of test on K.NE.1 GMG1F404.44
C ACUMPS1.215
100 CONTINUE GKR1F402.253
C GKR1F402.254
ELSE ! FLAG=1, e.g. run is only one period(N-1) into period(N) GMG1F404.45
CL ACUMPS1.217
CL---------------------------------------------------------------------- ACUMPS1.218
CL If partial sum data does not exist on disk: ACUMPS1.219
CL---------------------------------------------------------------------- ACUMPS1.220
CL ACUMPS1.221
CL Copy data across from D1 (real only) ACUMPS1.222
CL (N.B. For period 1; D1 will contain instantaneous data ACUMPS1.223
CL For period>1; D1 will contain time-mean data) ACUMPS1.224
CL ACUMPS1.225
DO 200 K=1,FIXHD(152)+1 GKR1F402.256
IF(K.NE.1)THEN ACUMPS1.226
*IF DEF,MPP GSM1F403.144
LREC = MPP_LOOKUP(P_LBLREC,K-1) GSM1F403.145
ADDR = MPP_LOOKUP(P_NADDR,K-1) GSM1F403.146
*ELSE GSM1F403.147
LREC = LOOKUP(LBLREC,K-1) GSM1F403.148
ADDR = LOOKUP(NADDR,K-1) GSM1F403.149
*ENDIF GSM1F403.150
IF (LCLIMREALYR) THEN ! only process real data GMG1F404.46
GMG1F404.47
IF(LOOKUP(DATA_TYPE,K-1).EQ.1.OR.LOOKUP(DATA_TYPE,K-1).EQ.4 GMG1F404.48
& .OR.LOOKUP(DATA_TYPE,K-1).EQ.-1) THEN ! data type=real GMG1F404.49
extraw=lookup(lbext,k-1) GMG1F404.50
IF (extraw .eq. imdi) THEN GMG1F404.51
extraw=0 GMG1F404.52
ENDIF GMG1F404.53
DO I=1,LREC-extraw GMG1F404.54
! do not multiply missing data GMG1F404.55
IF ( D1(ADDR+I-1) .EQ .RMDI ) THEN GMG1F404.56
D1_PSUM(ADDR+I-1)=RMDI GMG1F404.57
ELSE GMG1F404.58
D1_PSUM(ADDR+I-1) = realperiodlen*D1(ADDR+I-1) GMG1F404.59
ENDIF GMG1F404.60
ENDDO GMG1F404.61
GMG1F404.62
! Do not multiply extraw data eg gridpoints for timeseries GMG1F404.63
GMG1F404.64
IF (EXTRAW.GT.0) THEN GMG1F404.65
DO I=LREC-EXTRAW+1,LREC GMG1F404.66
D1_PSUM(ADDR+I-1)=D1(ADDR+I-1) GMG1F404.67
ENDDO GMG1F404.68
ENDIF GMG1F404.69
GMG1F404.70
ELSE ! non-real data GMG1F404.71
GMG1F404.72
! Copy data unchanged because it is non-real. No need to weight it. GMG1F404.73
DO I=1,LREC GMG1F404.74
D1_PSUM(ADDR+I-1) = D1(ADDR+I-1) GMG1F404.75
ENDDO GMG1F404.76
ENDIF ! end of test of whether data is real or not GMG1F404.77
GMG1F404.78
ELSE ! original code GMG1F404.79
CL Copy all fields because land sea mask is required by readdump and GSM1F403.151
CL reads it from this dump. If READDUMP changed so as to get LS mask GSM1F403.152
CL from elsewhere, the IF condition should be uncommented to only copy GSM1F403.153
CL real fields. GSM1F403.154
C IF(LOOKUP(DATA_TYPE,K-1).EQ.1.OR.LOOKUP(DATA_TYPE,K-1).EQ.4 GSM1F403.155
C * .OR.LOOKUP(DATA_TYPE,K-1).EQ.-1) THEN GSM1F403.156
DO 130 I=1,LREC GSM1F403.157
C In this case we do want to process extra data. ACUMPS1.230
D1_PSUM(ADDR+I-1) = D1(ADDR+I-1) GSM1F403.158
130 CONTINUE ACUMPS1.232
C ENDIF GSM1F403.159
GMG1F404.80
ENDIF ! end of test of lclimrealyr GMG1F404.81
ENDIF ACUMPS1.234
200 CONTINUE GKR1F402.259
GKR1F402.260
GKR1F402.261
C ACUMPS1.235
ENDIF ! end of test of FLAG GMG1F404.82
CL ACUMPS1.237
CL---------------------------------------------------------------------- ACUMPS1.238
CL Prepare partial sum data and write out to disk ACUMPS1.239
CL---------------------------------------------------------------------- ACUMPS1.240
CL ACUMPS1.241
C Maximum length of field, required for IO buffer GKR1F402.262
GKR1F402.263
IBUFLEN=LOOKUP(LBLREC,1) GKR1F402.264
IF (LEN2_LOOKUP.GT.1) THEN GKR1F402.265
DO I=2,LEN2_LOOKUP GKR1F402.266
IBUFLEN=MAX(IBUFLEN,LOOKUP(LBLREC,I)) GKR1F402.267
ENDDO GKR1F402.268
ENDIF ACUMPS1.260
GKR1F402.269
C IF (MEANLEV.GT.0) A_FIXHD(5)=2 ! Set FIXHD(5) for mean dump GKR1F402.270
GKR1F402.271
CALL UM_WRITDUMP(NFTOUT,FIXHD,LEN_FIXHD, GSM1F403.160
& INTHD,LEN_INTHD, GKR1F402.273
& REALHD,LEN_REALHD, GKR1F402.274
& LEVDEPC,LEN1_LEVDEPC,LEN2_LEVDEPC, GKR1F402.275
& ROWDEPC,LEN1_ROWDEPC,LEN2_ROWDEPC, GKR1F402.276
& COLDEPC,LEN1_COLDEPC,LEN2_COLDEPC, GKR1F402.277
& FLDDEPC,LEN1_FLDDEPC,LEN2_FLDDEPC, GKR1F402.278
& EXTCNST,LEN_EXTCNST, GKR1F402.279
& DUMPHIST,LEN_DUMPHIST, GKR1F402.280
& CFI1,LEN_CFI1, GKR1F402.281
& CFI2,LEN_CFI2, GKR1F402.282
& CFI3,LEN_CFI3, GKR1F402.283
& LOOKUP,LEN1_LOOKUP,LEN2_LOOKUP, GKR1F402.284
*IF DEF,MPP GSM1F403.161
& MPP_LOOKUP,MPP_LEN1_LOOKUP, GSM1F403.162
*ENDIF GSM1F403.163
& IBUFLEN,SUBM,N_OBJS_D1,D1_ADDR,LEN_DATA,D1_PSUM, GSM1F403.164
*CALL ARGPPX GDG0F401.47
& ICODE,CMESSAGE) GKR1F402.286
GKR1F402.287
*IF DEF,MPP GBC3F404.4
! Broadcast return code to all processors. GBC3F404.5
CALL GC_IBCAST(679,1,0,nproc,info,icode) GBC3F404.6
*ENDIF GBC3F404.7
IF (ICODE.GT.0) GOTO 999 GKR1F402.288
CL ACUMPS1.333
CL********************************************************************** ACUMPS1.334
CL End of loop over number of fields ACUMPS1.335
CL********************************************************************** ACUMPS1.336
CL ACUMPS1.337
999 CONTINUE ACUMPS1.338
RETURN ACUMPS1.339
END ACUMPS1.340
*ENDIF ACUMPS1.341