head	1.1;
access;
symbols;
locks
	gcm:1.1; strict;
comment	@# @;


1.1
date	2002.03.25.11.30.49;	author gcm;	state Exp;
branches;
next	;


desc
@@


1.1
log
@Initial revision
@
text
@*ID GSM3F406
*/
*/ ***note*** not suitable for non-mpp use:
*/            references variables not defined unless mpp is set!
*/            [wmc 2002/03/04]
*/
*/ U.M. 4.6 unix / source code change form / header   version 08/12/98
*/Instructions: see http://fr0800/umdoc/hegui/t3e4.6.html#chgfinst
*/ 
*/ SOC: Climate meaning optimisation.
*/
*/ Reduces memory, disk and IO requirement of climate means system.
*/ This modset can be used in all configurations, 
*/ Does not support diagnostics from Sections 21-24 and 41-44 (CM1-4).
*/ However, these are rarely used, and can be duplicated. Also, does
*/ not support creation of meaned dumps (also rarely used).
*/ S.D.Mullerworth 22/01/99
*/
*/ Has an entry been lodged in the Problem Reporting System? [N]
*/
*/ THIS CODE IS INTENDED FOR INCLUSION IN THE 4.6 BUILD      [Y]
*/ .....................................................................
*/   Author[s]:-> Steve Mullerworth E-mail:-> sdmullerworth@@meto.gov.uk 
*/ Reviewer[s]:-> E-mail:-> @@meto.gov.uk
*/
*/    "I have checked this change. When provided, the advance design 
*/  specification was agreed and adequate, and the new code conforms to
*/  Unified Model standards."
*/
*/  DESIGN SPEC. WAS REVIEWED ON: ......      REVIEWER[S] SIGNATURES
*/                                            ----------------------
*/    DATE CODE REVIEWED: ......
*/  .....................................................................
*/ ANY REFERENCES TO EXTERNAL DOCUMENTS-> instead of design spec.
*/
*/  WILL CHANGES AFFECT ANCILLARY FILES?         [N]
*/  ARE ANY CHANGES TO STASHMASTER FILES NEEDED? [N] 
*/  USER INTERFACE ACTION REQUIRED?              [N]
*/ 
*/  TESTED IN CONFIGURATIONS:-> HadCM3,HadAM3,HadSM3
*/  TESTS RUN BY [PERSON]:-> S.D.Mullerworth
*/ 
*/  WILL THE CHANGES SLOW DOWN THE MODEL?        [N]
*/  -> Further details
*/  CHANGES WILL INCREASE MEMORY CONSUMPTION?    [N]   
*/  -> Further details
*/
*/ | Forecast dumps bit compare with those created without the change 
*/ V MARK [Y| ] BELOW; leave rest of lines untouched.
*/
*/   Control Code    loses bit comparison
*/   Atmosphere (assuming same science options chosen)   loses b.c.
*/   Ocean       loses bit comparison
*/   Wave        loses bit comparison
*/   Reconfiguration   loses bit comparison
*/   Diagnostics      lose bit comparison
*/ For Y2K compliance checking:  
*/ DOES THIS CHANGE INTERACT WITH DATE CALCULATIONS IN ANY WAY? [N]   
*/ 
*/  SECTIONS (TO BE) CHANGED:
*/
*/  SECTIONS (TO BE) DELETED? 
*/
*/  NEW SECTIONS?  Fill in form http://www-hc/~hadmk/STASHmaster_change.html,
*/  and give section numbers below:
*/  
*/  *DEFS ADDED OR REMOVED: 
*/ ......................................................................
*/                ADVANCE DESIGN SPECIFICATION (optional) 
*/ ->    
*//////////////////////////////////////////////////////////////////////// 
*DECLARE ACUMPS1
*D ACUMPS1.8
!LL    To accumulate partial sums of climate mean tagged diagnostics 
!LL    and create dumps containing them. Also to overwrite the D1
!LL    diagnostice with the partial sum for use by MEANPS. This 
!LL    saves MEANPS having to reread the partial sum dump.
*I GSM2F405.35    
!LL   4.6  14/01/99  Optimised to sum only tagged diagnostics.
!LL                  S.D.Mullerworth
*D GKR1F402.122,GDG0F401.39   
      SUBROUTINE ACUMPS(
     &  N_OBJS_D1,D1_ADDR
     &  ,LEN_DATA,D1,LD1,ID1
     &  ,MAXSIZE,MEANS_TOTAL
     &  ,FLAG,NFTIN,NFTOUT,LCLIMREALYR,MEANLEV
     &  ,I_MONTH,I_YEAR
     &  ,HEAD_OUT,HEAD_LEN,HEAD_SIZE,
     &  TIMESTEP,CMITEMS,FIXHD12,
*CALL ARGSTS
     &  ICODE,CMESSAGE)
*D GKR1F402.141,GSM1F403.100  
     &  N_OBJS_D1               !IN No objects in D1 array    
