*IF DEF,C84_1A,OR,DEF,FLDMOD UIE3F404.26
C ******************************COPYRIGHT****************************** GTS2F400.4843
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.4844
C GTS2F400.4845
C Use, duplication or disclosure of this code is subject to the GTS2F400.4846
C restrictions as set forth in the contract. GTS2F400.4847
C GTS2F400.4848
C Meteorological Office GTS2F400.4849
C London Road GTS2F400.4850
C BRACKNELL GTS2F400.4851
C Berkshire UK GTS2F400.4852
C RG12 2SZ GTS2F400.4853
C GTS2F400.4854
C If no contract has been raised with this copy of the code, the use, GTS2F400.4855
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.4856
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.4857
C Modelling at the above address. GTS2F400.4858
C ******************************COPYRIGHT****************************** GTS2F400.4859
C GTS2F400.4860
CLL Routine: INIT_PP ------------------------------------------------- INITPP1A.3
CLL INITPP1A.4
CLL Purpose: Initialises direct access PP files at the start of INITPP1A.5
CLL the run. NB: Sequential PP files need no initialisation. INITPP1A.6
CLL INITPP1A.7
CLL Tested under compiler: cft77 INITPP1A.8
CLL Tested under OS version: UNICOS 5.1 INITPP1A.9
CLL INITPP1A.10
CLL Model Modification history from model version 3.0: INITPP1A.11
CLL version Date INITPP1A.12
CLL 3.1 12/02/93 Modify args to allow correct setting of PP_FIXHD(5) TJ130293.10
CLL 3.2 13/07/93 Changed CHARACTER*(*) to CHARACTER*(80) for TS150793.75
CLL portability. Author Tracey Smith. TS150793.76
CLL 3.3 05/10/93 Flush buffer of each pp file after initialisation RR051093.1
CLL to ensure complete file ready for re-start in the RR051093.2
CLL event of a 'hard' failure. R. Rawlins RR051093.3
!LL 4.3 30/04/97 Added code to use UM_SECTOR_SIZE to make transfers GBC0F403.43
!LL well-formed. GBC0F403.44
!LL B. Carruthers Cray Research. GBC0F403.45
CLL INITPP1A.13
CLL Programming standard: UM Doc Paper 3, version 1 (15/1/90) INITPP1A.14
CLL INITPP1A.15
CLL Logical components covered: D401 INITPP1A.16
CLL INITPP1A.17
CLL Project task: INITPP1A.18
CLL INITPP1A.19
CLL External documentation: On-line UM document C61 - Zonal mean INITPP1A.20
CLL calculations. INITPP1A.21
CLL INITPP1A.22
CLL ------------------------------------------------------------------- INITPP1A.23
C*L Interface and arguments: ------------------------------------------ INITPP1A.24
C INITPP1A.25
SUBROUTINE INIT_PP ( FTN_UNIT,FILE_TYPE_LETTER, 10,15TJ130293.11
& LEN1_LOOKUP,PP_LEN2_LOOKUP,FIXHD, TJ130293.12
1 INTHD,REALHD,LEVDEPC,LEN_FIXHD,LEN_INTHD, INITPP1A.27
2 LEN_REALHD,LEN1_LEVDEPC,LEN2_LEVDEPC, INITPP1A.28
3 ICODE,CMESSAGE) INITPP1A.29
C INITPP1A.30
IMPLICIT NONE INITPP1A.31
C INITPP1A.32
CHARACTER*1 TJ130293.13
& FILE_TYPE_LETTER ! IN - File type (p-PP, b-bndry) TJ130293.14
INTEGER INITPP1A.33
1 FTN_UNIT ! IN - Fortran unit number INITPP1A.34
2, LEN1_LOOKUP ! IN - Size of PP header INITPP1A.35
3, PP_LEN2_LOOKUP ! IN - Max allowable fields INITPP1A.36
4, LEN_FIXHD ! IN LENGTH OF FIXED CONSTANTS INITPP1A.37
5, LEN_INTHD ! IN LENGTH OF INTEGER CONSTANTS INITPP1A.38
6, LEN_REALHD ! IN LENGTH OF REAL CONSTANTS INITPP1A.39
7, LEN1_LEVDEPC ! IN LENGTH OF 1st Dim of lev depndt INITPP1A.40
8, LEN2_LEVDEPC ! IN LENGTH OF 2nd Dim of lev depndt INITPP1A.41
9, ICODE ! OUT - Error exit code INITPP1A.42
A, PP_LEN_INTHD ! OUT - Length of PP FILE integer header INITPP1A.43
B, PP_LEN_REALHD ! OUT - Length of PP FILE real header INITPP1A.44
C, PP_LEN2_LEVDEPC ! OUT - Length of 2nd dim of PP lev dep INITPP1A.45
C INITPP1A.46
PARAMETER INITPP1A.47
1 (PP_LEN_INTHD=15 INITPP1A.48
2, PP_LEN_REALHD=6 INITPP1A.49
3, PP_LEN2_LEVDEPC=4) INITPP1A.50
C INITPP1A.51
INTEGER INITPP1A.52
* FIXHD(LEN_FIXHD) ! IN ARRAY OF FIXED CONSTANTS INITPP1A.53
*, INTHD(LEN_INTHD) ! IN ARRAY OF integer CONSTANTS INITPP1A.54
*, LEVDEPC(LEN1_LEVDEPC*LEN2_LEVDEPC) ! IN LEV DEP CONSTANTS INITPP1A.55
*, PP_FIXHD(LEN_FIXHD) ! OUT ARRAY of fixed constants INITPP1A.56
*, PP_INTHD(PP_LEN_INTHD) ! OUT ARRAY of integer constants INITPP1A.57
*, PP_LEVDEPC(LEN1_LEVDEPC*PP_LEN2_LEVDEPC) ! OUT level dep cts INITPP1A.58
C INITPP1A.59
REAL INITPP1A.60
* REALHD(LEN_REALHD) ! IN ARRAY OF REAL CONSTANTS INITPP1A.61
*, PP_REALHD(PP_LEN_REALHD) ! OUT ARRAY OF REAL CONSTANTS INITPP1A.62
C INITPP1A.63
CHARACTER*80 TS150793.77
1 CMESSAGE ! OUT - Error message INITPP1A.65
C INITPP1A.66
C*---------------------------------------------------------------------- INITPP1A.67
C INITPP1A.68
C External subroutines INITPP1A.69
C INITPP1A.70
EXTERNAL SETPOS,IOERROR,POSERROR,BUFFOUT,FLUSH_BUFFER RR051093.4
C INITPP1A.72
C Local variables INITPP1A.73
C INITPP1A.74
INTEGER IPPLOOK(LEN1_LOOKUP,PP_LEN2_LOOKUP) INITPP1A.75
C GBC0F403.46
cdir$ cache_align pp_fixhd, pp_inthd, pp_realhd, pp_levdepc, ipplook GBC0F403.47
*CALL CNTL_IO 
GBC0F403.48
INTEGER INITPP1A.76
1 II,JJ,IWA,IX,LEN_IO,START_BLOCK ! INITPP1A.77
REAL A_IO INITPP1A.78
*CALL C_MDI UIE2F402.15
CL---------------------------------------------------------------------- INITPP1A.79
CL 1. Reserve space INITPP1A.80
CL INITPP1A.81
DO 1 II=1,PP_LEN2_LOOKUP INITPP1A.82
DO 2 JJ=1,LEN1_LOOKUP INITPP1A.83
IPPLOOK(JJ,II)=-99 INITPP1A.84
2 CONTINUE INITPP1A.85
1 CONTINUE INITPP1A.86
CL---------------------------------------------------------------------- INITPP1A.87
CL 1.1 Set up FIXED header record for the PP FILE INITPP1A.88
CL INITPP1A.89
DO 3 II=1,LEN_FIXHD INITPP1A.90
PP_FIXHD(II)=FIXHD(II) INITPP1A.91
3 CONTINUE INITPP1A.92
IF (FILE_TYPE_LETTER.EQ.'p') THEN TJ130293.15
PP_FIXHD(5)=3 TJ130293.16
ELSEIF (FILE_TYPE_LETTER.EQ.'b') THEN TJ130293.17
PP_FIXHD(5)=5 TJ130293.18
ELSE TJ130293.19
ICODE=100 TJ130293.20
CMESSAGE='INIT_PP : Unknown output file type letter' TJ130293.21
RETURN TJ130293.22
ENDIF TJ130293.23
PP_FIXHD(101)=PP_LEN_INTHD INITPP1A.93
PP_FIXHD(105)=PP_FIXHD(100)+PP_FIXHD(101) INITPP1A.94
PP_FIXHD(106)=PP_LEN_REALHD INITPP1A.95
PP_FIXHD(110)=PP_FIXHD(105)+PP_FIXHD(106) INITPP1A.96
PP_FIXHD(111)=LEN1_LEVDEPC INITPP1A.97
PP_FIXHD(112)=PP_LEN2_LEVDEPC INITPP1A.98
PP_FIXHD(115)=0 INITPP1A.99
PP_FIXHD(120)=0 INITPP1A.100
PP_FIXHD(125)=0 INITPP1A.101
PP_FIXHD(130)=0 INITPP1A.102
PP_FIXHD(135)=0 INITPP1A.103
PP_FIXHD(140)=0 INITPP1A.104
PP_FIXHD(142)=0 INITPP1A.105
PP_FIXHD(144)=0 INITPP1A.106
PP_FIXHD(150)=PP_FIXHD(110)+ PP_FIXHD(111)*PP_FIXHD(112) INITPP1A.107
PP_FIXHD(151)=LEN1_LOOKUP INITPP1A.108
PP_FIXHD(152)=PP_LEN2_LOOKUP INITPP1A.109
pp_fixhd(160)= ! make sure the data starts on a sector bndry GBC0F403.49
2 ((pp_fixhd(150)+pp_len2_lookup*len1_lookup+um_sector_size-1)/ GBC0F403.50
3 um_sector_size)*um_sector_size+1 GBC0F403.51
CL---------------------------------------------------------------------- INITPP1A.112
CL 1.2 Set up INTEGER constants record for the PP FILE INITPP1A.113
CL INITPP1A.114
IF(PP_FIXHD(5).LE.2) THEN ! set all values initially to MDI UIE2F402.16
DO II=1,PP_LEN_INTHD UIE2F402.17
PP_INTHD(II)=INTHD(21) UIE2F402.18
ENDDO UIE2F402.19
ELSE UIE2F402.20
DO II=1,PP_LEN_INTHD UIE2F402.21
PP_INTHD(II)=IMDI UIE2F402.22
ENDDO UIE2F402.23
ENDIF UIE2F402.24
UIE2F402.25
PP_INTHD(6)=INTHD(6) INITPP1A.118
PP_INTHD(7)=INTHD(7) INITPP1A.119
PP_INTHD(8)=INTHD(8) INITPP1A.120
PP_INTHD(9)=INTHD(9) INITPP1A.121
PP_INTHD(10)=INTHD(10) INITPP1A.122
PP_INTHD(13)=INTHD(13) INITPP1A.123
CL---------------------------------------------------------------------- INITPP1A.124
CL 1.3 Set up REAL constants record for the PP FILE INITPP1A.125
CL INITPP1A.126
PP_REALHD(1)=REALHD(1) INITPP1A.127
PP_REALHD(2)=REALHD(2) INITPP1A.128
PP_REALHD(3)=REALHD(3) INITPP1A.129
PP_REALHD(4)=REALHD(4) INITPP1A.130
PP_REALHD(5)=REALHD(5) INITPP1A.131
PP_REALHD(6)=REALHD(6) INITPP1A.132
CL---------------------------------------------------------------------- INITPP1A.133
CL 1.4 Set up LEVEL DEPENDANT constants record for the PP FILE INITPP1A.134
CL INITPP1A.135
DO 5 II=1,LEN1_LEVDEPC*PP_LEN2_LEVDEPC INITPP1A.136
PP_LEVDEPC(II)=LEVDEPC(II) INITPP1A.137
5 CONTINUE INITPP1A.138
CL---------------------------------------------------------------------- INITPP1A.139
CL 2.1 BUFFER OUT Header Records starting with the FIXED LENGTH INITPP1A.140
CL INITPP1A.141
CALL BUFFOUT(FTN_UNIT,PP_FIXHD(1),LEN_FIXHD,LEN_IO,A_IO) INITPP1A.142
IF(A_IO.NE.-1.0.OR.LEN_IO.NE.LEN_FIXHD) THEN INITPP1A.143
CALL IOERROR('bufferout of fixed length header',A_IO,LEN_IO, INITPP1A.144
& LEN_FIXHD) INITPP1A.145
CMESSAGE='INIT_PP:I/O error' INITPP1A.146
ICODE=1 INITPP1A.147
RETURN INITPP1A.148
ENDIF INITPP1A.149
START_BLOCK=LEN_FIXHD+1 INITPP1A.150
CL---------------------------------------------------------------------- INITPP1A.151
CL 2.2 BUFFER OUT Integer Constants INITPP1A.152
CL INITPP1A.153
INITPP1A.154
IF(FIXHD(100).GT.0) THEN ! Any integer constants to output ? INITPP1A.155
INITPP1A.156
C Check for error in file pointers INITPP1A.157
INITPP1A.158
C WRITE(6,*) 'START_BLOCK FIXHD(100)' INITPP1A.159
C WRITE(6,*) START_BLOCK INITPP1A.160
C WRITE(6,*) FIXHD(100) INITPP1A.161
C WRITE(6,*) FTN_UNIT INITPP1A.162
IF(FIXHD(100).NE.START_BLOCK) THEN ! Check start address INITPP1A.163
CALL POSERROR('integer constants',START_BLOCK,100, INITPP1A.164
& PP_FIXHD(100)) INITPP1A.165
CMESSAGE='INIT_PP: Addressing conflict' INITPP1A.166
ICODE=2 INITPP1A.167
RETURN INITPP1A.168
END IF INITPP1A.169
INITPP1A.170
CALL BUFFOUT (FTN_UNIT,PP_INTHD(1),PP_FIXHD(101),LEN_IO,A_IO) INITPP1A.171
INITPP1A.172
C Check for I/O errors INITPP1A.173
INITPP1A.174
IF(A_IO.NE.-1.0.OR.LEN_IO.NE.PP_FIXHD(101)) THEN INITPP1A.175
CALL IOERROR('buffer out of integer constants',A_IO,LEN_IO INITPP1A.176
& ,PP_FIXHD(101)) INITPP1A.177
CMESSAGE='INIT_PP: I/O Error' INITPP1A.178
ICODE=3 INITPP1A.179
RETURN INITPP1A.180
END IF INITPP1A.181
INITPP1A.182
START_BLOCK=START_BLOCK+PP_FIXHD(101) INITPP1A.183
INITPP1A.184
END IF INITPP1A.185
INITPP1A.186
CL---------------------------------------------------------------------- INITPP1A.187
CL 2.3 BUFFER OUT Real Constants INITPP1A.188
CL INITPP1A.189
INITPP1A.190
IF(PP_FIXHD(105).GT.0) THEN ! Any real constants to output ? INITPP1A.191
INITPP1A.192
C Check for error in file pointers INITPP1A.193
INITPP1A.194
IF(PP_FIXHD(105).NE.START_BLOCK) THEN INITPP1A.195
CALL POSERROR('real constants',START_BLOCK,100,PP_FIXHD(105)) INITPP1A.196
CMESSAGE='INIT_PP: Addressing conflict' INITPP1A.197
ICODE=4 INITPP1A.198
RETURN INITPP1A.199
END IF INITPP1A.200
INITPP1A.201
CALL BUFFOUT(FTN_UNIT,PP_REALHD(1),PP_FIXHD(106),LEN_IO,A_IO) INITPP1A.202
INITPP1A.203
C Check for I/O errors INITPP1A.204
INITPP1A.205
IF(A_IO.NE.-1.0.OR.LEN_IO.NE.PP_FIXHD(106)) THEN INITPP1A.206
CALL IOERROR('buffer out of real constants',A_IO,LEN_IO INITPP1A.207
& ,PP_FIXHD(106)) INITPP1A.208
CMESSAGE='INIT_PP: I/O Error' INITPP1A.209
ICODE=5 INITPP1A.210
RETURN INITPP1A.211
END IF INITPP1A.212
INITPP1A.213
START_BLOCK=START_BLOCK+PP_FIXHD(106) INITPP1A.214
INITPP1A.215
END IF INITPP1A.216
INITPP1A.217
CL---------------------------------------------------------------------- INITPP1A.218
CL 2.4 BUFFER OUT Level Dependant Constants. INITPP1A.219
CL INITPP1A.220
INITPP1A.221
IF(PP_FIXHD(112).GT.0) THEN ! Any level dependant constants ? INITPP1A.222
INITPP1A.223
C Check for error in file pointers INITPP1A.224
INITPP1A.225
IF(PP_FIXHD(110).NE.START_BLOCK) THEN INITPP1A.226
CALL POSERROR('real constants',START_BLOCK,100, INITPP1A.227
& PP_FIXHD(110)) INITPP1A.228
CMESSAGE='INIT_PP: Addressing conflict' INITPP1A.229
ICODE=6 INITPP1A.230
RETURN INITPP1A.231
END IF INITPP1A.232
INITPP1A.233
CALL BUFFOUT (FTN_UNIT,PP_LEVDEPC(1) INITPP1A.234
& ,PP_FIXHD(111)*PP_FIXHD(112),LEN_IO,A_IO) INITPP1A.235
INITPP1A.236
C Check for I/O errors INITPP1A.237
INITPP1A.238
IF(A_IO.NE.-1.0.OR.LEN_IO.NE.(PP_FIXHD(111)*PP_FIXHD(112) INITPP1A.239
& ))THEN INITPP1A.240
CALL IOERROR('buffer out of lev dep constants',A_IO,LEN_IO INITPP1A.241
& ,PP_FIXHD(111)) INITPP1A.242
CMESSAGE='INIT_PP: I/O Error' INITPP1A.243
ICODE=7 INITPP1A.244
RETURN INITPP1A.245
END IF INITPP1A.246
INITPP1A.247
START_BLOCK=START_BLOCK+ PP_FIXHD(111)*PP_FIXHD(112) INITPP1A.248
INITPP1A.249
END IF INITPP1A.250
CL---------------------------------------------------------------------- INITPP1A.251
CL 2.5 BUFFER OUT Lookup Table INITPP1A.252
CL INITPP1A.253
C IWA= 0 INITPP1A.254
C CALL SETPOS(FTN_UNIT,3,IWA,ICODE) GTD0F400.92
IF(PP_FIXHD(152).GT.0) THEN INITPP1A.256
INITPP1A.257
C Check for error in file pointers INITPP1A.258
INITPP1A.259
IF(PP_FIXHD(150).NE.START_BLOCK) THEN INITPP1A.260
CALL POSERROR('lookup table',START_BLOCK,100, INITPP1A.261
& PP_FIXHD(150)) INITPP1A.262
CMESSAGE='INIT_PP: Addressing conflict' INITPP1A.263
ICODE=8 INITPP1A.264
RETURN INITPP1A.265
END IF INITPP1A.266
INITPP1A.267
CALL BUFFOUT (FTN_UNIT, INITPP1A.268
* IPPLOOK(1,1),LEN1_LOOKUP*PP_LEN2_LOOKUP,LEN_IO,A_IO) INITPP1A.269
C INITPP1A.271
C Check for I/O errors INITPP1A.272
INITPP1A.273
IF(A_IO.NE.-1.0.OR.LEN_IO.NE.(PP_FIXHD(151)*PP_FIXHD(152))) INITPP1A.274
& THEN INITPP1A.275
CALL IOERROR('buffer out of PP LOOKUP TABLE ',A_IO,LEN_IO INITPP1A.276
& ,PP_FIXHD(152)) INITPP1A.277
CMESSAGE='INIT_PP: I/O Error' INITPP1A.278
ICODE=9 INITPP1A.279
RETURN INITPP1A.280
END IF INITPP1A.281
C RR051093.5
C Clear file buffer : force last buffer to be written to file RR051093.6
C to avoid problems with continuation runs following hard failures. RR051093.7
C RR051093.8
CALL FLUSH_BUFFER(FTN_UNIT,ICODE) RR051093.9
IF(ICODE.NE.0) THEN RR051093.10
CMESSAGE='INIT_PP: Problem flushing buffer' RR051093.11
ICODE=10 RR051093.12
RETURN RR051093.13
ENDIF RR051093.14
C RR051093.15
START_BLOCK=START_BLOCK+(PP_FIXHD(151)*PP_FIXHD(152)) INITPP1A.285
C RR051093.16
END IF INITPP1A.289
RETURN INITPP1A.290
END INITPP1A.291
INITPP1A.292
*ENDIF INITPP1A.293