SUBROUTINE PPCTL( 3,38@DYALLOC.2921
*CALL ARGSIZE 
@DYALLOC.2922
*CALL ARGD1 @DYALLOC.2923
*CALL ARGDUMA @DYALLOC.2924
*CALL ARGDUMO @DYALLOC.2925
*CALL ARGDUMW WRB1F401.636
*CALL ARGINFA @DYALLOC.2926
*CALL ARGINFO GMB1F405.474
*CALL ARGPPX GMB1F405.475
& I_AO,MEANLEV,LINITIAL,PPNAME,ICODE,CMESSAGE ) @DYALLOC.2927
C PPCTL2.41
IMPLICIT NONE PPCTL2.42
*CALL CMAXSIZE @DYALLOC.2928
*CALL CINTFA GDR2F405.122
*CALL CMAXSIZO GMB1F405.476
*CALL TYPSIZE @DYALLOC.2929
*CALL TYPD1 @DYALLOC.2930
*CALL TYPDUMA @DYALLOC.2931
*CALL TYPDUMO @DYALLOC.2932
*CALL TYPDUMW WRB1F401.637
*CALL TYPINFA @DYALLOC.2933
*CALL TYPINFO GMB1F405.477
GMB1F405.478
*CALL CSUBMODL GMB1F405.479
*CALL CPPXREF GMB1F405.480
*CALL PPXLOOK GMB1F405.481
@DYALLOC.2934
INTEGER I_AO ! IN - Atmosphere/Ocean indicator PPCTL2.43
INTEGER MEANLEV ! IN - Mean level indicator PPCTL2.44
LOGICAL LINITIAL ! IN - TRUE if called from INITIAL PPCTL2.45
CHARACTER*14 PPNAME ! OUT - PP filename generated by GET_NAME PPCTL2.46
INTEGER ICODE ! OUT - Return code from routine PPCTL2.47
CHARACTER*(80) CMESSAGE ! OUT - Return message if failure occurred TS150793.116
C PPCTL2.49
C*---------------------------------------------------------------------- PPCTL2.50
C Common blocks PPCTL2.51
C PPCTL2.52
*CALL CHSUNITS GDR3F305.148
*CALL CHISTORY RS030293.150
*CALL CCONTROL PPCTL2.53
*CALL CTIME PPCTL2.56
*CALL CENVIR PPCTL2.57
*CALL CINTFO GMB1F405.482
C PPCTL2.58
C Subroutines called PPCTL2.59
C PPCTL2.60
EXTERNAL GET_NAME,INIT_PP,IN_INTF,INTF_AREA GMB1F405.483
C PPCTL2.62
C Local variables PPCTL2.63
C PPCTL2.64
INTEGER NFTUNIT ! FORTRAN unit PPCTL2.65
INTEGER SMID ! Submodel id for filenaming PPCTL2.66
INTEGER I,IPOS ! Indices within filename string PPCTL2.67
INTEGER TOGGLE ! Dummy toggle switch PPCTL2.68
INTEGER STEP_PP ! Number of pa files written so far PPCTL2.69
INTEGER STEP ! Timestep of model PPCTL2.70
*,LEN_PPNAME PPCTL2.71
INTEGER JINTF ! Interface area index DR240293.945
INTEGER FIXHD_DUMMY(LEN_FIXHD) ! Array for reading header RR260493.4
INTEGER LEN_IO ! I/O output length RR260493.5
REAL A ! I/O output code RR260493.6
CHARACTER*1 FILETYPE ! File type letter PPCTL2.72
CHARACTER*80 STRING ! Work array PPCTL2.73
CHARACTER*14 OLDPPFILE ! Previous PPfile on given unit PPCTL2.74
C PPCTL2.75
*IF DEF,MPP GLW2F402.49
*CALL PARVARS GLW2F402.50
*ENDIF GLW2F402.51
character*80 filename ! Used to hold the filename of the GBC5F405.4
! pipe file, so that the unit can be GBC5F405.5
! closed if necessary to flush it. GBC5F405.6
CL---------------------------------------------------------------------- DR240293.951
TOGGLE=1 ! Dummy argument needed for GET_NAME PPCTL2.77
CL---------------------------------------------------------------------- PPCTL2.78
GBCCF404.26
C Get name of pipe GBCCF404.27
call get_file(8, filename, 80, icode) GBCCF404.28
CL 1. Called from INITIAL PPCTL2.79
CL PPCTL2.80
IF (LINITIAL) THEN PPCTL2.81
PPCTL2.82
DO NFTUNIT=20,NUNITS RS030293.151
CL PPCTL2.84
CL 1.1 OPEN all active units using most recent filenames (as assigned by PPCTL2.85
CL script). PPCTL2.86
CL Close unit again if reinitialisation is indicated to prevent PPCTL2.87
CL heap fragmentation later. PPCTL2.88
CL PPCTL2.89
IF (FT_ACTIVE(NFTUNIT).EQ.'Y') THEN PPCTL2.90
WRITE(6,*)'PPCTL: Opening preattached file on unit ',NFTUNIT GIE0F403.485
CALL FILE_OPEN(NFTUNIT,FT_ENVIRON(NFTUNIT), GPB1F305.107
& LEN_FT_ENVIR(NFTUNIT),1,0,ICODE) GPB1F305.108
IF (ICODE.NE.0) THEN DR240293.952
CMESSAGE='PPCTL : Error opening preassigned PPfile' DR240293.953
GO TO 999 ! Return DR240293.954
ENDIF DR240293.955
CL Perform dummy read of fixed header of pre-assigned file to RR260493.7
CL circumvent heap fragmentation problem in operational global CRUNs RR260493.8
CL NB: only trap a fatal error on read in Operational mode; in GTJ1F400.3
CL climate mode, the file may have been closed and archived in GTJ1F400.4
CL a previous run which failed later, but is not needed again. GTJ1F400.5
CALL BUFFIN (NFTUNIT,FIXHD_DUMMY,LEN_FIXHD,LEN_IO,A) GTJ1F400.6
IF(A.NE.-1.0.OR.LEN_IO.NE.LEN_FIXHD) THEN GTJ1F400.7
CMESSAGE='PPCTL2: I/O ERROR' GTJ1F400.10
IF (MODEL_STATUS.EQ.'Operational ') THEN GTJ1F400.11
ICODE=1 GTJ1F400.12
CALL IOERROR('buffer in pp fixed header', GBC2F404.88
2 A,LEN_IO,LEN_FIXHD) GBC2F404.89
RETURN GTJ1F400.13
ELSE GTJ1F400.14
ICODE=-1 GTJ1F400.15
write(6,8831) a, len_io, len_fixhd GBC2F404.90
8831 format(/'PP_CTL: Error Buffering in Fixed length Header' GBC2F404.91
2 /' Empty PP File in Climate Mode?'// GBC2F404.92
3 'Error code = ',f6.2/ GBC2F404.93
4 'Length requested = ',i9/ GBC2F404.94
5 'Length actually transferred = ',i9) GBC2F404.95
*IF DEF,T3E,AND,DEF,MPP GBC2F404.96
if(mype.eq.0) write(6,8831) a, len_io, len_fixhd GBC2F404.97
*ENDIF GBC2F404.98
ENDIF GTJ1F400.16
ENDIF GTJ1F400.17
CL RR260493.16
IF(FT_STEPS(NFTUNIT).GT.0)CALL FILE_CLOSE(NFTUNIT, GTD0F400.28
& FT_ENVIRON(NFTUNIT),LEN_FT_ENVIR(NFTUNIT),0,0,ICODE) GTD0F400.29
ENDIF PPCTL2.97
CL PPCTL2.98
CL 1.2 Take action on all selected units PPCTL2.99
CL PPCTL2.100
IF (LPP_SELECT(NFTUNIT)) THEN PPCTL2.101
CALL FILE_CLOSE(NFTUNIT,FT_ENVIRON(NFTUNIT), GTD0F400.30
& LEN_FT_ENVIR(NFTUNIT),0,0,ICODE) GTD0F400.31
PPCTL2.104
CL Set SMID from TYPE_LETTER_2 PPCTL2.105
PPCTL2.106
IF (TYPE_LETTER_2(NFTUNIT).EQ.'a') THEN PPCTL2.107
SMID=1 PPCTL2.108
ELSEIF (TYPE_LETTER_2(NFTUNIT).EQ.'o') THEN PPCTL2.109
SMID=2 PPCTL2.110
ELSEIF (TYPE_LETTER_2(NFTUNIT).EQ.'w') THEN WRB1F401.638
SMID=4 WRB1F401.639
ELSE PPCTL2.111
SMID=I_AO PPCTL2.112
ENDIF PPCTL2.113
PPCTL2.114
CL PPCTL2.115
CL 1.3 Open reinitialised files provided not already active. PPCTL2.116
CL Filename required. PPCTL2.117
CL PPCTL2.118
IF (FT_STEPS(NFTUNIT).NE.0.and. GMG1F404.299
* .NOT. FT_ACTIVE(NFTUNIT).EQ.'Y') THEN PPCTL2.120
CL PPCTL2.122
CL 1.4 Construct PPfile name from model information using defined PPCTL2.123
CL naming convention (INPUT files) PPCTL2.124
CL PPCTL2.125
IF (FT_INPUT(NFTUNIT).EQ.'Y') THEN PPCTL2.126
CALL GET_NAME(EXPT_ID_IN,JOB_ID_IN,SMID,MEANLEV,TOGGLE, PPCTL2.127
* FT_STEPS(NFTUNIT),TYPE_LETTER_1(NFTUNIT), PPCTL2.128
* TYPE_LETTER_3(NFTUNIT), PPCTL2.129
* MODEL_STATUS,TIME_CONVENTION,0,PPNAME,ICODE,CMESSAGE, GSS1F304.512
* LCAL360) GSS1F304.513
IF (ICODE.GT.0) GOTO 999 PPCTL2.131
ELSE PPCTL2.132
CL PPCTL2.133
CL 1.5 Construct PPfile name from model information using defined PPCTL2.134
CL naming convention (OUTPUT files) PPCTL2.135
CL PPCTL2.136
CALL GET_NAME(EXPT_ID,JOB_ID,SMID,MEANLEV,TOGGLE, PPCTL2.137
* FT_STEPS(NFTUNIT),TYPE_LETTER_1(NFTUNIT), PPCTL2.138
* TYPE_LETTER_3(NFTUNIT), PPCTL2.139
* MODEL_STATUS,TIME_CONVENTION,0,PPNAME,ICODE,CMESSAGE, GSS1F304.514
* LCAL360) GSS1F304.515
IF (ICODE.GT.0) GOTO 999 PPCTL2.141
ENDIF PPCTL2.142
CL PPCTL2.143
WRITE(6,*)'PPCTL: Opening new file ',PPNAME,' on unit ', GIE0F403.486
* NFTUNIT PPCTL2.145
LEN_PPNAME=LEN(PPNAME) PPCTL2.146
CALL FILE_OPEN(NFTUNIT,PPNAME,LEN_PPNAME,1,1,ICODE) GPB1F305.110
IF (ICODE.NE.0) THEN DR240293.956
CMESSAGE='PPCTL : Error opening new PPfile' DR240293.957
GO TO 999 ! Return DR240293.958
ENDIF DR240293.959
CL PPCTL2.149
CL 1.6 Update history file record for appropriate unit with new filename PPCTL2.150
CL PPCTL2.151
STRING=MODEL_FT_UNIT(NFTUNIT) PPCTL2.152
STRING(11:17)='$DATAM/' PPCTL2.153
STRING(18:31)=PPNAME PPCTL2.154
STRING(32:80)=' ' PPCTL2.155
MODEL_FT_UNIT(NFTUNIT)=STRING PPCTL2.156
ENDIF PPCTL2.157
CL PPCTL2.158
CL 1.7 Initialise or read in the direct access lookup headers of the PPCTL2.159
CL input/output file. PPCTL2.160
CL PPCTL2.161
CL (a) PP files PPCTL2.162
IF (TYPE_LETTER_1(NFTUNIT).EQ.'p') then PPCTL2.163
PPCTL2.164
IF (FT_OUTPUT(NFTUNIT).EQ.'Y' PPCTL2.165
* .AND..NOT.FT_ACTIVE(NFTUNIT).EQ.'Y') THEN PPCTL2.166
*IF DEF,ATMOS PPCTL2.167
IF (SMID.EQ.1) THEN PPCTL2.168
CL PPCTL2.169
CL Open file if not to be re-initialised, i.e. file name is in PPCTL2.170
CL environment variable. PPCTL2.171
IF(FT_STEPS(NFTUNIT).EQ.0) PPCTL2.172
* CALL FILE_OPEN(NFTUNIT,FT_ENVIRON(NFTUNIT), GPB1F305.111
* LEN_FT_ENVIR(NFTUNIT),1,0,ICODE) PPCTL2.174
WRITE(6,*)'PPCTL: Initialising new file on unit ',NFTUNIT GIE0F403.487
CALL INIT_PP(NFTUNIT,TYPE_LETTER_1(NFTUNIT), TJ130293.2
* LEN1_LOOKUP,PP_LEN2_LOOK(NFTUNIT), PPCTL2.177
* A_FIXHD,A_INTHD,A_REALHD,A_LEVDEPC, PPCTL2.178
* LEN_FIXHD,A_LEN_INTHD,A_LEN_REALHD,A_LEN1_LEVDEPC, PPCTL2.179
* A_LEN2_LEVDEPC,ICODE,CMESSAGE) PPCTL2.180
IF (ICODE.GT.0) GOTO 999 PPCTL2.181
FT_LASTFIELD(NFTUNIT)=0 PPCTL2.182
ENDIF PPCTL2.183
*ENDIF PPCTL2.184
*IF DEF,OCEAN PPCTL2.185
IF (SMID.EQ.2) THEN PPCTL2.186
CL PPCTL2.187
CL Open file if not to be re-initialised, i.e. file name is in PPCTL2.188
CL environment variable. PPCTL2.189
IF(FT_STEPS(NFTUNIT).EQ.0) PPCTL2.190
* CALL FILE_OPEN(NFTUNIT,FT_ENVIRON(NFTUNIT), GPB1F305.112
* LEN_FT_ENVIR(NFTUNIT),1,0,ICODE) PPCTL2.192
WRITE(6,*)'PPCTL: Initialising new file on unit ',NFTUNIT GIE0F403.488
CALL INIT_PP(NFTUNIT,TYPE_LETTER_1(NFTUNIT), TJ130293.3
* LEN1_LOOKUP,PP_LEN2_LOOK(NFTUNIT), PPCTL2.195
* O_FIXHD,O_INTHD,O_REALHD,O_LEVDEPC, PPCTL2.196
* LEN_FIXHD,O_LEN_INTHD,O_LEN_REALHD,O_LEN1_LEVDEPC, PPCTL2.197
* O_LEN2_LEVDEPC,ICODE,CMESSAGE) PPCTL2.198
IF (ICODE.GT.0) GOTO 999 PPCTL2.199
FT_LASTFIELD(NFTUNIT)=0 PPCTL2.200
ENDIF PPCTL2.201
*ENDIF PPCTL2.202
*IF DEF,WAVE WRB1F401.640
IF (SMID.EQ.4) THEN WRB1F401.641
CL WRB1F401.642
CL Open file if not to be re-initialised, i.e. file name is in WRB1F401.643
CL environment variable. WRB1F401.644
IF(FT_STEPS(NFTUNIT).EQ.0) WRB1F401.645
* CALL FILE_OPEN(NFTUNIT,FT_ENVIRON(NFTUNIT), WRB1F401.646
* LEN_FT_ENVIR(NFTUNIT),1,0,ICODE) WRB1F401.647
WRITE(6,*)'PPCTL: Initialising new file on unit ',NFTUNIT GIE0F403.489
CALL INIT_PP(NFTUNIT,TYPE_LETTER_1(NFTUNIT), WRB1F401.649
* LEN1_LOOKUP,PP_LEN2_LOOK(NFTUNIT), WRB1F401.650
* W_FIXHD,W_INTHD,W_REALHD,W_LEVDEPC, WRB1F401.651
* LEN_FIXHD,W_LEN_INTHD,W_LEN_REALHD,W_LEN1_LEVDEPC, WRB1F401.652
* W_LEN2_LEVDEPC,ICODE,CMESSAGE) WRB1F401.653
IF (ICODE.GT.0) GOTO 999 WRB1F401.654
FT_LASTFIELD(NFTUNIT)=0 WRB1F401.655
ENDIF PPCTL2.203
*ENDIF WRB1F401.656
ENDIF WRB1F401.657
CL PPCTL2.204
CL (b) Boundary files input and output PPCTL2.205
CL PPCTL2.206
ELSE IF (TYPE_LETTER_1(NFTUNIT).EQ.'b') THEN GDR2F405.123
CL PPCTL2.209
CL Call boundary file initialisation routine even if a continuation PPCTL2.210
CL run and file already exists. PPCTL2.211
CL PPCTL2.212
IF (FT_OUTPUT(NFTUNIT).EQ.'Y')THEN PPCTL2.213
WRITE(6,*)'PPCTL: Opening boundary output file on unit ', GIE0F403.490
* NFTUNIT PPCTL2.215
CL PPCTL2.216
CL Open file if not to be re-initialised, i.e. file name is in PPCTL2.217
CL environment variable. PPCTL2.218
IF(FT_STEPS(NFTUNIT).EQ.0) PPCTL2.219
* CALL FILE_OPEN(NFTUNIT,FT_ENVIRON(NFTUNIT), GPB1F305.113
* LEN_FT_ENVIR(NFTUNIT),1,0,ICODE) PPCTL2.221
GMB1F405.484
! Get interface area number GMB1F405.485
call intf_area( SMID, NFTUNIT, JINTF) GMB1F405.486
GDR2F405.124
*IF DEF,ATMOS GDR2F405.125
if ( SMID .eq. a_im ) then GDR2F405.126
GDR2F405.127
CALL IN_INTF ( @DYALLOC.2935
*CALL ARGSIZE @DYALLOC.2936
*CALL ARGD1 @DYALLOC.2937
*CALL ARGDUMA @DYALLOC.2938
*CALL ARGINFA @DYALLOC.2939
* NFTUNIT,ICODE,CMESSAGE) @DYALLOC.2940
GDR2F405.128
IF (ICODE.GT.0) THEN GDR2F405.129
WRITE (6,*) ' PPCTL : Error in IN_INTF - Atmos.' GDR2F405.130
GO TO 999 ! Return GDR2F405.131
ENDIF GDR2F405.132
GDR2F405.133
endif ! if SMID GDR2F405.134
*ENDIF GDR2F405.135
*IF DEF,OCEAN,AND,-DEF,ATMOS GMB1F405.487
if ( SMID .eq. o_im ) then GMB1F405.488
GMB1F405.489
! Modset is required for IN_INTF to work for ocean GMB1F405.490
! until next release. GMB1F405.491
GMB1F405.492
CALL IN_INTF( GMB1F405.493
*CALL ADUMLENO GMB1F405.494
*CALL AINFLENO GMB1F405.495
*CALL ARGDUMO GMB1F405.496
*CALL AINTFO GMB1F405.497
*CALL ARGINFO GMB1F405.498
*CALL ARGPPX GMB1F405.499
& km, jmt, jmt-1, imt, GMB1F405.500
& SMID,NFTUNIT,JINTF,ICODE,CMESSAGE) GMB1F405.501
GMB1F405.502
IF (ICODE.GT.0) THEN GMB1F405.503
WRITE (6,*) ' PPCTL : Error in IN_INTF - Ocean.' GMB1F405.504
GO TO 999 ! Return GMB1F405.505
ENDIF GMB1F405.506
GMB1F405.507
end if ! SMID GMB1F405.508
*ENDIF GMB1F405.509
IF (FT_STEPS(NFTUNIT).GT.0) THEN PPCTL2.224
IF (I_AO.EQ.1) THEN PPCTL2.225
STEP=STEPim(a_im) GDR5F305.141
ELSE IF (I_AO.EQ.2) THEN PPCTL2.227
STEP=STEPim(o_im) GDR5F305.142
ENDIF PPCTL2.229
IF (STEP.EQ.0.OR.(STEP-FT_FIRSTSTEP(NFTUNIT).NE.0.AND. PPCTL2.230
* MOD(STEP-FT_FIRSTSTEP(NFTUNIT), PPCTL2.231
* FT_STEPS(NFTUNIT)).EQ.0)) THEN PPCTL2.232
FT_LASTFIELD(NFTUNIT)=0 PPCTL2.233
ENDIF PPCTL2.234
ENDIF PPCTL2.235
CL Call routine to open and read boundary input file. PPCTL2.236
C ELSE IF (FT_INPUT(NFTUNIT).EQ.'Y')then PPCTL2.237
CL This is where IN_BOUND should be called PPCTL2.238
ENDIF PPCTL2.239
CL PPCTL2.240
CL (c) Ancillary files ? May be added at some future date PPCTL2.241
CL PPCTL2.242
PPCTL2.243
ENDIF PPCTL2.244
PPCTL2.245
C Close unit to release IO buffer if later reinitialisation indicated PPCTL2.246
IF(FT_STEPS(NFTUNIT).NE.0)THEN GMG1F404.300
LEN_PPNAME=LEN(PPNAME) PPCTL2.248
CALL FILE_CLOSE(NFTUNIT,PPNAME,LEN_PPNAME,1,0,ICODE) GTD0F400.32
ENDIF PPCTL2.250
CL Reset unit as active PPCTL2.251
FT_ACTIVE(NFTUNIT) = 'Y' PPCTL2.252
ENDIF PPCTL2.253
PPCTL2.254
END DO PPCTL2.255
PPCTL2.256
ELSE PPCTL2.257
CL---------------------------------------------------------------------- PPCTL2.258
CL 2.0 Call to PPCTL to reintialise non-mean files ie PP or boundary PPCTL2.259
CL files after the initial call (in this case FT_STEPS > 0) PPCTL2.260
PPCTL2.261
IF (MEANLEV.EQ.0) THEN PPCTL2.262
PPCTL2.263
CL---------------------------------------------------------------------- PPCTL2.264
CL 2.1 Loop over all valid FORTRAN units and select those to be PPCTL2.265
CL initialised this timestep as set by SETTSCTL PPCTL2.266
CL PPCTL2.267
SMID=I_AO PPCTL2.268
PPCTL2.269
DO NFTUNIT=20,NUNITS RS030293.152
PPCTL2.271
IF (LPP_SELECT(NFTUNIT)) THEN PPCTL2.272
CL PPCTL2.273
CL 2.2 Generate output processing requests for previous file on PPCTL2.274
CL this unit, which is now complete PPCTL2.275
CL PPCTL2.276
STRING=MODEL_FT_UNIT(NFTUNIT) PPCTL2.277
DO I=1,80 PPCTL2.278
IF(STRING(I:I).EQ."/") IPOS=I PPCTL2.279
ENDDO PPCTL2.280
OLDPPFILE=STRING(IPOS+1:IPOS+14) PPCTL2.281
PPCTL2.282
IF (FT_SELECT(NFTUNIT).EQ.'Y') THEN PPCTL2.283
IF (FT_ARCHSEL(NFTUNIT).EQ.'Y') THEN PPCTL2.284
IF (NFTUNIT.GE.60.AND.NFTUNIT.LT.70) THEN PPCTL2.285
IF (FT_PLOTSEL(NFTUNIT).GE.1) THEN PPCTL2.286
IF (SMID.EQ.1) THEN PPCTL2.287
STEP_PP=(STEPim(a_im)-FT_FIRSTSTEP(NFTUNIT)) GDR5F305.143
& /FT_STEPS(NFTUNIT) PPCTL2.289
ELSE IF (SMID.EQ.2) THEN PPCTL2.290
STEP_PP=(STEPim(o_im)-FT_FIRSTSTEP(NFTUNIT)) GDR5F305.144
& /FT_STEPS(NFTUNIT) PPCTL2.292
ELSE IF (SMID.EQ.4) THEN WRB1F401.658
STEP_PP=(STEPim(w_im)-FT_FIRSTSTEP(NFTUNIT)) WRB1F401.659
& /FT_STEPS(NFTUNIT) WRB1F401.660
ENDIF PPCTL2.293
IF(MOD(STEP_PP,FT_PLOTSEL(NFTUNIT)).EQ.0) THEN PPCTL2.294
*IF DEF,MPP GLW2F402.52
IF (mype.eq.0) THEN GLW2F402.53
WRITE(8,100) OLDPPFILE GLW2F402.54
*IF DEF,T3E GBCCF404.35
call flush(8, icode) GBCCF404.36
*ELSE GBCCF404.37
close(8) GBCCF404.38
open(8, file=filename) GBCCF404.39
*ENDIF GBCCF404.40
ENDIF GLW2F402.55
*ELSE GLW2F402.56
WRITE(8,100) OLDPPFILE PPCTL2.295
close(8) GBCCF404.41
open(8, file=filename) GBCCF404.42
*ENDIF GLW2F402.57
ENDIF PPCTL2.296
ELSE PPCTL2.297
*IF DEF,MPP GLW2F402.58
IF (mype.eq.0) THEN GLW2F402.59
WRITE(8,110) OLDPPFILE GLW2F402.60
*IF DEF,T3E GBCCF404.43
call flush(8, icode) GBCCF404.44
*ELSE GBCCF404.45
close(8) GBCCF404.46
open(8, file=filename) GBCCF404.47
*ENDIF GBCCF404.48
ENDIF GLW2F402.61
*ELSE GLW2F402.62
WRITE(8,110) OLDPPFILE PPCTL2.298
close(8) GBCCF404.49
open(8, file=filename) GBCCF404.50
*ENDIF GLW2F402.63
ENDIF PPCTL2.299
ELSE PPCTL2.300
IF (TYPE_LETTER_1(NFTUNIT).EQ.'b') THEN GDR2F405.136
*IF DEF,MPP GLW2F402.64
IF (mype.eq.0) THEN GLW2F402.65
WRITE(8,130) OLDPPFILE GLW2F402.66
*IF DEF,T3E GBCCF404.51
call flush(8, icode) GBCCF404.52
*ELSE GBCCF404.53
close(8) GBCCF404.54
open(8, file=filename) GBCCF404.55
*ENDIF GBCCF404.56
ENDIF GLW2F402.67
*ELSE GLW2F402.68
WRITE(8,130) OLDPPFILE PPCTL2.302
close(8) GBCCF404.57
open(8, file=filename) GBCCF404.58
*ENDIF GLW2F402.69
ELSE PPCTL2.303
*IF DEF,MPP GLW2F402.70
IF (mype.eq.0) THEN GLW2F402.71
WRITE(8,110) OLDPPFILE GLW2F402.72
*IF DEF,T3E GBCCF404.59
call flush(8, icode) GBCCF404.60
*ELSE GBCCF404.61
close(8) GBCCF404.62
open(8, file=filename) GBCCF404.63
*ENDIF GBCCF404.64
ENDIF GLW2F402.73
*ELSE GLW2F402.74
WRITE(8,110) OLDPPFILE PPCTL2.304
close(8) GBCCF404.65
open(8, file=filename) GBCCF404.66
*ENDIF GLW2F402.75
ENDIF PPCTL2.305
ENDIF PPCTL2.306
ELSE PPCTL2.307
IF (NFTUNIT.GE.60.AND.NFTUNIT.LT.70) THEN PPCTL2.308
IF (FT_PLOTSEL(NFTUNIT).GE.1) THEN PPCTL2.309
IF (SMID.EQ.1) THEN PPCTL2.310
STEP_PP=(STEPim(a_im)-FT_FIRSTSTEP(NFTUNIT)) GDR5F305.145
& /FT_STEPS(NFTUNIT) PPCTL2.312
ELSE IF (SMID.EQ.2) THEN PPCTL2.313
STEP_PP=(STEPim(o_im)-FT_FIRSTSTEP(NFTUNIT)) GDR5F305.146
& /FT_STEPS(NFTUNIT) PPCTL2.315
ELSE IF (SMID.EQ.4) THEN WRB1F401.661
STEP_PP=(STEPim(w_im)-FT_FIRSTSTEP(NFTUNIT)) WRB1F401.662
& /FT_STEPS(NFTUNIT) WRB1F401.663
ENDIF PPCTL2.316
IF(MOD(STEP_PP,FT_PLOTSEL(NFTUNIT)).EQ.0) THEN PPCTL2.317
*IF DEF,MPP GLW2F402.76
IF (mype.eq.0) THEN GLW2F402.77
WRITE(8,120) OLDPPFILE GLW2F402.78
*IF DEF,T3E GBCCF404.67
call flush(8, icode) GBCCF404.68
*ELSE GBCCF404.69
close(8) GBCCF404.70
open(8, file=filename) GBCCF404.71
*ENDIF GBCCF404.72
ENDIF GLW2F402.79
*ELSE GLW2F402.80
WRITE(8,120) OLDPPFILE PPCTL2.318
close(8) GBCCF404.73
open(8, file=filename) GBCCF404.74
*ENDIF GLW2F402.81
ENDIF PPCTL2.319
ENDIF PPCTL2.320
ENDIF PPCTL2.321
ENDIF PPCTL2.322
IF (NFTUNIT.GE.60.AND.NFTUNIT.LT.70) THEN PPCTL2.323
IF (FT_WSSEND(NFTUNIT).EQ.'Y') THEN PPCTL2.324
*IF DEF,MPP GLW2F402.82
IF (mype.eq.0) THEN GLW2F402.83
WRITE(8,140) OLDPPFILE GLW2F402.84
*IF DEF,T3E GBCCF404.75
call flush(8, icode) GBCCF404.76
*ELSE GBCCF404.77
close(8) GBCCF404.78
open(8, file=filename) GBCCF404.79
*ENDIF GBCCF404.80
ENDIF GLW2F402.85
*ELSE GLW2F402.86
WRITE(8,140) OLDPPFILE PPCTL2.325
close(8) GBCCF404.81
open(8, file=filename) GBCCF404.82
*ENDIF GLW2F402.87
ENDIF PPCTL2.326
ENDIF PPCTL2.327
*IF DEF,MPP GLW2F402.88
IF (mype.eq.0) THEN GLW2F402.89
WRITE(8,150) OLDPPFILE GLW2F402.90
*IF DEF,T3E GBCCF404.83
call flush(8, icode) GBCCF404.84
*ELSE GBCCF404.85
close(8) GBCCF404.86
open(8, file=filename) GBCCF404.87
*ENDIF GBCCF404.88
ENDIF GLW2F402.91
*ELSE GLW2F402.92
WRITE(8,150) OLDPPFILE PPCTL2.328
close(8) GBCCF404.89
open(8, file=filename) GBCCF404.90
*ENDIF GLW2F402.93
ENDIF PPCTL2.329
100 FORMAT('%%% ',A14,' ARCHIVE PPCHART') PPCTL2.330
110 FORMAT('%%% ',A14,' ARCHIVE PPNOCHART') PPCTL2.331
120 FORMAT('%%% ',A14,' PLOTONLY PPCHART') PPCTL2.332
130 FORMAT('%%% ',A14,' ARCHIVE BNDY') PPCTL2.333
140 FORMAT('%%% ',A14,' HPSEND') PPCTL2.334
150 FORMAT('%%% ',A14,' DELETE') PPCTL2.335
CL PPCTL2.336
CL 2.2 Construct PPfile name from model information using defined PPCTL2.337
CL naming convention (INPUT files) PPCTL2.338
CL PPCTL2.339
IF (FT_INPUT(NFTUNIT).EQ.'Y') THEN PPCTL2.340
CALL GET_NAME(EXPT_ID_IN,JOB_ID_IN,SMID,MEANLEV,TOGGLE, PPCTL2.341
* FT_STEPS(NFTUNIT),TYPE_LETTER_1(NFTUNIT), PPCTL2.342
* TYPE_LETTER_3(NFTUNIT), PPCTL2.343
* MODEL_STATUS,TIME_CONVENTION,0,PPNAME,ICODE,CMESSAGE, GSS1F304.516
* LCAL360) GSS1F304.517
IF (ICODE.GT.0) GOTO 999 PPCTL2.345
ELSE PPCTL2.346
CL PPCTL2.347
CL 2.3 Construct PPfile name from model information using defined PPCTL2.348
CL naming convention (OUTPUT files) PPCTL2.349
CL PPCTL2.350
CALL GET_NAME(EXPT_ID,JOB_ID,SMID,MEANLEV,TOGGLE, PPCTL2.351
* FT_STEPS(NFTUNIT),TYPE_LETTER_1(NFTUNIT), PPCTL2.352
* TYPE_LETTER_3(NFTUNIT), PPCTL2.353
* MODEL_STATUS,TIME_CONVENTION,0,PPNAME,ICODE,CMESSAGE, GSS1F304.518
* LCAL360) GSS1F304.519
IF (ICODE.GT.0) GOTO 999 PPCTL2.355
ENDIF PPCTL2.356
CL PPCTL2.357
CL 2.4 Open file on unit NFTUNIT PPCTL2.358
CL PPCTL2.359
LEN_PPNAME=LEN(PPNAME) PPCTL2.360
CALL FILE_CLOSE(NFTUNIT,PPNAME,LEN_PPNAME,1,0,ICODE) GTD0F400.33
WRITE(6,*)'PPCTL: Opening new file ',PPNAME,' on unit ', GIE0F403.491
* NFTUNIT PPCTL2.363
LEN_PPNAME=LEN(PPNAME) PPCTL2.364
CALL FILE_OPEN(NFTUNIT,PPNAME,LEN_PPNAME,1,1,ICODE) GPB1F305.116
IF (ICODE.NE.0) THEN DR240293.974
CMESSAGE='PPCTL : Error opening new PPfile' DR240293.975
GO TO 999 ! Return DR240293.976
ENDIF DR240293.977
CL PPCTL2.367
CL 2.5 Update history file record for appropriate unit if new filename PPCTL2.368
CL PPCTL2.369
STRING=MODEL_FT_UNIT(NFTUNIT) PPCTL2.370
STRING(11:17)='$DATAM/' PPCTL2.371
STRING(18:31)=PPNAME PPCTL2.372
STRING(32:80)=' ' PPCTL2.373
MODEL_FT_UNIT(NFTUNIT)=STRING PPCTL2.374
CL PPCTL2.375
CL 2.6 Initialise the direct access LOOKUP headers if OUTPUT file PPCTL2.376
CL PPCTL2.377
CL (a) PP files PPCTL2.378
IF (TYPE_LETTER_1(NFTUNIT).EQ.'p') THEN PPCTL2.379
PPCTL2.380
*IF DEF,ATMOS PPCTL2.381
IF (SMID.EQ.1.AND.FT_OUTPUT(NFTUNIT).EQ.'Y') THEN PPCTL2.382
WRITE(6,*)'PPCTL: Initialising new file on unit ',NFTUNIT GIE0F403.492
CALL INIT_PP(NFTUNIT,TYPE_LETTER_1(NFTUNIT), TJ130293.4
* LEN1_LOOKUP,PP_LEN2_LOOK(NFTUNIT), PPCTL2.385
* A_FIXHD,A_INTHD,A_REALHD,A_LEVDEPC, PPCTL2.386
* LEN_FIXHD,A_LEN_INTHD,A_LEN_REALHD,A_LEN1_LEVDEPC, PPCTL2.387
* A_LEN2_LEVDEPC,ICODE,CMESSAGE) PPCTL2.388
ENDIF PPCTL2.389
*ENDIF PPCTL2.390
*IF DEF,OCEAN PPCTL2.391
IF (SMID.EQ.2.AND.FT_OUTPUT(NFTUNIT).EQ.'Y') THEN PPCTL2.392
WRITE(6,*)'PPCTL: Initialising new file on unit ',NFTUNIT GIE0F403.493
CALL INIT_PP(NFTUNIT,TYPE_LETTER_1(NFTUNIT), TJ130293.5
* LEN1_LOOKUP,PP_LEN2_LOOK(NFTUNIT), PPCTL2.395
* O_FIXHD,O_INTHD,O_REALHD,O_LEVDEPC, PPCTL2.396
* LEN_FIXHD,O_LEN_INTHD,O_LEN_REALHD,O_LEN1_LEVDEPC, PPCTL2.397
* O_LEN2_LEVDEPC,ICODE,CMESSAGE) PPCTL2.398
ENDIF PPCTL2.399
*ENDIF PPCTL2.400
*IF DEF,WAVE WRB1F401.664
IF (SMID.EQ.4.AND.FT_OUTPUT(NFTUNIT).EQ.'Y') THEN WRB1F401.665
WRITE(6,*)'PPCTL: Initialising new file on unit ',NFTUNIT GIE0F403.494
CALL INIT_PP(NFTUNIT,TYPE_LETTER_1(NFTUNIT), WRB1F401.667
* LEN1_LOOKUP,PP_LEN2_LOOK(NFTUNIT), WRB1F401.668
* W_FIXHD,W_INTHD,W_REALHD,W_LEVDEPC, WRB1F401.669
* LEN_FIXHD,W_LEN_INTHD,W_LEN_REALHD,W_LEN1_LEVDEPC, WRB1F401.670
* W_LEN2_LEVDEPC,ICODE,CMESSAGE) WRB1F401.671
ENDIF WRB1F401.672
*ENDIF WRB1F401.673
CL PPCTL2.401
CL (b) Boundary files PPCTL2.402
CL PPCTL2.403
ELSE IF (TYPE_LETTER_1(NFTUNIT).EQ.'b') THEN GDR2F405.137
C PPCTL2.405
IF (FT_OUTPUT(NFTUNIT).EQ.'Y') THEN PPCTL2.406
WRITE(6,*)'PPCTL: Initialising new boundary file on unit', GIE0F403.495
* NFTUNIT PPCTL2.408
GMB1F405.510
! Get interface area number GMB1F405.511
call intf_area( SMID, NFTUNIT, JINTF) GMB1F405.512
GMB1F405.513
*IF DEF,ATMOS GDR2F405.138
if ( SMID .eq. a_im ) then GDR2F405.139
CALL IN_INTF ( @DYALLOC.2941
*CALL ARGSIZE @DYALLOC.2942
*CALL ARGD1 @DYALLOC.2943
*CALL ARGDUMA @DYALLOC.2944
*CALL ARGINFA @DYALLOC.2945
* NFTUNIT,ICODE,CMESSAGE) @DYALLOC.2946
GDR2F405.140
IF (ICODE.GT.0) THEN GDR2F405.141
WRITE (6,*) ' PPCTL : Error in IN_INTF - Atmos.' GDR2F405.142
GO TO 999 ! Return GDR2F405.143
ENDIF GDR2F405.144
GDR2F405.145
endif ! if SMID GDR2F405.146
*ENDIF GDR2F405.147
*IF DEF,OCEAN,AND,-DEF,ATMOS GMB1F405.514
if ( SMID .eq. o_im ) then GMB1F405.515
GMB1F405.516
! Modset is required for IN_INTF to work for ocean GMB1F405.517
! until next release. GMB1F405.518
GMB1F405.519
CALL IN_INTF( GMB1F405.520
*CALL ADUMLENO GMB1F405.521
*CALL AINFLENO GMB1F405.522
*CALL ARGDUMO GMB1F405.523
*CALL AINTFO GMB1F405.524
*CALL ARGINFO GMB1F405.525
*CALL ARGPPX GMB1F405.526
& km, jmt, jmt-1, imt, GMB1F405.527
& SMID,NFTUNIT,JINTF,ICODE,CMESSAGE) GMB1F405.528
GMB1F405.529
IF (ICODE.GT.0) THEN GMB1F405.530
WRITE (6,*) ' PPCTL : Error in IN_INTF - Ocean.' GMB1F405.531
GO TO 999 ! Return GMB1F405.532
ENDIF GMB1F405.533
GMB1F405.534
end if ! SMID GMB1F405.535
*ENDIF GMB1F405.536
C ELSE PPCTL2.410
C This is where a new boundary input file should be read in PPCTL2.411
ENDIF PPCTL2.412
ENDIF PPCTL2.413
C PPCTL2.414
FT_LASTFIELD(NFTUNIT)=0 PPCTL2.416
C Close unit to release IO buffer if later reinitialisation indicated PPCTL2.417
LEN_PPNAME=LEN(PPNAME) PPCTL2.418
CALL FILE_CLOSE(NFTUNIT,PPNAME,LEN_PPNAME,1,0,ICODE) GTD0F400.34
C Set FT_ACTIVE if initialising first file of a sequence PPCTL2.420
C (i.e. not initialised from INITIAL but within the run) PPCTL2.421
C PPCTL2.422
IF (SMID.EQ.1) THEN PPCTL2.423
STEP = STEPim(a_im) GDR5F305.147
ELSE IF (SMID.EQ.2) THEN PPCTL2.425
STEP = STEPim(o_im) GDR5F305.148
ELSE IF (SMID.EQ.4) THEN WRB1F401.674
STEP = STEPim(w_im) WRB1F401.675
ENDIF PPCTL2.427
C PPCTL2.428
IF (STEP-1.EQ.FT_FIRSTSTEP(NFTUNIT)) THEN PPCTL2.429
C PPCTL2.430
FT_ACTIVE(NFTUNIT)='Y' PPCTL2.431
C PPCTL2.432
ELSE IF (TYPE_LETTER_1(NFTUNIT).EQ.'b') THEN GDR2F405.148
DR240293.991
! Get interface area number GMB1F405.537
call intf_area( SMID, NFTUNIT, JINTF) GMB1F405.538
IF (STEP-1+INTERFACE_STEPSim(JINTF,A_IM) .EQ. GDR5F305.149
* FT_FIRSTSTEP(NFTUNIT)) THEN DR240293.994
DR240293.995
FT_ACTIVE(NFTUNIT)='Y' DR240293.996
DR240293.997
END IF DR240293.998
DR240293.999
END IF PPCTL2.437
C PPCTL2.438
ENDIF PPCTL2.439
PPCTL2.440
END DO PPCTL2.441
CL---------------------------------------------------------------------- PPCTL2.442
ELSE ! MEANLEV not=0, so following deals with mean files GMG1F404.301
CL---------------------------------------------------------------------- PPCTL2.444
CL 3. If called to initialise mean PP files ... PPCTL2.445
CL Initialise only the relevant unit PPCTL2.446
CL PPCTL2.447
SMID=I_AO PPCTL2.448
*IF DEF,ATMOS PPCTL2.449
IF (SMID.EQ.1) THEN PPCTL2.450
NFTUNIT = FT_MEANim(A_IM) GDR3F305.149
ENDIF PPCTL2.452
*ENDIF PPCTL2.453
*IF DEF,OCEAN PPCTL2.454
IF (SMID.EQ.2) THEN PPCTL2.455
NFTUNIT = FT_MEANim(O_IM) GDR3F305.150
ENDIF PPCTL2.457
*ENDIF PPCTL2.458
*IF DEF,WAVE WRB1F401.676
IF (SMID.EQ.4) THEN WRB1F401.677
NFTUNIT = FT_MEANim(W_IM) WRB1F401.678
ENDIF WRB1F401.679
*ENDIF WRB1F401.680
CL PPCTL2.459
CL 3.1 Construct PPfile name from model information using defined PPCTL2.460
CL naming convention (OUTPUT files) PPCTL2.461
CL PPCTL2.462
CALL GET_NAME(EXPT_ID,JOB_ID,SMID,MEANLEV,TOGGLE, PPCTL2.463
* FT_STEPS(NFTUNIT),TYPE_LETTER_1(NFTUNIT), PPCTL2.464
* TYPE_LETTER_3(NFTUNIT), PPCTL2.465
* MODEL_STATUS,TIME_CONVENTION,0,PPNAME,ICODE,CMESSAGE, GSS1F304.520
* LCAL360) GSS1F304.521
IF (ICODE.GT.0) GOTO 999 PPCTL2.467
CL PPCTL2.468
CL 3.2 Open named file on unit NFTUNIT PPCTL2.469
CL PPCTL2.470
LEN_PPNAME=LEN(PPNAME) PPCTL2.471
CALL FILE_CLOSE(NFTUNIT,PPNAME,LEN_PPNAME,1,0,ICODE) GTD0F400.35
WRITE(6,*)'PPCTL: Opening new file ',PPNAME,' on unit ',NFTUNIT GIE0F403.496
LEN_PPNAME=LEN(PPNAME) PPCTL2.474
CALL FILE_OPEN(NFTUNIT,PPNAME,LEN_PPNAME,1,1,ICODE) GPB1F305.119
IF (ICODE.NE.0) THEN DR240293.1000
CMESSAGE='PPCTL : Error opening new PPfile' DR240293.1001
GO TO 999 ! Return DR240293.1002
ENDIF DR240293.1003
CL PPCTL2.477
CL 3.2.1 Update history file record PPCTL2.478
CL PPCTL2.479
STRING=MODEL_FT_UNIT(NFTUNIT) PPCTL2.480
! Check that a name exists in STRING(1:8), if not set from CENVIRDT GDR3F305.153
IF (STRING(1:8) .eq. ' ') THEN GDR3F305.154
STRING(1:8) = FT_ENVIRON(NFTUNIT) GDR3F305.155
STRING(9:9) = ':' GDR3F305.156
END IF GDR3F305.157
STRING(11:17)='$DATAM/' PPCTL2.481
STRING(18:31)=PPNAME PPCTL2.482
STRING(32:80)=' ' PPCTL2.483
MODEL_FT_UNIT(NFTUNIT)=STRING PPCTL2.484
CL PPCTL2.485
CL 3.3 Initialise the direct access LOOKUP headers (OUTPUT file) PPCTL2.486
CL PPCTL2.487
*IF DEF,ATMOS PPCTL2.488
IF (SMID.EQ.1) THEN PPCTL2.489
WRITE(6,*)'PPCTL: Initialising new file on unit ',NFTUNIT GIE0F403.497
CALL INIT_PP(NFTUNIT,TYPE_LETTER_1(NFTUNIT), TJ130293.6
* LEN1_LOOKUP,PP_LEN2_MEANim(MEANLEV,A_IM), GDR3F305.151
* A_FIXHD,A_INTHD,A_REALHD,A_LEVDEPC, PPCTL2.492
* LEN_FIXHD,A_LEN_INTHD,A_LEN_REALHD,A_LEN1_LEVDEPC, PPCTL2.493
* A_LEN2_LEVDEPC,ICODE,CMESSAGE) PPCTL2.494
IF (ICODE.GT.0) GOTO 999 PPCTL2.495
FT_LASTFIELD(NFTUNIT)=0 PPCTL2.496
ENDIF PPCTL2.497
*ENDIF PPCTL2.498
*IF DEF,OCEAN PPCTL2.499
IF (SMID.EQ.2) THEN PPCTL2.500
WRITE(6,*)'PPCTL: Initialising new file on unit ',NFTUNIT GIE0F403.498
CALL INIT_PP(NFTUNIT,TYPE_LETTER_1(NFTUNIT), TJ130293.8
* LEN1_LOOKUP,PP_LEN2_MEANim(MEANLEV,O_IM), GDR3F305.152
* O_FIXHD,O_INTHD,O_REALHD,O_LEVDEPC, PPCTL2.503
* LEN_FIXHD,O_LEN_INTHD,O_LEN_REALHD,O_LEN1_LEVDEPC, PPCTL2.504
* O_LEN2_LEVDEPC,ICODE,CMESSAGE) PPCTL2.505
IF (ICODE.GT.0) GOTO 999 WRB1F401.681
FT_LASTFIELD(NFTUNIT)=0 WRB1F401.682
ENDIF WRB1F401.683
*ENDIF WRB1F401.684
*IF DEF,WAVE WRB1F401.685
IF (SMID.EQ.4) THEN WRB1F401.686
WRITE(6,*)'PPCTL: Initialising new file on unit ',NFTUNIT GIE0F403.499
CALL INIT_PP(NFTUNIT,TYPE_LETTER_1(NFTUNIT), WRB1F401.688
* LEN1_LOOKUP,PP_LEN2_MEANim(MEANLEV,W_IM), WRB1F401.689
* W_FIXHD,W_INTHD,W_REALHD,W_LEVDEPC, WRB1F401.690
* LEN_FIXHD,W_LEN_INTHD,W_LEN_REALHD,W_LEN1_LEVDEPC, WRB1F401.691
* W_LEN2_LEVDEPC,ICODE,CMESSAGE) WRB1F401.692
IF (ICODE.GT.0) GOTO 999 PPCTL2.506
FT_LASTFIELD(NFTUNIT)=0 PPCTL2.507
ENDIF PPCTL2.508
*ENDIF PPCTL2.509
LEN_PPNAME=LEN(PPNAME) PPCTL2.510
CALL FILE_CLOSE(NFTUNIT,PPNAME,LEN_PPNAME,1,0,ICODE) GTD0F400.36
ENDIF PPCTL2.512
ENDIF PPCTL2.513
C----------------------------------------------------------------------- PPCTL2.514
999 RETURN DR240293.1004
END PPCTL2.525
*ENDIF PPCTL2.526