*D GKR1F402.161,GKR1F402.172  
     &  D1_ADDR(D1_LIST_LEN,N_OBJS_D1) !IN Addressing of D1 array
*D GKR1F402.174,GKR1F402.181  
*D ACUMPS1.46,GMG1F404.9    
     &  MAXSIZE,                ! IN dimension of largest data field
     &  LEN_DATA,               ! IN Length of model data
     &  FLAG,                   ! IN Flag for reading partial sum dump
     &  NFTIN,                  ! IN Unit no for reading partial sums
     &  NFTOUT,                 ! IN Unit no for writing partial sums
     &  ICODE,                  ! OUT Return code; successful=0       
     &                          !                  error>0            
     &  MEANLEV,                ! IN level of climate meaning
     &  MEANS_TOTAL,            ! IN Indicates a meaning period
     &  I_MONTH,                ! IN Current model time (months)
     &  I_YEAR,                 ! IN Current model time (years)
     &  FIXHD12                 ! IN Version of model
     &  ,CMITEMS                ! IN Number of items being meaned
     &  ,TIMESTEP               ! IN Submodel timestep
*D ACUMPS1.60
     &  ID1(LEN_DATA)           ! IN/OUT Integer equiv. of data block.
                                !        Overwritten with partial sums.
*D ACUMPS1.63
     &  D1(LEN_DATA)            ! IN/OUT Real equivalence of data block
*D GMG1F404.10,GMG1F404.11   
     &  LD1(LEN_DATA),          ! IN/OUT Logical equiv. of data block
     &  LCLIMREALYR             ! IN Real-period climate meaning
*D GDG0F401.41,GDG0F401.42   
*CALL TYPSIZE
*CALL TYPSTS
*CALL STPARAM
*I GKR1F402.185   
      INTEGER
     &  HEAD_LEN
     &  ,HEAD_SIZE

      INTEGER
     &  HEAD_OUT(HEAD_LEN,TOTITEMS) ! IN Header contains packing 
                                !    info for output ps file
     &  ,HEAD_BUF(HEAD_SIZE)

! Header formatted as follows:
! HEAD_OUT(1,*): No of words per level in field
! HEAD_OUT(2,*): 2 for packed, 1 for unpacked
! HEAD_OUT(3,*): No of words per level on disk

! Align for well-formed io
cdir$ cache_align head_buf

*D ACUMPS1.75,GMG1F404.12   
      EXTERNAL EXPAND32B,PACK21,BUFFIN,BUFFOUT
     &,        P21BITS,SETPERLEN
*D ACUMPS1.84,GMG1F404.15   
     &  I,J,K                   ! Loop indices
     &  ,LEN_IO                 ! Actual IO length
     &  ,CITEMS                 ! Count variable
     &  ,PERIODLEN              ! Current meaning period in days
     &  ,TAG                    ! Stash tag
     &  ,PTD1                   ! Pointer to D1_ADDR information
     &  ,address                ! Address in local D1
     &  ,levels                 ! Number of levels per diagnostic
     &  ,length                 ! Length of each level in local D1
     &  ,global_length          ! Length of global field
     &  ,offset                 ! Indexing offset for WORK array
*I ACUMPS1.90    
      INTEGER
     &  HEADER(2)               ! Initial header
     &  ,HEAD_IN(HEAD_LEN,CMITEMS) ! Packing info for input ps file
                                ! Will differ from HEAD_OUT if packing
                                ! codes have changed mid-run

*D ACUMPS1.92,GMG1F404.18   
     &  IOSTAT,                 ! IO error code
     &  REALPERIODLEN           ! explicitly real equivalent
                                ! of PERIODLEN
*D ACUMPS1.97,GKR1F402.188  
*D GSM2F405.36,GKR1F402.193  
     &  D1_DATA(MAXSIZE)        ! Work area for fields
      REAL
     &  WORK(MAXSIZE+4)        ! Work area and IO buffer

! Align for well-formed io
cdir$ cache_align work

*D ACUMPS1.111,GMG1F404.19   

! Arrays sent to BUFFIN/BUFFOUT need to be cache aligned for 
! well-formed io to work, but the cache_align directive wasn't working 
! correctly for WORK. The following adds an offset to the index of 
! WORK which resolves the problem. 
      i=loc(work)
! This is an offset from 0, so an offset of 1 really means no offset!
      offset=1
      IF (MOD(i,32).NE.0)THEN
! Buffers must start on 32-byte boundary. If the WORK array does not
! start on a 32-byte boundary, then add an offset to the index so that
! the first element of WORK passed to the buffer routines *is* on a
! boundary
        offset=1+((i/32)*32+32-i)/8
      ENDIF

*D GMG1F404.22

*D ACUMPS1.116,GMG1F404.31   
*D GMG1F404.32
! STEP 1: Read in headers of previous partial sum and write out
!         header of new.
*D GSM1F403.106
      IF (FLAG.NE.1) THEN       ! PS data exist on disk
