SUBROUTINE DUMPCTL ( 26,23@DYALLOC.861
*CALL ARGSIZE 
@DYALLOC.862
*CALL ARGD1 @DYALLOC.863
*CALL ARGDUMA @DYALLOC.864
*CALL ARGDUMO @DYALLOC.865
*CALL ARGDUMW WRB1F401.80
*CALL ARGCONA @DYALLOC.866
*CALL ARGPTRA @DYALLOC.867
*CALL ARGSTS @DYALLOC.868
*CALL ARGPPX GDG0F401.597
& I_AO,MEANLEV,lwritd1,tmpfname,writestep,ICODE,CMESSAGE) GKR4F403.3
C DUMPCTL1.31
IMPLICIT NONE DUMPCTL1.32
@DYALLOC.870
C*L Arguments @DYALLOC.871
*CALL CMAXSIZE @DYALLOC.872
*CALL CSUBMODL GSS1F305.924
*CALL TYPSIZE @DYALLOC.879
*CALL NSTYPES ABX1F404.130
*CALL TYPD1 @DYALLOC.883
*CALL TYPDUMA @DYALLOC.885
*CALL TYPDUMO @DYALLOC.886
*CALL TYPDUMW WRB1F401.81
*CALL TYPCONA @DYALLOC.888
*CALL TYPPTRA @DYALLOC.890
*CALL TYPSTS @DYALLOC.892
*CALL PPXLOOK GDG0F401.598
C DUMPCTL1.33
INTEGER I_AO ! IN - Atmosphere/Ocean indicator DUMPCTL1.34
INTEGER MEANLEV ! IN - Mean period level for dump DUMPCTL1.35
INTEGER writestep ! IN - Timestep on which to write it GKR4F403.4
CHARACTER*14 tmpfname ! IN - Name of file to be written GKR4F403.5
! containing temporary copy of D1 GKR4F403.6
LOGICAL lwritd1 ! IN - True if doing a WRITD1 temp write GKR4F403.7
GKR4F403.8
INTEGER ICODE ! OUT - Error return code DUMPCTL1.36
CHARACTER*80 CMESSAGE TS150793.47
C DUMPCTL1.38
C*---------------------------------------------------------------------- DUMPCTL1.39
C Common blocks DUMPCTL1.40
C DUMPCTL1.41
*CALL CHSUNITS GDR3F305.23
*CALL CHISTORY RS030293.202
*CALL CCONTROL DUMPCTL1.42
*CALL CENVIR DUMPCTL1.48
*CALL CLOOKADD TJ300394.47
*CALL C_MDI RR250294.6
*CALL CTIME GGH3F400.7
C DUMPCTL1.49
C Subroutines called DUMPCTL1.50
C DUMPCTL1.51
EXTERNAL GET_FILE AD050293.228
*IF DEF,ATMOS DUMPCTL1.53
* ,THETL_QT DUMPCTL1.54
*ENDIF DUMPCTL1.55
* ,DATE,CLOCK,TIMER DUMPCTL1.56
EXTERNAL UM_WRITDUMP GPB4F403.3
C DUMPCTL1.57
C Local variables DUMPCTL1.58
C DUMPCTL1.59
LOGICAL LARCHIVE ! WORK - Switch for dump archiving DUMPCTL1.60
LOGICAL LUNITTYPE ! True if unit number can be superceded GLW6F403.10
C ! dump or ppfile GLW6F403.11
LOGICAL LKEEPATM ! True if atmos safe restart dump needs GKR1F404.6
! ! to be kept until the ocean safe GKR1F404.7
! ! restart dump is produced GKR1F404.8
LOGICAL LDELATM ! True if atmos safe restart dump can GKR1F404.9
! ! now be deleted ie. ocean safe restart GKR1F404.10
! ! dump has been produced. GKR1F404.11
CHARACTER*80 FILENAME AD050293.227
CHARACTER*1 C1 DUMPCTL1.61
CHARACTER*8 CDATE ! Creation date for file DUMPCTL1.62
INTEGER MYEAR,MMONTH,MDAY,MHOUR,MMIN,MSEC,IDATE ! Creation date DUMPCTL1.63
EQUIVALENCE (IDATE,CDATE) DUMPCTL1.64
INTEGER I,J ! Loop counters DUMPCTL1.70
C DUMPCTL1.71
INTEGER NFTOUT, ! Output unit number DUMPCTL1.72
2 BUFLEN ! Length of i/o buffer for WRITDUMP DUMPCTL1.73
3 ,TOGGLE ! Dummy argument for GET_NAME DUMPCTL1.74
& ,REINIT_STEPS! Dummy argument for GET_NAME DUMPCTL1.75
*,LEN_DUMPNAME !No of characters in file name DUMPCTL1.76
*,ERROR !Error code returned by OPEN DUMPCTL1.77
&,STEP !Step number GKR4F403.9
&,archdump_monfreq ! dump archiving frequency (in months) GMG1F404.90
&,archdump_monoffset ! dump archiving offset (in months) GMG1F404.91
&,disk_address ! Current rounded disk address GBC6F404.20
&,number_of_data_words_on_disk ! Number of data words on disk GBC6F404.21
&,number_of_data_words_in_memory ! Number of Data Words in memory GBC6F404.22
&,get_char_len ! function returns number of non- GBC6F404.23
! blank leading characters from a GBC6F404.24
! character variable GBC6F404.25
INTEGER internal_model GIE0F405.3
INTEGER im ! temporary internal model id for ocean or slab GIE0F405.4
GIE0F405.5
GKR4F403.10
CHARACTER*1 FILETYPE ! Code letter for file type DUMPCTL1.78
CHARACTER*1 LETTER_3 ! dummy argument for GET_NAME DUMPCTL1.79
CHARACTER*14 DUMPNAME ! Model generated dump name DUMPCTL1.80
INTEGER STP1im(N_INTERNAL_MODEL_MAX)!NO OF STEPS SINCE im DUMP GGH3F400.8
INTEGER STP2im(N_INTERNAL_MODEL_MAX)!NO OF STEPS BETWEEN im GMG1F404.92
!PERIOD 1 MEANS GMG1F404.93
INTEGER D1_ADDR_SUBMODEL_ID ! submodel id in D1_ADDR array GPB4F403.2
*IF DEF,ATMOS ADM2F404.101
REAL ZERO_FIELD(P_FIELD,Q_LEVELS) ! mixed phase precip ADM2F404.102
*ENDIF ADM2F404.103
C GLW2F402.3
*IF DEF,MPP GLW2F402.4
*CALL PARVARS GLW2F402.5
*ENDIF GLW2F402.6
CL DUMPCTL1.81
CL---------------------------------------------------------------------- DUMPCTL1.82
C Get name of pipe AD050293.229
CALL GET_FILE(8,FILENAME,80,ICODE) GTD0F400.153
CL DUMPCTL1.85
CL 1. (Temporary correction in preparation for removing temporary RR250294.7
CL history copy from dump headers, since not used within model RR250294.8
CL and history file size now (from vn3.1 on) exceeds reserved space). RR250294.9
CL Write missing data indicators into dump copy of temporary history RR250294.10
CL block to prevent earlier overwriting error. RR250294.11
CL RR250294.12
*IF DEF,ATMOS DUMPCTL1.122
IF (I_AO.EQ.1) THEN DUMPCTL1.123
DO I=1,LEN_DUMPHIST+1 RR250294.13
A_DUMPHIST(I) = RMDI RR250294.14
ENDDO DUMPCTL1.126
ENDIF DUMPCTL1.127
*ENDIF DUMPCTL1.128
*IF DEF,OCEAN DUMPCTL1.129
IF (I_AO.EQ.2) THEN DUMPCTL1.130
DO I=1,LEN_DUMPHIST+1 RR250294.15
O_DUMPHIST(I) = RMDI RR250294.16
ENDDO DUMPCTL1.133
ENDIF DUMPCTL1.134
*ENDIF DUMPCTL1.135
*IF DEF,WAVE WRB1F401.82
IF (I_AO.EQ.4) THEN WRB1F401.83
DO I=1,LEN_DUMPHIST+1 WRB1F401.84
W_DUMPHIST(I) = RMDI WRB1F401.85
ENDDO WRB1F401.86
ENDIF WRB1F401.87
*ENDIF WRB1F401.88
CL---------------------------------------------------------------------- DUMPCTL1.136
CL 2. Set LOOKUP header data and validity times from FIXHD DUMPCTL1.137
CL DUMPCTL1.138
CL ** This section deleted due to conflict with STASH use of dump DUMPCTL1.139
CL ** LOOKUP headers to retain timestamp information across timesteps. DUMPCTL1.140
CL DUMPCTL1.141
CL---------------------------------------------------------------------- DUMPCTL1.142
CL 3. Construct dump name from model information using defined DUMPCTL1.143
CL naming convention. DUMPCTL1.144
CL DUMPCTL1.145
IF (MEANLEV.NE.-1) THEN ! Analyses already named DUMPCTL1.146
IF (lwritd1) THEN GKR4F403.11
STEP = STEPim(I_AO) GKR4F403.12
IF (STEP .NE. writestep) GOTO 999 GKR4F403.13
WRITE(DUMPNAME,1011) STEP GKR4F403.14
1011 FORMAT('..........',i4.4) GIE1F405.27
DO I=1,10 GIE1F405.26
IF(TMPFNAME(I:I).NE.' ') DUMPNAME(I:I)=TMPFNAME(I:I) GKR4F403.17
END DO GKR4F403.18
ELSE GKR4F403.19
C DUMPCTL1.147
FILETYPE='d' ! Indicates dump DUMPCTL1.148
TOGGLE=1 DUMPCTL1.149
REINIT_STEPS=0 ! default dummy value DUMPCTL1.150
LETTER_3='a' ! default dummy value DUMPCTL1.151
IF ((I_AO.EQ.1 .AND. (MODEL_ASSIM_MODE.EQ."Atmosphere" .OR. DUMPCTL1.152
* MODEL_ASSIM_MODE.EQ."Coupled ")) .OR. DUMPCTL1.153
* (I_AO.EQ.2 .AND. (MODEL_ASSIM_MODE.EQ."Ocean " .OR. DUMPCTL1.154
* MODEL_ASSIM_MODE.EQ."Coupled ")) .OR. WRB1F401.89
* (I_AO.EQ.4 .AND. MODEL_ASSIM_MODE.EQ."Wave ")) THEN WRB1F401.90
CALL GET_NAME(EXPT_ID,JOB_ID,I_AO,MEANLEV,TOGGLE, DUMPCTL1.156
* REINIT_STEPS,FILETYPE,LETTER_3,MODEL_STATUS, DUMPCTL1.157
* TIME_CONVENTION,MODEL_ANALYSIS_HRS,DUMPNAME,ICODE,CMESSAGE, GSS1F304.284
* LCAL360) GSS1F304.285
ELSE DUMPCTL1.159
CALL GET_NAME(EXPT_ID,JOB_ID,I_AO,MEANLEV,TOGGLE, DUMPCTL1.160
* REINIT_STEPS,FILETYPE,LETTER_3,MODEL_STATUS, DUMPCTL1.161
* TIME_CONVENTION,0,DUMPNAME,ICODE,CMESSAGE,LCAL360) GSS1F304.286
ENDIF DUMPCTL1.163
IF (ICODE.GT.0) GOTO 999 DUMPCTL1.164
ENDIF GKR4F403.20
ELSE DUMPCTL1.165
C Initialise dumpname to prevent problems later. DUMPCTL1.166
DUMPNAME=' ' DUMPCTL1.167
C DUMPCTL1.168
ENDIF DUMPCTL1.169
CL---------------------------------------------------------------------- DUMPCTL1.170
CL 4. Assign dump name to appropriate IO unit and open for write. DUMPCTL1.171
CL NB: Analysis dumps have preassigned names DUMPCTL1.172
CL DUMPCTL1.173
IF (MEANLEV.EQ.0 .OR. lwritd1) THEN GKR4F403.21
C Cater for instantaneous dumps DUMPCTL1.175
IF(I_AO.EQ.1)THEN DUMPCTL1.176
NFTOUT=22 ! Atmos WRB1F401.91
ELSE IF (I_AO.EQ.2) THEN WRB1F401.92
NFTOUT=42 ! Ocean WRB1F401.93
ELSE DUMPCTL1.178
NFTOUT=132 ! Wave WRB1F401.94
ENDIF DUMPCTL1.180
ELSEIF (MEANLEV.EQ.-1) THEN DUMPCTL1.181
C Cater for analysis dumps DUMPCTL1.182
IF(I_AO.EQ.1)THEN DUMPCTL1.183
NFTOUT=28 ! Atmos WRB1F401.95
ELSE IF (I_AO.EQ.2) THEN WRB1F401.96
NFTOUT=47 ! Ocean WRB1F401.97
ELSE DUMPCTL1.185
NFTOUT=133 ! Wave WRB1F401.98
ENDIF DUMPCTL1.187
ELSE DUMPCTL1.188
C Cater for mean dump DUMPCTL1.189
NFTOUT=27 DUMPCTL1.190
ENDIF DUMPCTL1.191
GBC6F404.26
*IF DEF,ATMOS GBC6F404.27
c--compute the new addresses and lengths GBC6F404.28
if(i_ao.eq.1) then GBC6F404.29
call set_dumpfile_address( GBC6F404.30
& a_fixhd, len_fixhd, GBC6F404.31
& a_lookup, len1_lookup, a_len2_lookup, GBC6F404.32
& number_of_data_words_in_memory, number_of_data_words_on_disk, GBC6F404.33
& disk_address) GBC6F404.34
endif GBC6F404.35
*ENDIF GBC6F404.36
GBC6F404.37
*IF DEF,OCEAN GBC6F404.38
c--compute the new addresses and lengths GBC6F404.39
if(i_ao.eq.2) then GBC6F404.40
call set_dumpfile_address( GBC6F404.41
& o_fixhd, len_fixhd, GBC6F404.42
& o_lookup, len1_lookup, o_len2_lookup, GBC6F404.43
& number_of_data_words_in_memory, number_of_data_words_on_disk, GBC6F404.44
& disk_address) GBC6F404.45
endif GBC6F404.46
*ENDIF GBC6F404.47
GBC6F404.48
*IF DEF,WAVE GBC6F404.49
if(i_ao.eq.4) then GBC6F404.50
c--compute the new addresses and lengths GBC6F404.51
call set_dumpfile_address( GBC6F404.52
& w_fixhd, len_fixhd, GBC6F404.53
& w_lookup, len1_lookup, w_len2_lookup, GBC6F404.54
& number_of_data_words_in_memory, number_of_data_words_on_disk, GBC6F404.55
& disk_address) GBC6F404.56
endif GBC6F404.57
*ENDIF GBC6F404.58
GBC6F404.59
c--output the new length of this dumpfile GBC6F404.60
*IF DEF,MPP GBC6F404.61
if(mype.eq.0) then GBC6F404.62
*ENDIF GBC6F404.63
*IF DEF,DIAG92 GBC6F404.64
len_dumpname=get_char_len(dumpname) GBC6F404.65
write(6,9921) dumpname(1:len_dumpname), nftout, disk_address GBC6F404.66
9921 format(/'Dumpfile Size for File ',a,' on Unit ',i4, GBC6F404.67
2 ' to be set to ',i10,' Words') GBC6F404.68
*IF DEF,T3E GBC6F404.69
write(0,9921) dumpname(1:len_dumpname), nftout, disk_address GBC6F404.70
*ENDIF GBC6F404.71
*ENDIF GBC6F404.72
call set_dumpfile_length(nftout, disk_address) GBC6F404.73
*IF DEF,MPP GBC6F404.74
endif GBC6F404.75
*ENDIF GBC6F404.76
CL DUMPCTL1.192
CL 4.1 Open unit for dump : different call required if an analysis DUMPCTL1.193
CL since name pre-assigned through environment variable DUMPCTL1.194
CL DUMPCTL1.195
IF (MEANLEV.NE.-1) THEN DUMPCTL1.196
WRITE(6,*)"DUMPCTL: Opening new file ",DUMPNAME," on unit ",NFTOUT GIE0F403.122
LEN_DUMPNAME=LEN(DUMPNAME) DUMPCTL1.198
CALL FILE_OPEN(NFTOUT,DUMPNAME,LEN_DUMPNAME,1,1,ERROR) GPB1F305.31
IF(ERROR.NE.0)GOTO900 DUMPCTL1.200
ICODE=0 DUMPCTL1.201
DUMPCTL1.202
ELSE DUMPCTL1.203
DUMPCTL1.204
CALL FILE_OPEN(NFTOUT,FT_ENVIRON(NFTOUT), GPB1F305.30
* LEN_FT_ENVIR(NFTOUT),1,0,ERROR) DUMPCTL1.206
IF(ERROR.NE.0) GOTO 900 DUMPCTL1.207
ICODE=0 DUMPCTL1.208
ENDIF DUMPCTL1.209
CL---------------------------------------------------------------------- DUMPCTL1.210
CL 5. Write dump on appropriate unit putting timestamp in header DUMPCTL1.211
CL DUMPCTL1.212
*IF DEF,ATMOS DUMPCTL1.213
IF (I_AO.EQ.1) THEN DUMPCTL1.214
DUMPCTL1.215
CL Restore conserved thermodynamic variables to dump before writing DUMPCTL1.216
DUMPCTL1.217
IF (.NOT. lwritd1) THEN GKR4F403.22
IF(LTIMER) THEN DUMPCTL1.218
CALL TIMER('THETL_QT',3) DUMPCTL1.219
END IF DUMPCTL1.220
DUMPCTL1.221
! If using mixed phase precip scheme then do not want ice in the call ADM2F404.104
! to THETL_QT. ADM2F404.105
IF (L_LSPICE) THEN ADM2F404.106
! Mixed phase precip scheme. Define an array of zeros instead ADM2F404.107
! of using QCF. ADM2F404.108
DO J=1,Q_LEVELS ADM2F404.109
DO I=1,P_FIELD ADM2F404.110
ZERO_FIELD(I,J)=0.0 ADM2F404.111
END DO ADM2F404.112
END DO ADM2F404.113
! Now call THETL_QT with the zero field ADM2F404.114
CALL THETL_QT( ADM2F404.115
& D1(JPSTAR),D1(JTHETA(1)),D1(JQ(1)),D1(JQCL(1)),ZERO_FIELD, ADM2F404.116
& D1(JP_EXNER(1)),AKH,BKH,P_FIELD,P_LEVELS,Q_LEVELS) ADM2F404.117
! Else the call to THETL_QT does contain the QCF field ADM2F404.118
ELSE ADM2F404.119
CALL THETL_QT( DUMPCTL1.222
& D1(JPSTAR),D1(JTHETA(1)),D1(JQ(1)),D1(JQCL(1)),D1(JQCF(1)), DUMPCTL1.223
& D1(JP_EXNER(1)),AKH,BKH,P_FIELD,P_LEVELS,Q_LEVELS) DUMPCTL1.224
! END IF for L_LSPICE ADM2F404.120
END IF ADM2F404.121
DUMPCTL1.225
IF(LTIMER) THEN DUMPCTL1.226
CALL TIMER('THETL_QT',4) DUMPCTL1.227
END IF DUMPCTL1.228
ENDIF GKR4F403.23
DUMPCTL1.229
C Creation date and time TS150793.48
TS150793.49
CALL DATE_TIME(A_FIXHD(35),A_FIXHD(36),A_FIXHD(37), TS150793.50
* A_FIXHD(38),A_FIXHD(39),A_FIXHD(40)) TS150793.51
TS150793.52
C Maximum length of field, required for IO buffer TJ300394.48
DUMPCTL1.243
BUFLEN=A_LOOKUP(LBLREC,1) TJ300394.49
IF (A_LEN2_LOOKUP.GT.1) THEN TJ300394.50
DO I=2,A_LEN2_LOOKUP TJ300394.51
BUFLEN=MAX(BUFLEN,A_LOOKUP(LBLREC,I)) TJ300394.52
ENDDO TJ300394.53
ENDIF TJ300394.54
TJ300394.55
IF (MEANLEV.GT.0) A_FIXHD(5)=2 ! Set FIXHD(5) for mean dump TJ130293.25
DUMPCTL1.249
D1_ADDR_SUBMODEL_ID = SUBMODEL_FOR_SM(atmos_sm) GPB4F403.4
GPB4F403.5
CALL UM_WRITDUMP(NFTOUT,A_FIXHD,LEN_FIXHD, GPB4F403.6
& A_INTHD,A_LEN_INTHD, GDG0F401.601
& A_REALHD,A_LEN_REALHD, GDG0F401.602
& A_LEVDEPC,A_LEN1_LEVDEPC,A_LEN2_LEVDEPC, GDG0F401.603
& A_ROWDEPC,A_LEN1_ROWDEPC,A_LEN2_ROWDEPC, GDG0F401.604
& A_COLDEPC,A_LEN1_COLDEPC,A_LEN2_COLDEPC, GDG0F401.605
& A_FLDDEPC,A_LEN1_FLDDEPC,A_LEN2_FLDDEPC, GDG0F401.606
& A_EXTCNST,A_LEN_EXTCNST, GDG0F401.607
& A_DUMPHIST,LEN_DUMPHIST, GDG0F401.608
& A_CFI1,A_LEN_CFI1, GDG0F401.609
& A_CFI2,A_LEN_CFI2, GDG0F401.610
& A_CFI3,A_LEN_CFI3, GDG0F401.611
& A_LOOKUP,LEN1_LOOKUP,A_LEN2_LOOKUP, GDG0F401.612
*IF DEF,MPP GSM1F403.246
& A_MPP_LOOKUP,MPP_LEN1_LOOKUP, GSM1F403.247
*ENDIF GSM1F403.248
& BUFLEN, GPB4F403.7
& atmos_sm, GPB4F403.8
& NO_OBJ_D1(D1_ADDR_SUBMODEL_ID), GPB4F403.9
& D1_ADDR(1,1,D1_ADDR_SUBMODEL_ID), GPB4F403.10
& A_LEN_DATA,D1, GPB4F403.11
*CALL ARGPPX GDG0F401.614
& ICODE,CMESSAGE) GDG0F401.615
DUMPCTL1.265
IF (ICODE.GT.0) GOTO 999 DUMPCTL1.266
DUMPCTL1.267
A_FIXHD(5)=1 ! Set FIXHD(5) back to instantaneous dump TJ130293.26
TJ130293.27
IF (MEANLEV.EQ.0) THEN DUMPCTL1.268
ARESTART='ARESTART: $DATAM/' DUMPCTL1.269
ARESTART(18:31)=DUMPNAME DUMPCTL1.270
ELSEIF (MEANLEV.EQ.-1) THEN DUMPCTL1.271
ARESTART='ARESTART: ' GRB1F401.3
ARESTART(11:80)=ATMANL(11:80) DUMPCTL1.272
ELSEIF (NFTOUT.EQ.27) THEN GDR3F305.24
! Special case for mean dump file GDR3F305.25
AOMEAN = 'AOMEAN : $DATAM/' GDR3F305.26
AOMEAN(18:31) = DUMPNAME GDR3F305.27
ENDIF DUMPCTL1.273
DUMPCTL1.274
ENDIF DUMPCTL1.275
DUMPCTL1.276
*ENDIF DUMPCTL1.277
*IF DEF,OCEAN DUMPCTL1.278
IF (I_AO.EQ.2) THEN DUMPCTL1.279
DUMPCTL1.280
C Creation date and time TS150793.53
TS150793.54
CALL DATE_TIME(O_FIXHD(35),O_FIXHD(36),O_FIXHD(37), TS150793.55
* O_FIXHD(38),O_FIXHD(39),O_FIXHD(40)) TS150793.56
DUMPCTL1.295
C Maximum length of field, required for IO buffer TJ300394.56
TJ300394.57
BUFLEN=O_LOOKUP(LBLREC,1) TJ300394.58
IF (O_LEN2_LOOKUP.GT.1) THEN TJ300394.59
DO I=2,O_LEN2_LOOKUP TJ300394.60
BUFLEN=MAX(BUFLEN,O_LOOKUP(LBLREC,I)) TJ300394.61
ENDDO TJ300394.62
ENDIF TJ300394.63
DUMPCTL1.298
IF (MEANLEV.GT.0) O_FIXHD(5)=2 ! Set FIXHD(5) for mean dump TJ130293.28
DUMPCTL1.299
D1_ADDR_SUBMODEL_ID = SUBMODEL_FOR_SM(ocean_sm) GPB4F403.12
CALL UM_WRITDUMP(NFTOUT,O_FIXHD,LEN_FIXHD, GPB4F403.13
& O_INTHD,O_LEN_INTHD, GDG0F401.617
& O_REALHD,O_LEN_REALHD, GDG0F401.618
& O_LEVDEPC,O_LEN1_LEVDEPC,O_LEN2_LEVDEPC, GDG0F401.619
& O_ROWDEPC,O_LEN1_ROWDEPC,O_LEN2_ROWDEPC, GDG0F401.620
& O_COLDEPC,O_LEN1_COLDEPC,O_LEN2_COLDEPC, GDG0F401.621
& O_FLDDEPC,O_LEN1_FLDDEPC,O_LEN2_FLDDEPC, GDG0F401.622
& O_EXTCNST,O_LEN_EXTCNST, GDG0F401.623
& O_DUMPHIST,LEN_DUMPHIST, GDG0F401.624
& O_CFI1,O_LEN_CFI1, GDG0F401.625
& O_CFI2,O_LEN_CFI2, GDG0F401.626
& O_CFI3,O_LEN_CFI3, GDG0F401.627
& O_LOOKUP,LEN1_LOOKUP,O_LEN2_LOOKUP, GDG0F401.628
*IF DEF,MPP GSM1F403.249
& O_MPP_LOOKUP,MPP_LEN1_LOOKUP, GSM1F403.250
*ENDIF GSM1F403.251
& BUFLEN, GPB4F403.14
& ocean_sm, GPB4F403.15
& NO_OBJ_D1(D1_ADDR_SUBMODEL_ID), GPB4F403.16
& D1_ADDR(1,1,D1_ADDR_SUBMODEL_ID), GPB4F403.17
& O_LEN_DATA,D1, GPB4F403.18
*CALL ARGPPX GDG0F401.630
& ICODE,CMESSAGE) GDG0F401.631
DUMPCTL1.315
IF (ICODE.GT.0) GOTO 999 DUMPCTL1.316
TJ130293.29
O_FIXHD(5)=1 ! Set FIXHD(5) back to instantaneous dump TJ130293.30
DUMPCTL1.317
IF (MEANLEV.EQ.0) THEN DUMPCTL1.318
ORESTART='ORESTART: $DATAM/' DUMPCTL1.319
ORESTART(18:31)=DUMPNAME DUMPCTL1.320
ELSEIF (MEANLEV.EQ.-1) THEN DUMPCTL1.321
ORESTART='ORESTART: ' GRB1F401.4
ORESTART(11:80)=OCNANL(11:80) DUMPCTL1.322
ENDIF DUMPCTL1.323
DUMPCTL1.324
ENDIF DUMPCTL1.325
*ENDIF DUMPCTL1.326
*IF DEF,WAVE WRB1F401.99
IF (I_AO.EQ.4) THEN WRB1F401.100
WRB1F401.101
C Creation date and time WRB1F401.102
WRB1F401.103
CALL DATE_TIME(W_FIXHD(35),W_FIXHD(36),W_FIXHD(37), WRB1F401.104
* W_FIXHD(38),W_FIXHD(39),W_FIXHD(40)) WRB1F401.105
WRB1F401.106
C Maximum length of field, required for IO buffer WRB1F401.107
WRB1F401.108
BUFLEN=W_LOOKUP(LBLREC,1) WRB1F401.109
IF (W_LEN2_LOOKUP.GT.1) THEN WRB1F401.110
DO I=2,W_LEN2_LOOKUP WRB1F401.111
BUFLEN=MAX(BUFLEN,W_LOOKUP(LBLREC,I)) WRB1F401.112
ENDDO WRB1F401.113
ENDIF WRB1F401.114
WRB1F401.115
IF (MEANLEV.GT.0) W_FIXHD(5)=2 ! Set FIXHD(5) for mean dump WRB1F401.116
WRB1F401.117
D1_ADDR_SUBMODEL_ID = SUBMODEL_FOR_SM(wave_sm) GPB4F403.19
GPB4F403.20
CALL UM_WRITDUMP(NFTOUT,W_FIXHD,LEN_FIXHD, GPB4F403.21
& W_INTHD,W_LEN_INTHD, WRB1F401.119
& W_REALHD,W_LEN_REALHD, WRB1F401.120
& W_LEVDEPC,W_LEN1_LEVDEPC,W_LEN2_LEVDEPC, WRB1F401.121
& W_ROWDEPC,W_LEN1_ROWDEPC,W_LEN2_ROWDEPC, WRB1F401.122
& W_COLDEPC,W_LEN1_COLDEPC,W_LEN2_COLDEPC, WRB1F401.123
& W_FLDDEPC,W_LEN1_FLDDEPC,W_LEN2_FLDDEPC, WRB1F401.124
& W_EXTCNST,W_LEN_EXTCNST, WRB1F401.125
& W_DUMPHIST,LEN_DUMPHIST, WRB1F401.126
& W_CFI1,W_LEN_CFI1, WRB1F401.127
& W_CFI2,W_LEN_CFI2, WRB1F401.128
& W_CFI3,W_LEN_CFI3, WRB1F401.129
& W_LOOKUP,LEN1_LOOKUP,W_LEN2_LOOKUP, WRB1F401.130
& BUFLEN, GPB4F403.22
& wave_sm, GPB4F403.23
& NO_OBJ_D1(D1_ADDR_SUBMODEL_ID), GPB4F403.24
& D1_ADDR(1,1,D1_ADDR_SUBMODEL_ID), GPB4F403.25
& W_LEN_DATA,D1, GPB4F403.26
*CALL ARGPPX WRB1F401.132
& ICODE,CMESSAGE) WRB1F401.133
WRB1F401.134
IF (ICODE.GT.0) GOTO 999 WRB1F401.135
WRB1F401.136
W_FIXHD(5)=1 ! Set FIXHD(5) back to instantaneous dump WRB1F401.137
WRB1F401.138
IF (MEANLEV.EQ.0) THEN WRB1F401.139
WRESTART='WRESTART: $DATAM/' WRB1F401.140
WRESTART(18:31)=DUMPNAME WRB1F401.141
ELSEIF (MEANLEV.EQ.-1) THEN WRB1F401.142
WRESTART(11:80)=WAVANL(11:80) WRB1F401.143
ENDIF WRB1F401.144
WRB1F401.145
ENDIF WRB1F401.146
*ENDIF WRB1F401.147
CL DUMPCTL1.327
CL 5.1 Close unit DUMPCTL1.328
CL DUMPCTL1.329
DUMPCTL1.330
IF(MEANLEV.NE.-1) THEN ! Not analysis DUMPCTL1.331
DUMPCTL1.332
LEN_DUMPNAME=LEN(DUMPNAME) DUMPCTL1.333
CALL FILE_CLOSE(NFTOUT,DUMPNAME,LEN_DUMPNAME,1,0,ICODE) GTD0F400.1
ELSE ! analysis DUMPCTL1.335
DUMPCTL1.336
CALL FILE_CLOSE(NFTOUT,FT_ENVIRON(NFTOUT),LEN_FT_ENVIR(NFTOUT), GTD0F400.2
& 0,0,ICODE) GTD0F400.3
ENDIF DUMPCTL1.339
GKR4F403.24
c--now set the current length back to zero after we have done GBC6F404.77
c the o/p GBC6F404.78
*IF DEF,MPP GBC6F404.79
if(mype.eq.0) then GBC6F404.80
*ENDIF GBC6F404.81
call set_dumpfile_length(nftout, 0) GBC6F404.82
*IF DEF,MPP GBC6F404.83
endif GBC6F404.84
*ENDIF GBC6F404.85
GKR4F403.25
!LL 5.2 Exit here for WRITD1 temporary writes of dumps since GKR4F403.26
!LL no requests need to be sent to the archive server GKR4F403.27
GKR4F403.28
IF (lwritd1) GOTO 999 GKR4F403.29
GKR4F403.30
CL---------------------------------------------------------------------- DUMPCTL1.340
CL 6. Construct dump processing requests and send to slave task DUMPCTL1.341
CL DUMPCTL1.342
CL 6.1 Delete previous last-restart-dump from disk (slave request), DUMPCTL1.343
CL and update last-restart-dump to be current dump DUMPCTL1.344
CL (exception is: first dump not to be deleted if operational) DUMPCTL1.345
CL DUMPCTL1.346
GKR1F404.12
*IF DEF,ATMOS GIE0F405.6
*IF DEF,OCEAN GIE0F405.7
im=ocean_im GIE0F405.8
*ENDIF Ocean GIE0F405.9
*IF DEF,SLAB GIE0F405.10
im= slab_im GIE0F405.11
*ENDIF Slab GIE0F405.12
*IF DEF,OCEAN,OR,DEF,SLAB GIE0F405.13
GIE0F405.14
! Check if ocean/slab has completed the same number of groups as atmos GIE0F405.15
IF( (STEPim(atmos_im)/GROUPim(atmos_im) ).EQ. GIE0F405.16
* (STEPim( im)/GROUPim( im) ) ) THEN GIE0F405.17
internal_model=atmos_im GIE0F405.18
ELSE GIE0F405.19
internal_model= im ! either slab or ocean GIE0F405.20
ENDIF GIE0F405.21
*ELSE Not OCEAN or SLAB GIE0F405.22
internal_model=atmos_im GIE0F405.23
*ENDIF on OCEAN or SLAB GIE0F405.24
GIE0F405.25
*ELSE Not ATMOS GIE0F405.26
*IF DEF,OCEAN GIE0F405.27
internal_model=ocean_im GIE0F405.28
*ELSE GIE0F405.29
*IF DEF,WAVE GIE0F405.30
! This construct is only valid while the wave sub-model in not coupled GIE0F405.31
! to any other sub-model. GIE0F405.32
internal_model=wave_im GIE0F405.33
*ELSE GIE0F405.34
ICODE=1 GIE0F405.35
CMESSAGE="SETGRCTL : Illegal sub-model type, not ATMOS, OCEAN or GIE0F405.36
& WAVE" GIE0F405.37
*ENDIF on WAVE GIE0F405.38
*ENDIF on OCEAN GIE0F405.39
*ENDIF on ATMOS GIE0F405.40
GKR1F404.13
IF (NFTOUT.EQ.22.OR.NFTOUT.EQ.42.OR.(NFTOUT.GT.59.AND. GLW6F403.12
& NFTOUT.LT.68)) THEN GLW6F403.13
! Instantaneous dump (atmos/ocean) or daily PP file? (add GKR1F404.14
! extra unit numbers 68 and 69 if so but PP files not used here) GKR1F404.15
LUNITTYPE=.TRUE. GKR1F404.16
ELSE GLW6F403.15
! All other files GKR1F404.17
LUNITTYPE=.FALSE. GKR1F404.18
ENDIF GLW6F403.17
GKR1F404.19
LKEEPATM = .FALSE. GKR1F404.20
LDELATM = .TRUE. GKR1F404.21
GKR1F404.22
GKR1F404.23
IF (MEANLEV.LE.0) THEN ! Instantaneous dump or analysis GKR1F404.24
GKR1F404.25
*IF DEF,ATMOS DUMPCTL1.348
IF (I_AO.EQ.1) THEN ! Atmos submodel GKR1F404.26
GKR1F404.27
IF (MEANLEV.EQ.0.AND.FT_SELECT(NFTOUT).EQ."Y") THEN GKR1F404.28
! Meaning not switched on and files on this unit number GKR1F404.29
! to be deleted GKR1F404.30
GKR1F404.31
IF ((internal_model .EQ.ocean_im) .AND. GIE0F405.41
& (steps_per_periodim(a_im) .NE. dumpfreqim(a_im))) THEN GKR1F404.33
! Coupled model where coupling frequency is not the GKR1F404.34
! same as the dump frequency. Therefore always need to GKR1F404.35
! keep the atmos dump until the ocean dump has been GKR1F404.36
! written at the next dump time, for restartability. GKR1F404.37
LKEEPATM=.true. GKR1F404.38
CURRATMim(A_IM)=DUMPNAME GKR1F404.39
ELSE GKR1F404.40
LKEEPATM=.false. GKR1F404.41
ENDIF GKR1F404.42
GKR1F404.43
GKR1F404.44
IF (MEANFREQim(1,A_IM) .NE. 0 ) THEN GKR1F404.45
! Period 1 means are being calculated in this run GKR1F404.46
GKR1F404.47
STP1im(A_IM)=STEPim(A_IM)+(DUMPFREQim(A_IM)* GKR1F404.48
& (OFFSET_DUMPSim(A_IM)-1)) GGH0F401.3
STP2im(A_IM)=MEANFREQim(1,A_IM)*DUMPFREQim(A_IM) GKR1F404.49
GKR1F404.50
IF (MOD(STP1im(A_IM),STP2im(A_IM)) .EQ. 0) THEN GKR1F404.51
! The last dump was at a period 1 mean point so a GKR1F404.52
! new safe restart dump was created. Therefore do GKR1F404.53
! not delete this latest safe restart dump but the GKR1F404.54
! previous safe restart dump in END_DUMPim GKR1F404.55
GKR1F404.56
IF ((internal_model .EQ.ocean_im) .AND. GIE0F405.42
& (steps_per_periodim(a_im) .NE. dumpfreqim(a_im)))THEN GKR1F404.58
LASTATMim(A_IM)=SAFEDMPim(A_IM) GKR1F404.59
ELSE GKR1F404.60
END_DUMPim(A_IM)=SAFEDMPim(A_IM) GKR1F404.61
ENDIF GKR1F404.62
ENDIF ! (MOD(STP1im(A_IM),STP2im(A_IM)) .EQ. 0) GKR1F404.63
GKR1F404.64
ENDIF ! (MEANFREQim(1,A_IM) .NE. 0 ) GKR1F404.65
GKR1F404.66
*IF DEF,MPP GLW2F402.7
IF (mype.eq.0) THEN GKR1F404.67
GKR1F404.68
*ENDIF GKR1F404.69
IF (.NOT.(MOD((STP1im(A_IM)+DUMPFREQim(A_IM)),STP2im(A_IM)) GKR1F404.70
& .EQ. 0)) THEN GKR1F404.71
IF (END_DUMPim(A_IM).NE." " .AND. GKR1F404.72
& .NOT. LKEEPATM ) THEN GKR1F404.73
! Filename to be deleted is not blank and is not to GKR1F404.74
! be kept until the ocean dump for the current step GKR1F404.75
! is written GKR1F404.76
WRITE (8,610) END_DUMPim(A_IM) ! Delete request GKR1F404.77
*IF DEF,T3E GKR1F404.78
call flush(8, icode) GKR1F404.79
*ELSE GKR1F404.80
CLOSE(8) GKR1F404.81
OPEN(8,FILE=FILENAME) GKR1F404.82
*ENDIF GKR1F404.83
ENDIF GKR1F404.84
ENDIF GLW2F402.12
*IF DEF,MPP GKR1F404.85
GKR1F404.86
ENDIF ! (mype .eq. 0) GKR1F404.87
*ENDIF GLW2F402.16
ENDIF ! (MEANLEV.EQ.0.AND.FT_SELECT(NFTOUT).EQ."Y") GKR1F404.88
GKR1F404.89
GKR1F404.90
IF (H_STEPim(A_IM).NE.DUMPTIMESim(1,A_IM).OR. GDR3F305.30
& MODEL_STATUS.NE."OPERATIONAL ") THEN GGH3F400.23
! This step is not the first one in the list of dumptimes GKR1F404.91
! or the model is not operational GKR1F404.92
GKR1F404.93
IF (MEANFREQim(1,A_IM).NE.0.AND.FT_SELECT(NFTOUT).EQ."Y") GGH0F401.11
& THEN GGH0F401.12
! Period 1 Means switched on and files on this unit GKR1F404.94
! number to be deleted GKR1F404.95
GKR1F404.96
IF (MOD((STP1im(A_IM)+DUMPFREQim(A_IM)),STP2im(A_IM)) GKR1F404.97
& .EQ. 0) THEN GGH0F401.14
! File is at a Period 1 mean point. Update names of GKR1F404.98
! old and new safe restart points. GKR1F404.99
SAFEDMPim(A_IM)=NEWSAFEim(A_IM) GKR1F404.100
NEWSAFEim(A_IM)=DUMPNAME GKR1F404.101
LASTDMPim(A_IM) = END_DUMPim(A_IM) GKR1F404.102
ELSE GKR1F404.103
END_DUMPim(A_IM)=DUMPNAME GKR1F404.104
ENDIF GKR1F404.105
ELSE GJC0F405.11
END_DUMPim(A_IM)=DUMPNAME GJC0F405.12
ENDIF GGH3F400.37
GKR1F404.107
ENDIF ! (H_STEPim(A_IM).NE.DUMPTIMESim(1,A_IM).OR GKR1F404.108
! MODEL_STATUS.NE."OPERATIONAL ") GKR1F404.109
GKR1F404.110
ENDIF ! (I_AO.EQ.1) GKR1F404.111
*ENDIF DUMPCTL1.361
*IF DEF,OCEAN DUMPCTL1.362
IF (I_AO.EQ.2) THEN GGH0F401.10
GKR1F404.112
IF (MEANLEV.EQ.0.AND.FT_SELECT(NFTOUT).EQ."Y") THEN GKR1F404.113
! Meaning not switched on and files on this unit number GKR1F404.114
! to be deleted GKR1F404.115
GKR1F404.116
IF( (internal_model .EQ.ocean_im) .AND. GIE0F405.43
& (steps_per_periodim(o_im) .NE. dumpfreqim(o_im)) ) THEN GKR1F404.118
! Coupled model where coupling frequency is not the GKR1F404.119
! same as the dump frequency. Atmos dump for the GKR1F404.120
! previous dump time can now be deleted. GKR1F404.121
LDELATM = .true. GKR1F404.122
ENDIF GKR1F404.123
GKR1F404.124
IF (MEANFREQim(1,O_IM) .NE. 0 ) THEN GJC0F405.13
! Period 1 means are being calculated in this run GKR1F404.126
STP1im(O_IM)=STEPim(O_IM)+(DUMPFREQim(O_IM)* GKR1F404.127
& (OFFSET_DUMPSim(O_IM)-1)) GGH0F401.16
STP2im(O_IM)=MEANFREQim(1,O_IM)*DUMPFREQim(O_IM) GKR1F404.128
GKR1F404.129
IF (MOD(STP1im(O_IM),STP2im(O_IM)) .EQ. 0) THEN GKR1F404.130
! The last dump was at a period 1 mean point so a GKR1F404.131
! new safe restart dump was created. Therefore do GKR1F404.132
! not delete this latest safe restart dump but the GKR1F404.133
! previous safe restart dump in END_DUMPim GKR1F404.134
END_DUMPim(O_IM)=SAFEDMPim(O_IM) GKR1F404.135
ENDIF GKR1F404.136
ENDIF GJC0F405.14
GKR1F404.138
*IF DEF,MPP GLW2F402.17
IF (mype.eq.0) THEN GKR1F404.139
GKR1F404.140
*ENDIF GKR1F404.141
IF (.NOT.(MOD((STP1im(O_IM)+DUMPFREQim(O_IM)),STP2im(O_IM)) GKR1F404.142
& .EQ. 0)) THEN GKR1F404.143
IF (END_DUMPim(O_IM).NE." ") THEN GKR1F404.144
! Filename to be deleted is not blank GKR1F404.145
WRITE(8,610) END_DUMPim(O_IM) GKR1F404.146
*IF DEF,T3E GKR1F404.147
call flush(8, icode) GKR1F404.148
*ELSE GKR1F404.149
CLOSE(8) GKR1F404.150
OPEN(8,FILE=FILENAME) GKR1F404.151
*ENDIF GKR1F404.152
ENDIF GKR1F404.153
GKR1F404.154
IF (LDELATM .AND. LASTATMim(A_IM).NE." ")THEN GKR1F404.155
! There is an atmos dump to delete and the filename GKR1F404.156
! to be deleted is not blank GKR1F404.157
WRITE(8,610) LASTATMim(A_IM) GKR1F404.158
CLOSE(8) GKR1F404.159
ENDIF GKR1F404.160
OPEN(8,FILE=FILENAME) GKR1F404.161
ENDIF GLW2F402.22
*IF DEF,MPP GKR1F404.162
GKR1F404.163
ENDIF ! (mype.eq.0) GKR1F404.164
*ENDIF GKR1F404.165
LASTATMim(A_IM) = CURRATMim(A_IM) GKR1F404.166
GKR1F404.167
ENDIF ! (MEANLEV.EQ.0.AND.FT_SELECT(NFTOUT).EQ."Y") GKR1F404.168
GKR1F404.169
GKR1F404.170
IF (MEANFREQim(1,O_IM).NE.0.AND.FT_SELECT(NFTOUT).EQ."Y") GKR1F404.171
& THEN GKR1F404.172
! Period 1 Means switched on and files on this unit GKR1F404.173
! number to be deleted GKR1F404.174
IF (MOD((STP1im(O_IM)+DUMPFREQim(O_IM)),STP2im(O_IM)) GKR1F404.175
& .EQ. 0) THEN GKR1F404.176
! File is at a Period 1 mean point. Update names of GKR1F404.177
! old and new safe restart points. GKR1F404.178
SAFEDMPim(O_IM)=NEWSAFEim(O_IM) GKR1F404.179
NEWSAFEim(O_IM)=DUMPNAME GKR1F404.180
LASTDMPim(O_IM) = END_DUMPim(O_IM) GKR1F404.181
ELSE GKR1F404.182
END_DUMPim(O_IM)=DUMPNAME GKR1F404.183
ENDIF GKR1F404.184
ELSE GKR1F404.185
END_DUMPim(O_IM)=DUMPNAME GKR1F404.186
ENDIF GLW2F402.24
GGH0F401.27
ENDIF ! (I_AO.EQ.2) GKR1F404.187
*ENDIF DUMPCTL1.371
610 FORMAT('%%% ',A14,' DELETE') DUMPCTL1.372
GKR1F404.188
ENDIF ! (MEANLEV.LE.0) GKR1F404.189
GKR1F404.190
C GKR1F404.191
CL 6.2 If current dump is to be archived construct archiving request DUMPCTL1.375
CL followed by delete request if appropriate GKR1F404.192
CL DUMPCTL1.376
LARCHIVE = .FALSE. DUMPCTL1.377
GKR1F404.193
IF (I_AO.EQ.1 .or. I_AO.EQ.2 .or. I_AO.EQ.4) THEN WRB1F401.148
GKR1F404.194
IF (MEANLEV.LE.0 .AND. DUMPFREQim(I_AO).GT.0 GDR3F305.36
& .AND. ARCHDUMP_FREQim(I_AO).GT.0) THEN GDR3F305.37
! No meaning, regular dumping, regular archiving GKR1F404.195
GKR1F404.196
if (lclimrealyr) then ! get freq + offset in terms of real GMG1F404.94
! months from 360d-style freq + offset GMG1F404.95
if (i_day .eq. 1 .and. i_hour .eq. 0) then ! end of month GMG1F404.96
archdump_monfreq=(DUMPFREQim(I_AO)*ARCHDUMP_FREQim(I_AO)* GMG1F404.97
& SECS_PER_PERIODim(I_AO))/ GMG1F404.98
& (30*86400*STEPS_PER_PERIODim(I_AO)) GMG1F404.99
archdump_monoffset=(DUMPFREQim(I_AO)*ARCHDUMP_OFFSETim(I_AO) GMG1F404.100
& *SECS_PER_PERIODim(I_AO))/ GMG1F404.101
& (30*86400*STEPS_PER_PERIODim(I_AO)) GMG1F404.102
! N.B. i_month is used below, not (i_month-1), because offset is from GMG1F404.103
! _start_ of 1st month GMG1F404.104
if(mod((i_month-(MODEL_BASIS_TIME(2)+archdump_monoffset)), GMG1F404.105
& archdump_monfreq) .eq. 0) then GMG1F404.106
LARCHIVE = .true. GMG1F404.107
endif GMG1F404.108
endif GMG1F404.109
else IF ( H_STEPim(I_AO)/DUMPFREQim(I_AO) .GE. GMG1F404.110
& ARCHDUMP_OFFSETim(I_AO) ) THEN GDR8F400.4
! Have passed the timestep from which to start archiving GKR1F404.197
! Calculate whether this timestep is an archive time GKR1F404.198
GKR1F404.199
LARCHIVE = (MOD((H_STEPim(I_AO)/ GKR1F404.200
& DUMPFREQim(I_AO)-ARCHDUMP_OFFSETim(I_AO)), GDR3F305.39
& ARCHDUMP_FREQim(I_AO)).EQ.0) GDR3F305.40
ENDIF GDR8F400.5
GKR1F404.201
ELSEIF (MEANLEV.LE.0 .AND. DUMPFREQim(I_AO).EQ.0) THEN GDR3F305.41
! No meaning, no regular dumping. Will archive if archiving GKR1F404.202
! frequency is greater than 0. GKR1F404.203
LARCHIVE= (ARCHDUMP_FREQim(I_AO).GT.0) GDR3F305.42
GKR1F404.204
ELSEIF (MEANLEV.GT.0) THEN GDR3F305.43
! Meaning on. Archive is mean archive frequncy > 0. GKR1F404.205
LARCHIVE= (MEANARCHim(MEANLEV,I_AO).EQ.1) GDR3F305.44
ENDIF GDR3F305.45
*IF DEF,MPP GLW2F402.28
IF (mype.eq.0) THEN GLW2F402.29
*ENDIF GKR1F404.206
IF (LARCHIVE) THEN GLW2F402.30
! Archiving turned on GKR1F404.207
WRITE(8,620) DUMPNAME ! archive request GKR1F404.208
*IF DEF,T3E GKR1F404.209
call flush(8, icode) GKR1F404.210
*ELSE GKR1F404.211
CLOSE(8) GJC0F405.15
OPEN(8,FILE=FILENAME) GKR1F404.213
*ENDIF GKR1F404.214
IF (MEANLEV.GT.0) THEN GLW6F403.18
! Meaning turned on GKR1F404.215
IF (LUNITTYPE) THEN GLW6F403.19
! Correct sort of unit to be deleted GKR1F404.216
IF (FT_SELECT(NFTOUT).EQ."Y") THEN GLW6F403.20
! Files on this unit number is to be deleted GKR1F404.217
WRITE(8,610) DUMPNAME ! Delete request GKR1F404.218
ENDIF GLW6F403.22
ELSE GLW6F403.23
WRITE(8,610) DUMPNAME ! Delete request GKR1F404.219
ENDIF GLW6F403.25
*IF DEF,T3E GKR1F404.220
call flush(8, icode) GKR1F404.221
*ELSE GKR1F404.222
CLOSE(8) GLW2F402.33
OPEN(8,FILE=FILENAME) GLW2F402.34
*ENDIF GKR1F404.223
GKR1F404.224
ENDIF GLW6F403.26
GKR1F404.225
ELSE ! LARCHIVE false GKR1F404.226
GKR1F404.227
IF (MEANLEV.GT.0) THEN GLW2F402.36
! Meaning turned on GKR1F404.228
IF (LUNITTYPE) THEN GKR1F404.229
! Correct sort of unit to be deleted GKR1F404.230
IF (FT_SELECT(NFTOUT).EQ."Y") THEN GLW6F403.28
! Files on this unit number is to be deleted GKR1F404.231
WRITE(8,610) DUMPNAME ! Delete request GKR1F404.232
ENDIF GLW6F403.30
ELSE GLW6F403.31
WRITE(8,610) DUMPNAME ! Delete request GKR1F404.233
ENDIF GLW6F403.33
*IF DEF,T3E GKR1F404.234
call flush(8, icode) GKR1F404.235
*ELSE GKR1F404.236
CLOSE(8) GLW2F402.38
OPEN(8,FILE=FILENAME) GLW2F402.39
*ENDIF GKR1F404.237
ENDIF GLW2F402.40
GKR1F404.238
ENDIF GLW2F402.41
*IF DEF,MPP GKR1F404.239
ENDIF GLW2F402.45
*ENDIF GLW2F402.46
ENDIF ! (I_AO.EQ.1 .or. I_AO.EQ.2 .or. I_AO.EQ.4) GKR1F404.240
GKR1F404.241
620 FORMAT('%%% ',A14,' ARCHIVE DUMP') GKR1F404.242
GKR1F404.243
C DUMPCTL1.429
C Normal return DUMPCTL1.430
C DUMPCTL1.431
RETURN DUMPCTL1.432
C DUMPCTL1.433
C Error returns DUMPCTL1.434
C DUMPCTL1.435
900 ICODE=1 DUMPCTL1.436
CMESSAGE="DUMPCTL : Fail to open output dump - may already exist" DUMPCTL1.437
999 CONTINUE DUMPCTL1.438
RETURN DUMPCTL1.439
CL---------------------------------------------------------------------- DUMPCTL1.440
END DUMPCTL1.441
*ENDIF DUMPCTL1.442