*ID GSM3F406
*/
*/ ***note*** needs mods for non-mpp use:
*/ references variables not defined unless mpp is set.
*/ this affects acumps and meanctl.
*/ See "WMC" at the end
*/ [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
*/
*/
*/
*/ Following code needs IFDEF MPP around it, as example above
*/
*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_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
*/
*ENDIF
*/
*/
*/
*/
*/ Now remove IFDEF MPP from comdeck STPARAM to prevent undef variables
*/ in acumps
*/
*DECLARE STPARAM
*D GPB1F402.611
*D GPB1F402.614
*/