! Read headers for input partial sum file
        CALL BUFFIN(NFTIN,HEAD_BUF,HEAD_SIZE,LEN_IO,IOSTAT)
        IF(IOSTAT.NE.-1.0.OR.LEN_IO.NE.HEAD_SIZE)THEN
          WRITE(6,*)'ACUMPS: Error reading header: IO code ',
     &      IOSTAT,' on unit ',NFTIN
          WRITE(6,*)'Words requested ',HEAD_SIZE,
     &      ' Words read ',LEN_IO
          ICODE=1
          CMESSAGE='ACUMPS: BUFFIN error - see output'
          GOTO 999
        ENDIF
! Transfer header information from buffer to header arrays
        HEADER(1)=HEAD_BUF(1) ! Timestep of creation
        HEADER(2)=HEAD_BUF(2) ! Number of records
        K=3
        DO I=1,CMITEMS
          DO J=1,HEAD_LEN
            HEAD_IN(J,I)=HEAD_BUF(K)
            K=K+1
          ENDDO
        ENDDO
*D GSM1F403.108,GSM1F403.109  
        IF (HEADER(1).GE.TIMESTEP.OR.HEADER(2).NE.CMITEMS)THEN
          WRITE(6,*)'ACUMPS1: Partial sum file inconsistent'
          WRITE(6,*)'PS file holds ',HEADER(2),' items and written 
     &      at STEP ',HEADER(1)
          WRITE(6,*)'Expected timestep should be < ',TIMESTEP
          WRITE(6,*)'Expected number of items ',CMITEMS
          CMESSAGE='ACUMPS1: Partial sum file inconsistent. See Output'
          ICODE=2
          GOTO 999
        ENDIF
      ELSE
! No input sum, so initialise header array
        DO I=1,HEAD_SIZE
          HEAD_BUF(I)=0
*D GKR3F403.15,GKR3F403.16   
      ENDIF
*D GSM1F403.111,GSM1F403.112  
! Write headers for new partial sum file
! Transfer information to io buffer
      HEAD_BUF(1)=TIMESTEP
      HEAD_BUF(2)=CMITEMS
      K=3
      DO I=1,CMITEMS
        DO J=1,HEAD_LEN
          HEAD_BUF(K)=HEAD_OUT(J,I)
          K=K+1
        ENDDO
      ENDDO
      CALL BUFFOUT(NFTOUT,HEAD_BUF,HEAD_SIZE,LEN_IO,IOSTAT)
      IF(IOSTAT.NE.-1.0.OR.LEN_IO.NE.HEAD_SIZE)THEN
        WRITE(6,*)'ACUMPS: Error writing header: IO code ',
     &    IOSTAT,' on unit ',NFTOUT
        WRITE(6,*)'Words requested ',HEAD_SIZE,
     &    ' Words written ',LEN_IO
        ICODE=4
        CMESSAGE='ACUMPS: BUFFOUT error - see output'
        GOTO 999
      ENDIF

! STEP 2 : Loop over all STASH items. For each tagged item, gather
!          current data to D1_DATA array, read partial sum into WORK
!          array (if there is a partial sum), sum the two and write
!          out to new partial sum file. 
!           Also, if this is a meaning period, overwrite the field
!          in D1 with the complete sum, to be picked up by MEANPS.

!     Start of loop over STASH items
      CITEMS=0
      DO K=1,TOTITEMS
        TAG=STLIST(st_macrotag,K)/1000
        PTD1=STLIST(st_d1pos,K)
        IF(TAG.NE.0.AND.STLIST(s_modl,k).eq.D1_ADDR(d1_imodl,PTD1))THEN
! Object tagged for climate meaning and in relevant internal model
          address=D1_ADDR(d1_address,PTD1)
          levels=D1_ADDR(d1_no_levels,PTD1)
          length=D1_ADDR(d1_length,PTD1)/levels
          global_length=STLIST(st_dump_level_output_length,K)
          CITEMS=CITEMS+1
          DO J=1,levels
! Copy current field from D1 to D1_DATA
*D GSM1F403.114
! by gathering full field to pe0
            CALL GENERAL_GATHER_FIELD(
     &        D1(address),D1_DATA,length,
     &        global_length,
     &        D1_ADDR(1,PTD1),0,
     &        ICODE,CMESSAGE)
            IF(ICODE.NE.0)GOTO 999
*ELSE
            DO I=1,global_length
              D1_DATA(I)=D1(address+I-1)
            ENDDO
*D GSM1F403.115,GKR3F403.18   
            DO I=global_length+1,MAXSIZE
              D1_DATA(I)=0.
            ENDDO
! If partial sum exists on disk, read it in and add to current field
            IF (FLAG.NE.1) THEN ! PS data exist on disk
! Read in one level of partial sum field
              CALL BUFFIN(NFTIN,WORK(offset),HEAD_IN(3,CITEMS)
     &          ,LEN_IO,IOSTAT)
              IF(IOSTAT.NE.-1.0.OR.LEN_IO.NE.HEAD_IN(3,CITEMS))THEN
                WRITE(6,*)'ACUMPS: Error reading partial sum IO code ',
     &            IOSTAT,' on unit ',NFTIN
                WRITE(6,*)'Words requested ',HEAD_IN(3,CITEMS),
     &            ' Words read ',LEN_IO
                ICODE=6
                CMESSAGE='ACUMPS: BUFFIN error - see output'
                GOTO 999
              ENDIF
*IF DEF,MPP
              IF (mype.eq.0) THEN
! Valid data exists on pe0 only
*ENDIF
! Unpack if data on disk was packed
                IF (HEAD_IN(2,CITEMS).EQ.2)THEN
                  CALL EXPAND32B(GLOBAL_LENGTH,WORK(offset),FIXHD12)
                ENDIF
! Sum with field in D1 - Scale data if 365 day calendar
                IF (LCLIMREALYR)THEN
                  DO I=1,global_length
                    IF (WORK(I+offset-1).eq.RMDI)THEN
                      D1_DATA(I)=RMDI
                    ELSE
                      D1_DATA(I)=WORK(I+offset-1)+
     &                  (realperiodlen*D1_DATA(I))
                    ENDIF
                  END DO
                ELSE
! 360 day calendar
                  DO I=1,global_length
                    IF (WORK(I+offset-1).eq.RMDI)THEN
                      D1_DATA(I)=RMDI
                    ELSE
                      D1_DATA(I)=WORK(I+offset-1)+D1_DATA(I)
                    ENDIF
                  END DO
                ENDIF
*IF DEF,MPP
              ENDIF
*ENDIF
            ELSE
! First data for this period - no partial sum to add
              IF (LCLIMREALYR)THEN
! Scale initial data if 365 day calendar
*IF DEF,MPP
                IF (mype.eq.0) THEN
*ENDIF
                  DO I=1,global_length
                    IF (D1_DATA(I).ne.RMDI)THEN
                      D1_DATA(I)=realperiodlen*D1_DATA(I)
                    ENDIF
                  END DO
*IF DEF,MPP
                ENDIF
*ENDIF
              ENDIF
            ENDIF ! End of adding PS data
*I GKR1F402.217   
!         Write out sum to PS file
*D GKR1F402.219,GSM2F404.178  
            IF (mype.eq.0) THEN
*I GKR1F402.221   
! Copy data to WORK array, packing if necessary
              IF (HEAD_OUT(2,CITEMS).EQ.2)THEN
                DO I=HEAD_OUT(1,CITEMS),MAXSIZE
                  WORK(I+offset-1)=0.
                ENDDO
                CALL PACK21(GLOBAL_LENGTH,D1_DATA,
     &            WORK(offset),P21BITS(FIXHD12))
              ELSE
                DO I=1,GLOBAL_LENGTH
                  WORK(I+offset-1)=D1_DATA(I)
                ENDDO
              ENDIF
*IF DEF,MPP
            ENDIF
*ENDIF
! Output partial sum to file
            CALL BUFFOUT(NFTOUT,WORK(offset),
     &        HEAD_OUT(3,CITEMS),LEN_IO,IOSTAT)
            IF(IOSTAT.NE.-1.0.OR.LEN_IO.NE.HEAD_OUT(3,CITEMS))THEN
              WRITE(6,*)'ACUMPS: Error writing partial sum. Code ',
     &          IOSTAT,' on unit ',NFTOUT
              WRITE(6,*)'Words requested ',HEAD_OUT(3,CITEMS),
     &          ' Words written ',LEN_IO
              ICODE=7
              CMESSAGE='ACUMPS: BUFFOUT error - see output'
              GOTO 999
            ENDIF
            IF (MEANS_TOTAL.NE.0)THEN
! Overwrite field in D1 with partial sum for use by MEANPS
*IF DEF,MPP
              IF (mype.eq.0)then
! Pack and unpack for bit comparison with old system
                IF (HEAD_OUT(2,CITEMS).EQ.2)THEN
                  DO I=1,HEAD_OUT(1,CITEMS)
                    D1_DATA(I)=WORK(I+offset-1)
                  ENDDO
                  CALL EXPAND32B(GLOBAL_LENGTH,D1_DATA,FIXHD12)
                ENDIF
              ENDIF
              CALL GENERAL_SCATTER_FIELD(
     &          D1(address),D1_DATA,LENGTH,global_length,
     &          D1_ADDR(1,PTD1),0,ICODE,CMESSAGE)
              IF(ICODE.NE.0)GOTO 999
*ELSE
              DO I=1,global_length
                D1(address+I-1)=D1_DATA(I)
              ENDDO
*ENDIF
            ENDIF
            address=address + length ! Point to next level
          ENDDO                 ! End loop over levels
        ENDIF                   ! End tagged for meaning
      END DO                    ! End of loop over STASH list
*D ACUMPS1.165,ACUMPS1.337  
*I ACUMPS1.341   



*DC MEANPS1
*D MEANPS1.8
!LL    To mean partial sums. Sums obtained from the D1 array, put there
!LL    by ACUMPS.
*I MEANPS1.18    
!LL   4.6  14/01/99  Optimised to mean only tagged diagnostics, and
!LL                  to get data from D1 rather than from dump.
!LL                  S.D.Mullerworth
*D GKR1F402.291,GDG0F401.876  
      SUBROUTINE MEANPS( 
     &  N_OBJS_D1,D1_ADDR
     &  ,LEN_DATA,D1,LD1,ID1,
*CALL ARGSTS
     &  MEANING_PERIOD
     &  )
*D GKR1F402.310,GSM1F403.224  
     &  N_OBJS_D1
*D GKR1F402.330,GKR1F402.341  
     &  D1_ADDR(D1_LIST_LEN,N_OBJS_D1)
*D GKR1F402.343,GKR1F402.350  
*D MEANPS1.44,MEANPS1.53   
     &  LEN_DATA,               ! IN Length of model data
     &  MEANING_PERIOD          ! IN Meaning period (in multiples
     &                          !             of restart frequency)
*D MEANPS1.58
     &  ID1(LEN_DATA)           ! IN Integer equivalence of data block
*D MEANPS1.61
     &  D1(LEN_DATA)            ! IN/OUT Real equivalence of data block
                                !    containing meaned fields
*D MEANPS1.64
     &  LD1(LEN_DATA)           ! IN Logical equivalence of data block
*D MEANPS1.68
*D GDG0F401.878,GKR1F402.353  
*CALL TYPSIZE
*CALL TYPSTS
*CALL STPARAM
*D MEANPS1.72,MEANPS1.74   
*D MEANPS1.82,GSM1F403.229  
     &  J,K                     ! Loop indices
     &  ,TAG                    ! Climate mean tag
     &  ,ADDRESS
     &  ,PTD1
*D MEANPS1.90,GKR1F402.356  
     &  FACTOR                  ! Meaning period (real)
     &  ,RFACTOR                 ! Reciprocal of FACTOR
*D MEANPS1.93,MEANPS1.99   

*D MEANPS1.105,MEANPS1.107  


! Calculate divisor
*D MEANPS1.111,MEANPS1.119  
*D GSM1F403.230,GKR3F403.24   
!----------------------------------------------------------------------
!     Loop through STASH list and process climate mean fields
!     NOTE: D1 contains partial sums put there by preceding ACUMPS call
!----------------------------------------------------------------------
*D GKR1F402.381,GKR1F402.384  
      DO K=1,TOTITEMS
        TAG=STLIST(st_macrotag,K)/1000
        PTD1=STLIST(st_d1pos,K)
        IF(TAG.NE.0.AND.STLIST(s_modl,k).eq.D1_ADDR(d1_imodl,PTD1))THEN
! Object is tagged for climate meaning and in relevant internal model
          ADDRESS=D1_ADDR(d1_address,PTD1) ! local address
! Divide whole field by FACTOR - except for RMDI
          DO J=ADDRESS,ADDRESS+D1_ADDR(d1_length,PTD1)-1
            IF (D1(J).NE.RMDI)THEN
              D1(J)=D1(J)*RFACTOR
            ENDIF
          ENDDO
        ENDIF
      ENDDO
*D MEANPS1.157,GKR1F402.386  
!**********************************************************************
!     End of loop over STASH list
!**********************************************************************
*D MEANPS1.161,MEANPS1.233  
*DC MEANCTL1
*I GMB1F405.402   
!LL  4.6  14/01/99  Optimised to mean only tagged diagnostics
!LL                 S.D.Mullerworth
*I @@DYALLOC.2269  
*CALL CLOOKADD
*I GSS1F305.933   
*CALL CNTL_IO
*I MEANCTL1.29    
     &  HEAD_LEN                ! Length of each record in header
     &  ,HEAD_SIZE              ! Size of header on disk

      PARAMETER(
     &  HEAD_LEN=3
     &  )

      INTEGER
     &  HEAD_OUT(HEAD_LEN,TOTITEMS) ! Header info for output ps file

      INTEGER
*I GMG1F404.136   
     &       ,orig_decomp         ! Used to check for change in
     &       ,new_decomp          ! decomposition
     &       ,TAG                 ! Stash tag
     &       ,PTD1                ! Pointer to D1_ADDR information
     &       ,MODNUM              ! Pointer to D1_ADDR submodel
     &       ,PTL                 ! Pointer to LOOKUP information
     &       ,global_length       ! Length of global field
     &       ,CITEMS              ! Counter for no of objects to mean

*D GPB2F405.80
*D GPB2F405.84,GPB2F405.88   
     &  IE                      ! loop counter over items
     &  , tag                   ! indicates if this field is meaned
     &  , maxsize               ! maximum dump output length
     &  ,lmaxsize               ! Maximum output length per level
     &  ,totsize                ! Size required for partial sum dumps
     &  ,levsize                ! Size of each level
*I GKR1F404.292   
*CALL DECOMPTP
*I MEANCTL1.313   

! Create header for partial sum file
*IF DEF,ATMOS
      IF(IND_IM.EQ.1)THEN
! Set pointer to submodel info in D1_ADDR
        MODNUM=SUBMODEL_FOR_SM(IND_IM)
        CITEMS=0
        DO IE=1,TOTITEMS
          TAG=STLIST(st_macrotag,IE)/1000
! Get pointer to element in D1_ADDR array
          PTD1=STLIST(st_d1pos,IE)
          IF(tag.NE.0.AND.
     &      STLIST(s_modl,IE).eq.D1_ADDR(d1_imodl,PTD1,MODNUM))THEN
! Tagged for meaning and submodel information matches.
! Counter for no of variables that will be processed
            CITEMS=CITEMS+1
            PTL=D1_ADDR(d1_lookup_ptr,PTD1,MODNUM)
            global_length=STLIST(st_dump_level_output_length,IE)
            HEAD_OUT(1,CITEMS)=GLOBAL_LENGTH
            HEAD_OUT(2,CITEMS)=1
            HEAD_OUT(3,CITEMS)=(((GLOBAL_LENGTH+um_sector_size)
     &        /um_sector_size)*um_sector_size)
            IF(MOD((A_LOOKUP(LBPACK,PTL)),10) .EQ. 2) THEN
              IF(A_LOOKUP(DATA_TYPE,PTL) .EQ. 1) THEN
! Data to be packed so reduce data length accordingly
                GLOBAL_LENGTH=(GLOBAL_LENGTH+1)/2
                HEAD_OUT(1,CITEMS)=GLOBAL_LENGTH
                HEAD_OUT(2,CITEMS)=2
                HEAD_OUT(3,CITEMS)=(((GLOBAL_LENGTH+um_sector_size)
     &            /um_sector_size)*um_sector_size)
              ENDIF
            ENDIF
          ENDIF
        ENDDO
      ENDIF
*ENDIF
*IF DEF,OCEAN
      IF(IND_IM.EQ.2)THEN
! Set pointer to submodel info in D1_ADDR
        MODNUM=SUBMODEL_FOR_SM(IND_IM)
        CITEMS=0
        DO IE=1,TOTITEMS
          TAG=STLIST(st_macrotag,IE)/1000
! Get pointer to element in D1_ADDR array
          PTD1=STLIST(st_d1pos,IE)
          IF(tag.NE.0.AND.
     &      STLIST(s_modl,IE).eq.D1_ADDR(d1_imodl,PTD1,MODNUM))THEN
! Tagged for meaning and submodel information matches.
! Counter for no of variables that will be processed
            CITEMS=CITEMS+1
            PTL=D1_ADDR(d1_lookup_ptr,PTD1,MODNUM)
            global_length=STLIST(st_dump_level_output_length,IE)
            HEAD_OUT(1,CITEMS)=GLOBAL_LENGTH
            HEAD_OUT(2,CITEMS)=1
            HEAD_OUT(3,CITEMS)=(((GLOBAL_LENGTH+um_sector_size)
     &        /um_sector_size)*um_sector_size)
            IF(MOD((O_LOOKUP(LBPACK,PTL)),10) .EQ. 2) THEN
              IF(O_LOOKUP(DATA_TYPE,PTL) .EQ. 1) THEN
! Data to be packed so reduce data length accordingly
                GLOBAL_LENGTH=(GLOBAL_LENGTH+1)/2
                HEAD_OUT(1,CITEMS)=GLOBAL_LENGTH
                HEAD_OUT(2,CITEMS)=2
                HEAD_OUT(3,CITEMS)=(((GLOBAL_LENGTH+um_sector_size)
     &            /um_sector_size)*um_sector_size)
              ENDIF
            ENDIF
          ENDIF
        ENDDO
      ENDIF
*ENDIF

! Find the largest output field size to dimension I/O buffer array
! and the total size of storage required to set file size
      IF(IND_IM.EQ.1.OR.IND_IM.EQ.2)THEN
        lmaxsize=1
        head_size=CITEMS*HEAD_LEN+UM_SECTOR_SIZE+2
        head_size=(head_size/UM_SECTOR_SIZE)*UM_SECTOR_SIZE
        totsize=head_size
        CITEMS=0

        DO IE=1,TOTITEMS
          tag=STLIST(st_macrotag,IE)/1000
! Get pointer to element in D1_ADDR array
          PTD1=STLIST(st_d1pos,IE)
          IF(tag.NE.0.AND.
     &      STLIST(s_modl,IE).eq.D1_ADDR(d1_imodl,PTD1,MODNUM))THEN
! Tagged for meaning and submodel information matches.
            CITEMS=CITEMS+1
            lmaxsize=max(lmaxsize,
     &        STLIST(st_dump_level_output_length,IE))
            totsize=totsize+
     &        HEAD_OUT(3,CITEMS)*D1_ADDR(d1_no_levels,PTD1,MODNUM)
          ENDIF
        ENDDO
        lmaxsize=((lmaxsize+UM_SECTOR_SIZE)/UM_SECTOR_SIZE)
     &    *UM_SECTOR_SIZE
      ENDIF

*I MEANCTL1.339   
*IF DEF,MPP

        orig_decomp=current_decomp_type
        new_decomp=orig_decomp 

        IF (IND_IM.EQ.1.AND.orig_decomp.NE.decomp_standard_atmos)THEN
          new_decomp=decomp_standard_atmos
        ELSEIF (IND_IM.EQ.2.AND.orig_decomp.NE.decomp_nowrap_ocean)THEN
          new_decomp=decomp_nowrap_ocean
        ENDIF
        IF (new_decomp .NE. orig_decomp) THEN 
          CALL CHANGE_DECOMPOSITION(new_decomp,icode)
          IF (ICODE.NE.0)THEN
            WRITE(6,*)'ERROR : MEANCTL'
            WRITE(6,*)'Failed to change decomposition to ',new_decomp
            CMESSAGE='MEANCTL1: Failed to change decomposition'
            GOTO 999
          ENDIF
        ENDIF
*ENDIF
        IF(MEANS_TOTAL.GT.0)THEN
CL
CL                 STEP 1
CL     Copy instantaneous dump to SSD
CL
CL Strictly, only climate mean tagged diagnostics need to be saved.

! Compute the maximum length for the FT_SSD File
          maximum_file_length=0
*IF DEF,ATMOS
          maximum_file_length=max(maximum_file_length,
     2      a_len_data+(p_levels+1)*p_field)
*ENDIF
*IF DEF,OCEAN
          maximum_file_length=max(maximum_file_length,
     2      o_len_data)
*ENDIF
! Set the length of the file needed
          call set_dumpfile_length(ft_ssd, maximum_file_length)
c
*IF DEF,ATMOS
          IF(IND_IM.EQ.1)THEN
            CALL TRANSOUT(
*CALL ARGD1
     &        A_LEN_DATA+(P_LEVELS+1)*P_FIELD,FT_SSD,IND_IM
     &        ,ICODE,CMESSAGE)
          ENDIF
*ENDIF
*IF DEF,OCEAN
          IF(IND_IM.EQ.2)THEN
            CALL TRANSOUT(
*CALL ARGD1
     &        O_LEN_DATA,FT_SSD,IND_IM
     &        ,ICODE,CMESSAGE)
          ENDIF
*ENDIF

!      Check return code from TRANSOUT
          IF(ICODE.NE.0)THEN
            RUN_MEANCTL_RESTART=1
            WRITE(6,*) 'MEANCTL: RESTART AT PERIOD_',RUN_MEANCTL_RESTART
            GOTO 999
          ENDIF

          CALL FILE_CLOSE(FT_SSD,FT_ENVIRON(FT_SSD),
     &      LEN_FT_ENVIR(FT_SSD),0,0,ICODE)

        ENDIF
C
*D GBC6F404.99,GBC6F404.118  
*D GBC6F404.120,GBC6F404.121  
        call set_dumpfile_length(ft_read , totsize)
        call set_dumpfile_length(ft_write, totsize)
*D GKR1F402.2,GDG0F401.838  
          CALL ACUMPS(
     &  NO_OBJ_D1(D1_ADDR_SUBMODEL_ID),
     &  D1_ADDR(1,1,D1_ADDR_SUBMODEL_ID),
     &  A_LEN_DATA,D1,D1,D1,
     &  LMAXSIZE,MEANS_TOTAL,
     &  PS_FLAG(1),FT_READ,FT_WRITE,LCLIMREALYR,MEANLEV,
     &  I_MONTH,I_YEAR,
     &  HEAD_OUT,HEAD_LEN,HEAD_SIZE,
     &  STEPim(IND_IM),CITEMS,A_FIXHD(12),
*CALL ARGSTS
     &  ICODE,CMESSAGE)
*D GKR1F402.22,GDG0F401.844  
          CALL ACUMPS(
     &  NO_OBJ_D1(D1_ADDR_SUBMODEL_ID),
     &  D1_ADDR(1,1,D1_ADDR_SUBMODEL_ID),
     &  O_LEN_DATA,D1,D1,D1,
     &  LMAXSIZE,MEANS_TOTAL,
     &  PS_FLAG(1),FT_READ,FT_WRITE,LCLIMREALYR,MEANLEV,
     &  I_MONTH,I_YEAR,
     &  HEAD_OUT,HEAD_LEN,HEAD_SIZE,
     &  STEPim(IND_IM),CITEMS,O_FIXHD(12),
*CALL ARGSTS
     &  ICODE,CMESSAGE)
*D MEANCTL1.402,MEANCTL1.434  
*D GBC6F404.139,GBC6F404.145  
*D GBC6F404.147
            call set_dumpfile_length(ft_read , totsize)
*D GKR1F402.42,GMG1F404.235  
          CALL MEANPS(
     &          NO_OBJ_D1(D1_ADDR_SUBMODEL_ID),
     &          D1_ADDR(1,1,D1_ADDR_SUBMODEL_ID),
     &          A_LEN_DATA,D1,D1,D1,
*CALL ARGSTS
     &          PERIODLENDM
     &          )               
*D GMG1F404.237,GDG0F401.850  
              CALL MEANPS(
     &          NO_OBJ_D1(D1_ADDR_SUBMODEL_ID),
     &          D1_ADDR(1,1,D1_ADDR_SUBMODEL_ID),
     &          A_LEN_DATA,D1,D1,D1,
*CALL ARGSTS
     &          MEANFREQim(MEANLEV,IND_IM)
     &          )
*D GBC6F404.150,GBC6F404.156  
*D GBC6F404.158
            call set_dumpfile_length(ft_read , totsize)
*D GKR1F402.61,GMG1F404.261  
          CALL MEANPS(
     &          NO_OBJ_D1(D1_ADDR_SUBMODEL_ID),
     &          D1_ADDR(1,1,D1_ADDR_SUBMODEL_ID),
     &          O_LEN_DATA,D1,D1,D1,
*CALL ARGSTS
     &          PERIODLENDM
     &          )
*D GMG1F404.263,GDG0F401.856  
              CALL MEANPS(
     &          NO_OBJ_D1(D1_ADDR_SUBMODEL_ID),
     &          D1_ADDR(1,1,D1_ADDR_SUBMODEL_ID),
     &          O_LEN_DATA,D1,D1,D1,
*CALL ARGSTS
     &          MEANFREQim(MEANLEV,IND_IM)
     &          )
*D GBC6F404.161,GBC6F404.167  
*D GBC6F404.169
              call set_dumpfile_length(ft_read , totsize)
*D GBC6F404.172,GBC6F404.179  
*D GBC6F404.181
              call set_dumpfile_length(ft_write, totsize)
*D GKR1F402.80,GDG0F401.862  
          CALL ACUMPS(
     &  NO_OBJ_D1(D1_ADDR_SUBMODEL_ID),
     &  D1_ADDR(1,1,D1_ADDR_SUBMODEL_ID),
     &  A_LEN_DATA,D1,D1,D1,
     &  LMAXSIZE,MEANS_TOTAL,
     &  PS_FLAG(MEANLEV+1),FT_READ,FT_WRITE,
     &  LCLIMREALYR,MEANLEV,I_MONTH,I_YEAR,
     &  HEAD_OUT,HEAD_LEN,HEAD_SIZE,
     &  STEPim(IND_IM),CITEMS,A_FIXHD(12),
*CALL ARGSTS
     &  ICODE,CMESSAGE)
*D GBC6F404.184,GBC6F404.190  
*D GBC6F404.192
              call set_dumpfile_length(ft_read , totsize)
*D GBC6F404.195,GBC6F404.202  
*D GBC6F404.204
              call set_dumpfile_length(ft_write, totsize)
*D GKR1F402.100,GDG0F401.868  
          CALL ACUMPS(
     &  NO_OBJ_D1(D1_ADDR_SUBMODEL_ID),
     &  D1_ADDR(1,1,D1_ADDR_SUBMODEL_ID),
     &  O_LEN_DATA,D1,D1,D1,
     &  LMAXSIZE,MEANS_TOTAL,
     &  PS_FLAG(MEANLEV+1),FT_READ,FT_WRITE,
     &  LCLIMREALYR,MEANLEV,I_MONTH,I_YEAR,
     &  HEAD_OUT,HEAD_LEN,HEAD_SIZE,
     &  STEPim(IND_IM),CITEMS,O_FIXHD(12),
*CALL ARGSTS
     &  ICODE,CMESSAGE) 
*D MEANCTL1.729


      orig_decomp=current_decomp_type
      new_decomp=orig_decomp 
      IF (IND_IM.EQ.1.AND.orig_decomp.NE.decomp_standard_atmos)THEN
        new_decomp=decomp_standard_atmos
      ELSEIF (IND_IM.EQ.2.AND.orig_decomp.NE.decomp_standard_ocean)THEN
        new_decomp=decomp_standard_ocean
      ENDIF
      IF (new_decomp .NE. orig_decomp) THEN 
        CALL CHANGE_DECOMPOSITION(new_decomp,icode)
        IF (ICODE.NE.0)THEN
          WRITE(6,*)'ERROR : MEANCTL'
          WRITE(6,*)'Failed to change decomposition to ',new_decomp
          CMESSAGE='MEANCTL1: Failed to change decomposition'
        ENDIF
      ENDIF
@
