PROGRAM FIELDCOS ,11FIELDCOS.33
IMPLICIT NONE FIELDCOS.34
C*--------------------------------------------------------------------- PS050793.13
C Called routines PS050793.14
EXTERNAL READFF,SETPOS,IOERROR,READ_WRITE FIELDCOS.35
C*--------------------------------------------------------------------- PS050793.15
C arguments for called routines PS050793.16
CHARACTER PS050793.17
& CMESSAGE*80 ! Error message from lower routines URS4F400.6
& ,INFILE*80 ! Pathname of input file. UIE1F402.36
& ,FORMAT_OUT*6 ! IBM/IEEE/VAX for output format URS4F400.7
! GRIB - pure binary grib stash codes URS4F400.8
! GRIB1 - pure binary grib - standard codes URS4F400.9
! GRIB2 - pure binary grib - Other table 2 URS4F400.10
LOGICAL PS050793.20
& UNPACK ! indicates whether to unpack PS050793.21
& ,OPER ! indicates whether operational PS050793.22
NAMELIST /PACK/ UNPACK,FORMAT_OUT FIELDCOS.40
NAMELIST /TYPE/ OPER PS050793.23
INTEGER PS050793.24
& LEN1_LOOKUP ! First dimension of the lookup PS050793.25
& ,PP_LEN2_LOOKUP ! Size of the LOOKUP on the file PS050793.26
& ,PPUNIT ! unit no of required fieldsfile PS050793.27
& ,COS_PPUNIT ! unit no of COS output file PS050793.28
& ,IEXTRA(10) ! spare for future use PS050793.29
& ,ICODE ! return code PS050793.30
& ,DATA_ADD ! The word address of the data. PS050793.31
& ,IWA ! Word address in call SETPOS PS050793.32
& ,LEN_IO ! Length of IO done PS050793.33
& ,LEN_FIXHD ! Length of fixed length header PS050793.34
PARAMETER(LEN_FIXHD=256) PS050793.35
INTEGER PS050793.36
& PP_FIXHD(LEN_FIXHD) ! Fixed length header PS050793.37
REAL PS050793.38
& A_IO ! status returned by BUFFIN PS050793.39
PARAMETER(LEN1_LOOKUP=64) PS050793.40
DATA UNPACK/.FALSE./ FIELDCOS.41
DATA FORMAT_OUT/'IBM '/ FIELDCOS.42
DATA OPER/.FALSE./ FIELDCOS.44
*CALL CHSUNITS 
! defines NUNITS PS050793.41
*CALL CGRIBTAB URS4F400.11
LOGICAL FLAG ! =T/F file exists/not PS050793.42
COMMON /FLAG_IO/FLAG(NUNITS) ! needed for BUFFIN check PS050793.43
C*--------------------------------------------------------------------- FIELDCOS.54
C LOCAL VARIABLES FIELDCOS.55
INTEGER FIELDCOS.56
& I ! local counter FIELDCOS.57
& ,IX ! used as a dummy variable in UNIT FIELDCOS.58
& ,ERR UIE1F402.34
& ,DIAG_UNIT UIE1F402.35
LOGICAL LCAL360 ! 360 day calendar switch GDR3F305.75
C Initialise LCAL360 GDR3F305.76
DATA LCAL360 /.FALSE./ GDR3F305.77
CHARACTER*80 DIAGFILE UIE1F402.70
C===================================================================== FIELDCOS.69
C REMEMBER THAT BUFFER OUT STARTS AT ADDRESS 0 THUS LOOKUP GOES FIELDCOS.70
C FROM 0 to 262143 ie THE NEXT ADDRESS SHOULD BE IWA=262144 to FIELDCOS.71
C IWA=325119 then IWA=325120 to 388095 then 388096 etc FIELDCOS.72
C===================================================================== FIELDCOS.73
READ(5,PACK) FIELDCOS.74
READ(5,TYPE) FIELDCOS.75
WRITE(6,*)' UNPACK ',UNPACK GIE0F403.151
WRITE(6,*)' FORMAT ',FORMAT_OUT GIE0F403.152
WRITE(6,*)' OPER ',OPER GIE0F403.153
DO I=1,10 PS050793.44
IEXTRA(I)=0 FIELDCOS.85
ENDDO FIELDCOS.86
UIE1F402.65
DIAG_UNIT = 7 UIE1F402.66
CALL GET_FILE(DIAG_UNIT,DIAGFILE,80,ICODE) UIE1F402.67
OPEN(UNIT=DIAG_UNIT,FILE=DIAGFILE) UIE1F402.68
UIE1F402.69
PPUNIT=10 FIELDCOS.87
COS_PPUNIT=11 FIELDCOS.88
! ------------------------------------------------------------------- URS4F400.12
! If FORMAT_OUT is GRIB1 or GRIB2 initialise grib field code URS4F400.13
! conversion table URS4F400.14
IF (FORMAT_OUT.EQ.'GRIB1') THEN URS4F400.15
CALL GRIB_TABLE_INIT1 URS4F400.16
ELSE IF (FORMAT_OUT.EQ.'GRIB2') THEN URS4F400.17
CALL GRIB_TABLE_INIT2 URS4F400.18
ENDIF URS4F400.19
CL-------------Read in the FIXED length header------------------------ FIELDCOS.90
CALL GET_FILE(PPUNIT,INFILE,80,ICODE) UIE1F402.37
CALL FILE_OPEN(PPUNIT,INFILE,80,0,1,ERR) UIE1F402.38
FLAG(PPUNIT)=.TRUE. ! needed for BUFFIN check FIELDCOS.92
CALL BUFFIN(PPUNIT,PP_FIXHD,LEN_FIXHD,LEN_IO,A_IO) FIELDCOS.93
IF(A_IO.NE.-1.0.OR.LEN_IO.NE.LEN_FIXHD) THEN FIELDCOS.94
CALL IOERROR('Buffer in fixed length header',A_IO,LEN_IO, FIELDCOS.95
& LEN_FIXHD) FIELDCOS.96
CMESSAGE='FIELDCOS : I/O error reading FIXED LENGTH HEADER' FIELDCOS.97
ICODE=2 FIELDCOS.98
WRITE(6,*)' I/O error reading FIXED LENGTH HEADER' GIE0F403.154
CALL ABORT(" FAILED IN FIELDCOS ") FIELDCOS.100
ENDIF FIELDCOS.101
DATA_ADD=PP_FIXHD(160)-1 ! Start address for the data. FIELDCOS.102
IWA= PP_FIXHD(150)-1 ! Start address for the lookup table. FIELDCOS.103
PP_LEN2_LOOKUP=PP_FIXHD(152) FIELDCOS.104
WRITE(6,*)' PP_LEN2_LOOKUP ',PP_LEN2_LOOKUP GIE0F403.155
WRITE(6,*)' dump type=',pp_fixhd(5), GIE0F403.156
* ' 3=fieldsfile,1=dump,2=time mean dump,4=ancil,5=bound' PS050793.47
CALL READ_WRITE(PP_LEN2_LOOKUP,LEN1_LOOKUP,DATA_ADD, FIELDCOS.106
& PP_FIXHD, FIELDCOS.107
& IWA,UNPACK,FORMAT_OUT,PPUNIT,COS_PPUNIT, FIELDCOS.108
& IEXTRA,OPER,ICODE,CMESSAGE,LCAL360) GSS1F304.294
IF(ICODE.NE.0) THEN FIELDCOS.110
CALL EREPORT(ICODE,CMESSAGE) FIELDCOS.111
CALL ABORT(" FAILED IN FIELDCOS ") FIELDCOS.112
ENDIF FIELDCOS.113
STOP FIELDCOS.114
END FIELDCOS.115
CLL Routine: READ_WRITE ----------------------------------------------- FIELDCOS.116
CLL FIELDCOS.117
CLL Purpose: To read a direct access PP file and convert it to a FIELDCOS.118
CLL sequential file read to be passed across to the IBM FIELDCOS.119
CLL FIELDCOS.120
CLL Tested under compiler: cft77 FIELDCOS.121
CLL Tested under OS version: UNICOS 5.1 FIELDCOS.122
CLL FIELDCOS.123
CLL Model Modification history from model version 3.0: FIELDCOS.124
CLL version Date FIELDCOS.125
CLL FIELDCOS.126
CLL Programming standard: UM Doc Paper 3, version 1 (15/1/90) FIELDCOS.127
CLL FIELDCOS.128
CLL Logical components covered: C41 FIELDCOS.129
CLL FIELDCOS.130
CLL Project task: C4 FIELDCOS.131
CLL FIELDCOS.132
CLL External documentation: UM Documentation paper C4 FIELDCOS.133
CLL FIELDCOS.134
CLL ------------------------------------------------------------------- FIELDCOS.135
C*L Interface and arguments: ------------------------------------------ FIELDCOS.136
C FIELDCOS.137
SUBROUTINE READ_WRITE(PP_LEN2_LOOKUP,LEN1_LOOKUP,DATA_ADD, 2,12FIELDCOS.138
& PP_FIXHD, FIELDCOS.139
& IWA,UNPACK,FORMAT_OUT,PPUNIT,COS_PPUNIT, FIELDCOS.140
& IEXTRA,OPER,ICODE,CMESSAGE,LCAL360) GSS1F304.295
IMPLICIT NONE FIELDCOS.142
C Arguments PS050793.48
CHARACTER PS050793.49
& FORMAT_OUT*6 ! IN IBM/IEEE/VAX format for output PS050793.50
& ,CMESSAGE*80 ! OUT error messages PS050793.51
& ,OUTFILE*80 ! OUT pathname of output file UIE1F402.64
LOGICAL PS050793.52
& UNPACK ! IN indicates whether to unpack PS050793.53
& ,OPER ! IN indicates whether operational PS050793.54
& ,LCAL360 GSS1F304.296
INTEGER PS050793.55
& LEN1_LOOKUP ! IN 1st dimension of LOOKUP PS050793.56
& ,PP_LEN2_LOOKUP ! IN 2nd dimension of LOOKUP PS050793.57
& ,PPUNIT ! IN unit no of required fieldsfile PS050793.58
& ,COS_PPUNIT ! IN unit no of COS output file PS050793.59
& ,DATA_ADD ! IN word address of the data. PS050793.60
& ,IEXTRA(10) ! IN Controls READFF PS050793.61
& ,IWA ! IN Word address in call SETPOS PS050793.62
& ,PP_FIXHD(*) ! IN PPfile fixed header PS050793.63
& ,ICODE ! OUT error code PS050793.64
PS050793.65
C*--------------------------------------------------------------------- PS050793.66
C Called routines PS050793.67
EXTERNAL READFF,SETPOS,CRAY_IBM,CRAY_VAX,CRAY_IEEE,IOERROR FIELDCOS.143
C*--------------------------------------------------------------------- PS050793.68
C arguments for called routines PS050793.69
LOGICAL FIELDCOS.149
& MODEL_FLAG ! flag - set to true if model dump PS050793.70
& ,LAST ! indicates last record process PS050793.71
INTEGER FIELDCOS.151
& LOOKUP(LEN1_LOOKUP,PP_LEN2_LOOKUP) ! integer lookup PS050793.72
& ,NUM_VALUES ! No of data points in a field PS050793.73
& ,IDIM ! NUM_VALUES rounded to an even no PS050793.74
C ! used to dimension the output array PS050793.75
& ,IEXTRAW ! The number of words of "extra" data. PS050793.76
& ,ENTRY_NO ! lookkup entry no of the Field. PS050793.77
& ,LEN_IO ! actual no of words transferred by IO. PS050793.78
& ,LEN_IO_EXPECTED ! expected no of words transferred by IO PS050793.79
REAL PS050793.80
& A_IO ! status returned by BUFFIN PS050793.81
*CALL CLOOKADD PS050793.82
C*--------------------------------------------------------------------- FIELDCOS.166
C LOCAL VARIABLES FIELDCOS.167
INTEGER FIELDCOS.168
& I ! local counter PS050793.83
& ,J ! local counter PS050793.84
& ,IX ! used as a dummy variable in UNIT PS050793.85
& ,ICOUNT ! Counter PS050793.86
& ,NENT ! No of entries in the printfile PS050793.87
& ,TOTAL_WORDS ! Total number of words output GRIB URS4F400.20
! option only URS4F400.21
PS050793.88
CL -----------Read in the LOOKUP table if first time thro------------ FIELDCOS.182
CALL SETPOS(PPUNIT,IWA,ICODE) GTD0F400.72
LEN_IO_EXPECTED=PP_LEN2_LOOKUP*LEN1_LOOKUP FIELDCOS.184
CALL BUFFIN(PPUNIT,LOOKUP,LEN_IO_EXPECTED,LEN_IO,A_IO) FIELDCOS.185
IF(A_IO.NE.-1.0.OR.LEN_IO.NE.LEN_IO_EXPECTED) THEN FIELDCOS.186
CALL IOERROR('Buffer in lookup table ',A_IO,LEN_IO, FIELDCOS.187
& LEN_IO_EXPECTED ) FIELDCOS.188
CMESSAGE='READ_W : I/O error reading LOOKUP TABLE ' FIELDCOS.189
ICODE=3 FIELDCOS.190
WRITE(6,*)' I/O error reading LOOKUP TABLE' GIE0F403.157
RETURN FIELDCOS.192
ENDIF FIELDCOS.193
PS050793.89
CL -----Having read the LOOKUP table Open the output COS File-------- FIELDCOS.194
CALL GET_FILE(COS_PPUNIT,OUTFILE,80,ICODE) UIE1F402.62
OPEN(UNIT=COS_PPUNIT,FILE=OUTFILE,FORM='UNFORMATTED') UIE1F402.63
NENT=0 FIELDCOS.196
PS050793.90
CL -----Calculate the number of fields in the File------------------- FIELDCOS.197
DO I=1,PP_LEN2_LOOKUP PS050793.91
IF(LOOKUP(LBROW,I).NE.-99) THEN FIELDCOS.199
NENT=NENT+1 FIELDCOS.200
ELSE FIELDCOS.201
GOTO 2 FIELDCOS.202
ENDIF FIELDCOS.203
ENDDO PS050793.92
2 CONTINUE FIELDCOS.205
WRITE(6,*)' THE NUMBER OF FIELDS IN THE INPUT FILE IS ', NENT GIE0F403.158
LAST=.FALSE. FIELDCOS.207
C-------------------------------------------------------------------- FIELDCOS.208
C Note LBROW=18,LBNPT=19 FIELDCOS.209
C For a DUMP LBLREC will hold original no of data points. FIELDCOS.210
C LBNREC will be set to zero. FIELDCOS.211
C FIELDCOS.212
C For a PP_file LBLREC will hold the no of CRAY words needed to hold FIELDCOS.213
C the data. The original field size will be rows*columns. FIELDCOS.214
C If the data is not packed then LBLREC=LBROW*LBNPT+LBEXT, where FIELDCOS.215
C LBEXT will be greater than 0 for timeseries (which are never packed). FIELDCOS.216
C !! WARNING LBEXT - may be -32768 MISSING VALUE !! PS050793.94
C--------------------------------------------------------------------- FIELDCOS.217
C FIELDCOS.218
CL -----Set MODEL_FLAG and reset UNPACK if DUMP --------------------- PS050793.95
IF(PP_FIXHD(5).NE.3) THEN PS050793.96
MODEL_FLAG=.TRUE. ! Model dump PS050793.97
UNPACK= .TRUE. ! cray 32 bit packed data unpacked PS050793.98
WRITE(6,*)'Model dump - UNPACK set TRUE ' GIE0F403.159
ELSE PS050793.100
MODEL_FLAG=.FALSE. ! Fieldsfile PS050793.101
ENDIF PS050793.102
IF(.NOT.UNPACK) IEXTRA(1)=1 ! DATA LEFT PACKED PS050793.103
PS050793.104
CL -----Loop thro all the entries within the field ------------------ FIELDCOS.219
DO I=1,NENT PS050793.105
IF(I.EQ.NENT) LAST=.TRUE. PS050793.106
IF(MODEL_FLAG) THEN FIELDCOS.225
NUM_VALUES=LOOKUP(LBLREC,I) ! NCOLS*NROWS FIELDCOS.226
ELSE FIELDCOS.227
NUM_VALUES=LOOKUP(LBROW,I)*LOOKUP(LBNPT,I)+LOOKUP(LBEXT,I) FIELDCOS.228
ENDIF FIELDCOS.229
IEXTRAW=0 PS050793.107
IF(LOOKUP(LBEXT,I).GT.0) THEN ! got some extra data PS050793.108
IEXTRAW=LOOKUP(LBEXT,I) PS050793.109
C check to see that we don't have packing if we have extra data.... FIELDCOS.232
IF(LOOKUP(LBROW,I)*LOOKUP(LBNPT,I)+LOOKUP(LBEXT,I) .NE. PS050793.110
& LOOKUP(LBLREC,I)) THEN PS050793.111
CMESSAGE='READ_WRT : Packing of extra data not supported' PS050793.112
ICODE=1 PS050793.113
RETURN FIELDCOS.237
ENDIF FIELDCOS.238
ENDIF FIELDCOS.239
IDIM=((NUM_VALUES+1)/2)*2 ! Round to ensur an integer for IBM PS050793.114
FIELDCOS.241
CL--------------------------------------------------------------------- FIELDCOS.242
CL If packed simply read in the field ie LBLREC words for PP_type FIELDCOS.243
CL files & for Dump type read LBLREC/2 if packed and LBLREC if not. FIELDCOS.244
CL All packed data is assumed real. If the data is to be un-packed FIELDCOS.245
CL then it is un-packed into an array size IDIM. IDIM is NROWS*NCOLS+ext FIELDCOS.246
CL rounded up to ensure it is even. If the data is not packed then it FIELDCOS.247
CL could be REAL,LOGICAL or INTEGER . FIELDCOS.248
CL-------------------------------------------------------------------- FIELDCOS.249
FIELDCOS.250
ICODE=0 FIELDCOS.251
ENTRY_NO=I FIELDCOS.252
IF(FORMAT_OUT.EQ.'IBM') THEN FIELDCOS.253
CALL CRAY_IBM(IDIM,NUM_VALUES,PPUNIT, FIELDCOS.254
& LEN1_LOOKUP,PP_LEN2_LOOKUP,PP_FIXHD,LOOKUP, FIELDCOS.255
& LOOKUP,ENTRY_NO,DATA_ADD,MODEL_FLAG, PS050793.115
& COS_PPUNIT,IEXTRA,IEXTRAW,LAST,OPER, FIELDCOS.257
& ICODE,CMESSAGE,LCAL360) GSS1F304.297
ELSEIF(FORMAT_OUT.EQ.'VAX') THEN FIELDCOS.259
CALL CRAY_VAX(IDIM,NUM_VALUES,PPUNIT, FIELDCOS.260
& LEN1_LOOKUP,PP_LEN2_LOOKUP,PP_FIXHD,LOOKUP, FIELDCOS.261
& LOOKUP,ENTRY_NO,DATA_ADD,MODEL_FLAG, PS050793.116
& COS_PPUNIT,IEXTRA,IEXTRAW,LAST,OPER, FIELDCOS.263
& ICODE,CMESSAGE,LCAL360) GSS1F304.298
ELSEIF(FORMAT_OUT.EQ.'IEEE') THEN FIELDCOS.265
CALL CRAY_IEEE(IDIM,NUM_VALUES,PPUNIT, FIELDCOS.266
& LEN1_LOOKUP,PP_LEN2_LOOKUP,PP_FIXHD,LOOKUP, PS050793.117
& LOOKUP,ENTRY_NO,DATA_ADD,MODEL_FLAG, PS050793.118
& COS_PPUNIT,IEXTRA,IEXTRAW,LAST,OPER, PS050793.119
& ICODE,CMESSAGE,LCAL360) GSS1F304.299
ELSEIF(FORMAT_OUT.EQ.'GRIB'.OR.FORMAT_OUT.EQ.'GRIB1'.OR. URS4F400.22
& FORMAT_OUT.EQ.'GRIB2') THEN URS4F400.23
TOTAL_WORDS=0 URS4F400.24
CALL CRAY_GRIB(IDIM,PPUNIT,TOTAL_WORDS,FORMAT_OUT, URS4F400.25
& LEN1_LOOKUP,PP_LEN2_LOOKUP,PP_FIXHD,LOOKUP, URS4F400.26
& LOOKUP,ENTRY_NO,DATA_ADD,MODEL_FLAG, URS4F400.27
& COS_PPUNIT,IEXTRA,ICODE,CMESSAGE) URS4F400.28
ELSE FIELDCOS.271
ICODE=1 FIELDCOS.272
CMESSAGE= ' OUTPUT FORMAT NOT YET AVAILABLE ' FIELDCOS.273
ENDIF FIELDCOS.274
IF(ICODE.NE.0) THEN FIELDCOS.275
RETURN FIELDCOS.276
ENDIF FIELDCOS.277
ENDDO PS050793.121
RETURN FIELDCOS.280
END FIELDCOS.281
CLL Routine: CRAY_IBM------------------------------------------------- FIELDCOS.283
CLL FIELDCOS.284
CLL Purpose: To read a direct access PP file and convert it to a FIELDCOS.285
CLL sequential file read to be passed across to the IBM FIELDCOS.286
CLL FIELDCOS.287
CLL Tested under compiler: cft77 FIELDCOS.288
CLL Tested under OS version: UNICOS 5.1 FIELDCOS.289
CLL FIELDCOS.290
CLL Model Modification history from model version 3.0: FIELDCOS.291
CLL version Date FIELDCOS.292
CLL 4.5 24/7/98 Change to output land sea mask as a real field (as a URR2F405.1
CLL special case). Rick Rawlins URR2F405.2
CLL FIELDCOS.293
CLL Programming standard: UM Doc Paper 3, version 1 (15/1/90) FIELDCOS.294
CLL FIELDCOS.295
CLL Logical components covered: C41 FIELDCOS.296
CLL FIELDCOS.297
CLL Project task: C4 FIELDCOS.298
CLL FIELDCOS.299
CLL External documentation: FIELDCOS.300
CLL FIELDCOS.301
CLL ------------------------------------------------------------------- FIELDCOS.302
C*L Interface and arguments: ------------------------------------------ FIELDCOS.303
C FIELDCOS.304
SUBROUTINE CRAY_IBM(IDIM,NUM_VALUES,PPUNIT, 1,7FIELDCOS.305
& LEN1_LOOKUP,PP_LEN2_LOOKUP,PP_FIXHD,LOOKUP, FIELDCOS.306
& ROOKUP,ENTRY_NO,DATA_ADD,MODEL_FLAG, PS050793.122
& COS_PPUNIT,IEXTRA,IEXTRAW,LAST,OPER, PS050793.123
& ICODE,CMESSAGE,LCAL360) GSS1F304.300
IMPLICIT NONE FIELDCOS.309
C Arguments PS050793.125
CHARACTER PS050793.126
& CMESSAGE*(*) !OUT error messages PS050793.127
LOGICAL PS050793.128
& LAST !IN indicates last record process PS050793.129
& ,OPER !IN indicates whether operational PS050793.130
& ,MODEL_FLAG !IN True => dumps, False => fieldsfile PS050793.131
& ,LCAL360 GSS1F304.301
INTEGER PS050793.132
& PPUNIT !IN unit no of required fieldsfile PS050793.133
& ,COS_PPUNIT !IN unit no of COS output file PS050793.134
& ,NUM_VALUES !IN No of data points NROWS*NCOLS PS050793.135
& ,IDIM !IN NUM_VALUES rounded to an even no PS050793.136
C ! used to dimension The output array PS050793.137
& ,DATA_ADD !IN The word address of the data. PS050793.138
& ,LEN1_LOOKUP !IN First dimension of the lookup PS050793.139
& ,PP_LEN2_LOOKUP !IN Size of the LOOKUP on the file PS050793.140
& ,IEXTRA(10) !IN Used within READFF PS050793.141
& ,IEXTRAW !IN no of words of extra data. PS050793.142
& ,ENTRY_NO !IN Lookup entry no of the Field. PS050793.143
& ,PP_FIXHD(*) !IN PPfile fixed header PS050793.144
& ,LOOKUP(LEN1_LOOKUP,PP_LEN2_LOOKUP) !IN integer lookup PS050793.145
& ,ICODE !OUT error code PS050793.146
REAL PS050793.147
& ROOKUP(LEN1_LOOKUP,PP_LEN2_LOOKUP) !IN Real lookup PS050793.148
C*--------------------------------------------------------------------- PS050793.149
C Called routines PS050793.150
EXTERNAL READFF,INT_FROM_REAL,CRI2IBM,TIME2SEC,SEC2TIME UIE1F402.1
INTEGER INT_FROM_REAL,CRI2IBM UIE1F402.2
C*--------------------------------------------------------------------- PS050793.152
C arguments for called routines PS050793.153
INTEGER FIELDCOS.315
& MAX_LEN_ILABEL ! maximum length of INT part of pp header PS050793.154
& ,MAX_LEN_RLABEL ! maximum length of REAL part of pp header PS050793.155
PARAMETER (MAX_LEN_ILABEL=45,MAX_LEN_RLABEL=32) PS050793.156
INTEGER FIELDCOS.331
& END_YEAR ! ) PS050793.157
& ,END_MONTH ! ) PS050793.158
& ,END_DAY ! ) arguments PS050793.159
& ,END_HOUR ! ) PS050793.160
& ,END_MINUTE ! ) for PS050793.161
& ,END_SECOND ! ) PS050793.162
& ,END_DAY_NUMBER ! ) TJ080294.54
& ,END_TIME_DAYS ! ) TJ080294.55
& ,END_TIME_SECS ! ) date/time PS050793.163
& ,START_TIME_SECS ! ) PS050793.164
& ,START_TIME_DAYS ! ) TJ080294.56
& ,DATA_YEAR ! ) conversion PS050793.165
& ,DATA_MONTH ! ) PS050793.166
& ,DATA_DAY ! ) when PS050793.167
& ,DATA_HOUR ! ) PS050793.168
& ,DATA_MINUTE ! ) OPER is TRUE PS050793.169
& ,DATA_SECOND ! ) PS050793.170
& ,DATA_DAY_NUMBER ! ) PS050793.171
& ,ADDR ! address in fld, used to process extra data PS050793.172
& ,IBM_ADDR ! address in ibm fld where extra data going. PS050793.173
& ,BIT_OFF ! what bit offset are we using PS050793.174
C (32 for odd, 0 for even values of addr) PS050793.175
& ,IER ! error RETURN CODE from conversion PS050793.176
& ,IV ! value of integer code for vectors PS050793.177
& ,LEN_ILABEL ! number of values in ILABEL PS050793.178
& ,LEN_RLABEL ! number of values in RLABEL PS050793.179
& ,DATA_VALUES ! number of values in real extra data PS050793.180
& ,ILABEL(MAX_LEN_ILABEL) ! holds integer part of LOOKUP PS050793.181
& ,IBM_LABEL((LEN1_LOOKUP+1)/2) ! holds IBM conversion of LABEL PS050793.182
PS050793.183
REAL FIELDCOS.334
& FIELD(IDIM) ! array holding data PS050793.184
& ,IBM_FIELD(IDIM/2) ! array holding IBM data PS050793.185
& ,RLABEL(MAX_LEN_RLABEL) ! holds real part of LOOKUP PS050793.186
PS050793.187
*CALL CLOOKADD PS050793.188
C*--------------------------------------------------------------------- FIELDCOS.340
C LOCAL VARIABLES FIELDCOS.341
INTEGER FIELDCOS.342
& I ! local counter PS050793.189
& ,PACK_TYPE ! packing type N1 of LBPACK PS050793.190
& ,DATA_COMP ! data compression code FIELDCOS.371
& ,DATA_COMP_DEF ! data compression definition FIELDCOS.372
& ,NUMBER_FORMAT ! number format FIELDCOS.373
& ,FCST_PRD PS050793.191
FIELDCOS.374
LOGICAL PACKED ! indicates whether the data is packed PS050793.192
FIELDCOS.376
PS050793.193
FIELDCOS.378
DO 1 I=1,IDIM ! make sure FIELD is initialised. An odd FIELDCOS.379
FIELD(I)=0.0 ! number of points might upset conversion FIELDCOS.380
1 CONTINUE FIELDCOS.381
PACKED=.FALSE. FIELDCOS.382
FIELDCOS.383
CL access the Fields File. FIELDCOS.384
CALL READFF(PPUNIT,FIELD,IDIM,ENTRY_NO, FIELDCOS.385
*ILABEL,RLABEL,IEXTRA,PP_LEN2_LOOKUP,LEN1_LOOKUP, FIELDCOS.386
*PP_FIXHD,LOOKUP,ROOKUP,DATA_ADD, PS050793.194
*MODEL_FLAG,MAX_LEN_ILABEL,MAX_LEN_RLABEL, PS050793.195
*LEN_ILABEL,LEN_RLABEL, PS050793.196
*ICODE,CMESSAGE) PS050793.197
C FIELDCOS.388
IF(ICODE.NE.0) RETURN FIELDCOS.389
FIELDCOS.390
C----------------------------------------------------------------- FIELDCOS.391
FIELDCOS.392
C The data has now been read in and has 1) Been read in packed FIELDCOS.393
C and left packed or 2) read in as packed and then un-packed or FIELDCOS.394
C 3) The data was never packed at all. If packed FIELD will have FIELDCOS.395
C LBLREC/2 values if a DUMP and LBLREC values if a PP_FILE. If FIELDCOS.396
C the data is not packed FIELD will have the no of data points FIELDCOS.397
C length LBROW*LBNPT+LBEXT if a pp_file and LBLREC if a dump file. FIELDCOS.398
C FIELDCOS.399
C For a dump LBLREC will hold origonal no of data points. For a FIELDCOS.400
C pp_file LBLREC will hold the no of CRAY words needed to hold FIELDCOS.401
C the data (if un-packed also no of data points) FIELDCOS.402
C FIELDCOS.403
C The value returned in ILABEL(LBLREC) may have to change because FIELDCOS.404
C the IBM only has a 32 bit word length compared to the CRAY's 64 FIELDCOS.405
C bit word length. On the IBM ILABEL(LBLREC) will be no of IBM FIELDCOS.406
C words needed to hold the data . If the data is not packed (or FIELDCOS.407
C it has been un-packed) then this will be the no of data points. FIELDCOS.408
C If the data is left packed the value of ILABEL(LBLREC) on the FIELDCOS.409
C IBM will have to be doubled as the no of IBM words needed to FIELDCOS.410
C hold the data will twice that on the CRAY. FIELDCOS.411
FIELDCOS.412
C On output the data will either have been converted to IBM FIELDCOS.413
C numbers and stored in IBM_FIELD or left packed in FIELD. If packed FIELDCOS.414
C then LBLREC/2 words of FIELD are written as LBLREC is now FIELDCOS.415
C the no of IBM words. If un-packed IBM_FIELD which has size FIELDCOS.416
C IDIM/2 (or NUM_VALUES/2) is written as it is. FIELDCOS.417
FIELDCOS.418
C----------------------------------------------------------------- FIELDCOS.419
c decode LBPACK FIELDCOS.420
PACK_TYPE = MOD(ILABEL(LBPACK),10) FIELDCOS.421
DATA_COMP = MOD(ILABEL(LBPACK),100) - PACK_TYPE FIELDCOS.422
DATA_COMP_DEF = MOD(ILABEL(LBPACK),1000) -DATA_COMP -PACK_TYPE FIELDCOS.423
NUMBER_FORMAT = ILABEL(LBPACK)/1000 FIELDCOS.424
FIELDCOS.425
IF(PACK_TYPE.GT.0) PACKED=.TRUE. FIELDCOS.426
IF(PACKED) THEN ! Data left in packed form. Number of PS290193.2
ILABEL(LBLREC)=ILABEL(LBLREC)*2 ! IBM words needed is 2*CRAY PS290193.3
ENDIF FIELDCOS.437
C verify that don't have extra data and packing at once FIELDCOS.438
IF (IEXTRAW.GT.0.AND.PACKED) THEN FIELDCOS.439
CMESSAGE='FIELDCOS: Extra data with packing not supported' FIELDCOS.440
ICODE=1 FIELDCOS.441
RETURN FIELDCOS.442
ENDIF FIELDCOS.443
FIELDCOS.444
CL Convert ILABEL to IBM(Hitachi) integers. FIELDCOS.445
C For either an accumulation or time mean (ie LBTIM.ne.0) the start & FIELDCOS.446
C end time are in a different order to the data and veri time for a FIELDCOS.447
C snap shot type field. This anomaly has to be catered for operational FIELDCOS.448
C use. Thus the PP package will not work properly on accum/time mn field FIELDCOS.449
C for operational Fields files. FIELDCOS.450
IF(ILABEL(LBTIM).NE.11.AND.OPER) THEN PS050793.198
C re -calculate the data time from the end time and fcst period FIELDCOS.452
C First calculate the no of seconds from day 0 FIELDCOS.453
END_YEAR=ILABEL(LBYRD) FIELDCOS.454
END_MONTH=ILABEL(LBMOND) FIELDCOS.455
END_DAY=ILABEL(LBDATD) FIELDCOS.456
END_HOUR=ILABEL(LBHRD) FIELDCOS.457
END_MINUTE=ILABEL(LBMIND) FIELDCOS.458
END_DAY_NUMBER=ILABEL(LBDAYD) TJ080294.75
END_SECOND=0 PS190494.3
FCST_PRD=ILABEL(LBFT) FIELDCOS.460
C WRITE(6,*)' START YR/MO/DA/HR/MIN BEFORE ',ILABEL(1),ILABEL(2), GIE0F403.160
C * ILABEL(3),ILABEL(4),ILABEL(5) FIELDCOS.462
C WRITE(6,*)' END YR/MO/DA/HR/MIN BEFORE ',ILABEL(7),ILABEL(8), GIE0F403.161
C * ILABEL(9),ILABEL(10),ILABEL(11) FIELDCOS.464
C WRITE(6,*)' FCST_PRD BEFORE ',FCST_PRD GIE0F403.162
CALL TIME2SEC (END_YEAR,END_MONTH,END_DAY,END_HOUR, FIELDCOS.466
* END_MINUTE,END_SECOND,0,0, TJ080294.57
* END_TIME_DAYS,END_TIME_SECS,LCAL360) GSS1F304.302
FIELDCOS.468
C Subtract forecast hours from end time in (days,seconds) TJ080294.84
TJ080294.85
CALL TIME_DF(END_TIME_DAYS,END_TIME_SECS,0,-FCST_PRD*3600, TJ080294.86
* START_TIME_DAYS,START_TIME_SECS) TJ080294.87
FIELDCOS.470
C Go back and re-calculate Year/Month/Day/Hour/Sec. FIELDCOS.471
CALL SEC2TIME(0,0,START_TIME_DAYS,START_TIME_SECS, TJ080294.59
* DATA_YEAR,DATA_MONTH,DATA_DAY, TJ080294.60
* DATA_HOUR,DATA_MINUTE,DATA_SECOND,DATA_DAY_NUMBER, GSS1F304.303
* LCAL360) GSS1F304.304
ILABEL(LBYRD)=DATA_YEAR FIELDCOS.475
ILABEL(LBMOND)=DATA_MONTH FIELDCOS.476
ILABEL(LBDATD)=DATA_DAY FIELDCOS.477
ILABEL(LBHRD)=DATA_HOUR FIELDCOS.478
ILABEL(LBMIND)=DATA_MINUTE FIELDCOS.479
ILABEL(LBDAYD)=DATA_DAY_NUMBER TJ080294.76
ILABEL(LBYR)=END_YEAR FIELDCOS.480
ILABEL(LBMON)=END_MONTH FIELDCOS.481
ILABEL(LBDAT)=END_DAY FIELDCOS.482
ILABEL(LBHR)=END_HOUR FIELDCOS.483
ILABEL(LBMIN)=END_MINUTE FIELDCOS.484
ILABEL(LBDAY)=END_DAY_NUMBER TJ080294.77
C WRITE(6,*)' -----------------------------------------------' GIE0F403.163
C WRITE(6,*)' Veri YR/MO/DA/HR/MIN AFTER ',ILABEL(1),ILABEL(2), GIE0F403.164
C * ILABEL(3),ILABEL(4),ILABEL(5) FIELDCOS.487
C WRITE(6,*)' Data YR/MO/DA/HR/MIN AFTER ',ILABEL(7),ILABEL(8), GIE0F403.165
C * ILABEL(9),ILABEL(10),ILABEL(11) FIELDCOS.489
C WRITE(6,*)' FCST_PRD AFTER ',FCST_PRD GIE0F403.166
C WRITE(6,*)' -----------------------------------------------' GIE0F403.167
C WRITE(6,*)' -----------------------------------------------' GIE0F403.168
ENDIF FIELDCOS.493
if(oper) then PS050793.199
C new fix added 3.2 to correct max/min temp M08 codes PS050793.200
IF(ILABEL(LBTYP).EQ.58) THEN PS050793.201
WRITE(6,*)'fix to type=',ilabel(lbtyp),' proc=',ilabel(lbproc) GIE0F403.169
C check lbproc for max or min PS050793.203
IF(ILABEL(LBPROC).EQ.4096) ILABEL(LBTYP)=157 ! MIN PS050793.204
IF(ILABEL(LBPROC).EQ.8192) ILABEL(LBTYP)=156 ! MAX PS050793.205
WRITE(6,*)' type=',ilabel(lbtyp) GIE0F403.170
ENDIF PS050793.207
ENDIF PS050793.208
FIELDCOS.494
C now native format for front-end FIELDCOS.495
ILABEL(LBPACK) = ILABEL(LBPACK) -NUMBER_FORMAT*1000 FIELDCOS.496
C FIELDCOS.497
C should really be ibm format but access not ready on front-end PS050793.209
C ILABEL(LBPACK) = ILABEL(LBPACK) -NUMBER_FORMAT*1000 + 1000 FIELDCOS.499
FIELDCOS.500
CL Convert ILABEL to IBM(Hitachi) Integers PS050793.210
BIT_OFF = 0 FIELDCOS.501
IBM_ADDR=1 PS050793.211
IER = CRI2IBM(2,LEN_ILABEL,IBM_LABEL(IBM_ADDR),BIT_OFF,ILABEL, UIE1F402.3
& 1,64,32) UIE1F402.4
IF(IER.NE.0) THEN FIELDCOS.503
ICODE=1 FIELDCOS.504
CMESSAGE=' CRAY_IBM error converting INT for IBM_LABEL' PS050793.213
RETURN FIELDCOS.506
ENDIF FIELDCOS.507
CL Convert RLABEL to IBM(Hitachi) Real. FIELDCOS.508
IBM_ADDR=LEN_ILABEL/2 PS050793.214
IF(IBM_ADDR*2.NE.LEN_ILABEL) BIT_OFF=32 PS050793.215
IBM_ADDR=IBM_ADDR+1 PS050793.216
IER = CRI2IBM(3,LEN_RLABEL,IBM_LABEL(IBM_ADDR),BIT_OFF,RLABEL, UIE1F402.5
& 1,64,32) UIE1F402.6
IF(IER.NE.0) THEN FIELDCOS.511
ICODE=1 FIELDCOS.512
CMESSAGE=' CRAY_IBM error converting REAL for IBM_LABEL' PS050793.218
RETURN FIELDCOS.514
ENDIF FIELDCOS.515
BIT_OFF = 0 PS050793.219
IF(.NOT.PACKED) THEN FIELDCOS.516
CL Convert Real DATA to IBM(Hitachi) Real if not packed. FIELDCOS.517
IF(ILABEL(DATA_TYPE).EQ.1) THEN !Data Type Real FIELDCOS.518
if(ilabel(32).eq.74) then APS2F304.9
! Output land sea mask as a real field. This is defined as a logical in URR2F405.3
! the model, but STASH cannot currently handle logical fields on output URR2F405.4
! and it is output unconverted by STASH, but with the datatype URR2F405.5
! hardwired to 1 to indicate real. URR2F405.6
WRITE(6,*) 'Convert type 74 (=landsea mask) from logical', URR2F405.7
& ' to real. Datatype already labelled as real.' URR2F405.8
CALL LOGICAL_TO_REAL(IDIM,FIELD,FIELD,NUM_VALUES, URR2F405.9
& ILABEL,ICODE,CMESSAGE) URR2F405.10
endif URR2F405.11
IER = CRI2IBM(3,NUM_VALUES-IEXTRAW,IBM_FIELD,BIT_OFF,FIELD, UIE1F402.9
& 1,64,32) UIE1F402.10
IF(IER.NE.0) THEN FIELDCOS.520
ICODE=1 FIELDCOS.521
CMESSAGE='CRAY_IBM error converting real for IBM_FIELD' FIELDCOS.522
RETURN FIELDCOS.523
ENDIF FIELDCOS.524
CL Convert Integer data to IBM(Hitachi) Integer. FIELDCOS.525
ELSEIF(ILABEL(DATA_TYPE).EQ.2) THEN !Data Type Integer PS050793.220
IER = CRI2IBM(2,NUM_VALUES-IEXTRAW,IBM_FIELD,BIT_OFF,FIELD, UIE1F402.11
& 1,64,32) UIE1F402.12
IF(IER.NE.0) THEN FIELDCOS.528
ICODE=1 FIELDCOS.529
CMESSAGE='CRAY_IBM error converting int for IBM_FIELD' FIELDCOS.530
RETURN FIELDCOS.531
ENDIF FIELDCOS.532
ELSEIF(ILABEL(DATA_TYPE).EQ.3) THEN !Data Type Logical PS050793.221
IER = CRI2IBM(5,NUM_VALUES-IEXTRAW,IBM_FIELD,BIT_OFF,FIELD, UIE1F402.13
& 1,64,32) UIE1F402.14
IF(IER.NE.0) THEN APS2F304.16
ICODE=1 FIELDCOS.534
CMESSAGE='CRAY_IBM error converting logical for IBM_FIELD' APS2F304.17
RETURN FIELDCOS.536
ENDIF APS2F304.18
ENDIF FIELDCOS.537
ENDIF FIELDCOS.538
FIELDCOS.539
CL process extra data FIELDCOS.540
IF (IEXTRAW.GT.0) THEN ! process extra data as got some FIELDCOS.541
CL init values for while loop FIELDCOS.542
ADDR=NUM_VALUES-IEXTRAW+1 ! start address in field for extra dat FIELDCOS.543
IBM_ADDR=(ADDR+1)/2 FIELDCOS.544
IF (IBM_ADDR*2.EQ.ADDR) THEN FIELDCOS.545
BIT_OFF=32 FIELDCOS.546
ELSE FIELDCOS.547
BIT_OFF=0 FIELDCOS.548
ENDIF FIELDCOS.549
FIELDCOS.550
DO WHILE (ADDR.LT.NUM_VALUES) FIELDCOS.551
CL main while loop that works out code and then checks that code is FIELDCOS.552
CL ok. FIELDCOS.553
CL if code is ok then data_values will contain the number of REALs PS050793.222
CL in the vector. PS050793.223
IV=INT_FROM_REAL(FIELD(ADDR)) FIELDCOS.556
CALL CHECK_EXTRA(IV,DATA_VALUES,ICODE,CMESSAGE) FIELDCOS.557
IF (ICODE.NE.0) THEN FIELDCOS.558
RETURN FIELDCOS.559
ENDIF FIELDCOS.560
IER=CRI2IBM(2,1,IBM_FIELD(IBM_ADDR),BIT_OFF,FIELD(ADDR), UIE1F402.15
& 1,64,32) UIE1F402.16
C convert the integer from cray format to ibm format FIELDCOS.562
IF (IER.NE.0) THEN FIELDCOS.563
ICODE=1 FIELDCOS.564
CMESSAGE='CRAY_IBM: failed in integer conv of extra data' FIELDCOS.565
RETURN FIELDCOS.566
ENDIF FIELDCOS.567
FIELDCOS.568
CL update bit_off, addr and ibm_addr FIELDCOS.569
IF (BIT_OFF.EQ.0) THEN FIELDCOS.570
BIT_OFF=32 FIELDCOS.571
ELSE FIELDCOS.572
BIT_OFF=0 FIELDCOS.573
IBM_ADDR=IBM_ADDR+1 ! GONE ON ANOTHER WORD.. FIELDCOS.574
ENDIF FIELDCOS.575
ADDR=ADDR+1 ! INCREMENT ADDRESS FIELDCOS.576
CL now to convert REAL vector to IBM format. FIELDCOS.577
IER=CRI2IBM(3,DATA_VALUES,IBM_FIELD(IBM_ADDR), UIE1F402.17
& BIT_OFF,FIELD(ADDR),1,64,32) UIE1F402.18
C convert the real data values FIELDCOS.580
IF (IER.NE.0) THEN FIELDCOS.581
ICODE=1 FIELDCOS.582
CMESSAGE='CRAY_IBM: FAILED IN REAL CONV OF EXTRA DATA' FIELDCOS.583
RETURN FIELDCOS.584
ENDIF FIELDCOS.585
CL update loop variables. FIELDCOS.586
ADDR=ADDR+DATA_VALUES FIELDCOS.587
IBM_ADDR=IBM_ADDR+DATA_VALUES/2 FIELDCOS.588
IF ((DATA_VALUES/2)*2.NE.DATA_VALUES) THEN ! ODD NO. OF VALUES FIELDCOS.589
IF (BIT_OFF.EQ.0) THEN FIELDCOS.590
BIT_OFF=32 FIELDCOS.591
ELSE FIELDCOS.592
BIT_OFF=0 FIELDCOS.593
IBM_ADDR=IBM_ADDR+1 ! GONE ON ANOTHER WORD.. FIELDCOS.594
ENDIF FIELDCOS.595
ENDIF FIELDCOS.596
ENDDO ! continue unitil run out of data.... FIELDCOS.597
CL Verify addr and ibm_addr have correct values at end of whileloop FIELDCOS.598
CL first check that addr is ok FIELDCOS.599
IF (ADDR.NE.NUM_VALUES+1) THEN FIELDCOS.600
WRITE(CMESSAGE,109)ADDR,NUM_VALUES+1 FIELDCOS.601
109 FORMAT('CRAY_IBM: addr',i5,1x,'<> num_values+1',i5) GPB0F405.145
ICODE=1 FIELDCOS.603
RETURN FIELDCOS.604
ENDIF FIELDCOS.605
CL and so is ibm_addr FIELDCOS.606
IF (BIT_OFF.EQ.0) IBM_ADDR=IBM_ADDR-1 FIELDCOS.607
IF (IBM_ADDR.NE.(NUM_VALUES+1)/2) THEN FIELDCOS.608
WRITE(CMESSAGE,110)IBM_ADDR,(NUM_VALUES+1)/2 FIELDCOS.609
110 FORMAt('CRAY_IBM: ibm_addr ',i5,1x,' <> (num_values+1)/2',i5) GPB0F405.146
ICODE=1 FIELDCOS.611
RETURN FIELDCOS.612
ENDIF FIELDCOS.613
ENDIF ! end processing of extra data FIELDCOS.614
FIELDCOS.615
WRITE(COS_PPUNIT) IBM_LABEL PS050793.224
IF(PACKED) THEN FIELDCOS.617
WRITE(COS_PPUNIT) (FIELD(I),I=1,ILABEL(LBLREC)/2) PS050793.225
ELSE FIELDCOS.619
WRITE(COS_PPUNIT) IBM_FIELD FIELDCOS.620
ENDIF FIELDCOS.621
C FIELDCOS.622
100 FORMAT(' WRITING COS FILE for IPROJ ITYPE FCT LEVEL',4I6) FIELDCOS.623
CL The last field has been processed. An extra field is now written FIELDCOS.624
CL to act as a delimeter for the M08 software. This extra fields is FIELDCOS.625
CL a duplicate,but with a PP field code of -99 . FIELDCOS.626
IF(LAST) THEN FIELDCOS.627
WRITE(6,101) FIELDCOS.629
101 FORMAT(' WRITING LAST RECORD IN THE COS FILE ') FIELDCOS.630
ILABEL(LBFC)=-99 PS050793.226
CL Convert ILABEL to IBM(Hitachi) Integers PS050793.227
BIT_OFF = 0 PS050793.228
IBM_ADDR=1 PS050793.229
IER = CRI2IBM(2,LEN_ILABEL,IBM_LABEL(IBM_ADDR),BIT_OFF,ILABEL, UIE1F402.19
& 1,64,32) UIE1F402.20
IF(IER.NE.0) THEN PS050793.231
ICODE=1 PS050793.232
CMESSAGE=' CRAY_IBM error converting INT for IBM_LABEL' PS050793.233
RETURN PS050793.234
ENDIF PS050793.235
CL Convert RLABEL to IBM(Hitachi) Real. PS050793.236
IBM_ADDR=LEN_ILABEL/2 PS050793.237
IF(IBM_ADDR*2.NE.LEN_ILABEL) BIT_OFF=32 PS050793.238
IBM_ADDR=IBM_ADDR+1 PS050793.239
IER = CRI2IBM(3,LEN_RLABEL,IBM_LABEL(IBM_ADDR),BIT_OFF,RLABEL, UIE1F402.21
& 1,64,32) UIE1F402.22
IF(IER.NE.0) THEN PS050793.241
ICODE=1 PS050793.242
CMESSAGE=' CRAY_IBM error converting REAL for IBM_LABEL' PS050793.243
RETURN PS050793.244
ENDIF PS050793.245
WRITE(COS_PPUNIT) IBM_LABEL PS050793.246
IF(PACKED) THEN FIELDCOS.639
WRITE(COS_PPUNIT) (FIELD(I),I=1,ILABEL(LBLREC)/2) PS050793.247
ELSE FIELDCOS.641
WRITE(COS_PPUNIT) IBM_FIELD FIELDCOS.642
ENDIF FIELDCOS.643
ENDIF FIELDCOS.644
9999 CONTINUE FIELDCOS.645
RETURN FIELDCOS.646
END FIELDCOS.647
FIELDCOS.648
CLL Routine: CRAY_VAX------------------------------------------------- FIELDCOS.649
CLL FIELDCOS.650
CLL Purpose: To read a direct access PP file and convert it to a FIELDCOS.651
CLL sequential file read to be passed in VAX format FIELDCOS.652
CLL FIELDCOS.653
CLL Tested under compiler: cft77 FIELDCOS.654
CLL Tested under OS version: FIELDCOS.655
CLL FIELDCOS.656
CLL Author: P.J .Smith Date: 26 June 1992 FIELDCOS.657
CLL FIELDCOS.658
CLL Model Modification history from model version 3.0: FIELDCOS.659
CLL version Date FIELDCOS.660
CLL FIELDCOS.661
CLL Programming standard: UM Doc Paper 3, version 1 (15/1/90) FIELDCOS.662
CLL FIELDCOS.663
CLL Logical components covered: C41 FIELDCOS.664
CLL FIELDCOS.665
CLL Project task: C4 FIELDCOS.666
CLL FIELDCOS.667
CLL External documentation: FIELDCOS.668
CLL FIELDCOS.669
CLL ------------------------------------------------------------------- FIELDCOS.670
C*L Interface and arguments: ------------------------------------------ FIELDCOS.671
C FIELDCOS.672
SUBROUTINE CRAY_VAX(IDIM,NUM_VALUES,PPUNIT, 1,16FIELDCOS.673
& LEN1_LOOKUP,PP_LEN2_LOOKUP,PP_FIXHD,LOOKUP, FIELDCOS.674
& ROOKUP,ENTRY_NO,DATA_ADD,MODEL_FLAG, PS050793.248
& COS_PPUNIT,IEXTRA,IEXTRAW,LAST,OPER, PS050793.249
& ICODE,CMESSAGE,LCAL360) GSS1F304.305
IMPLICIT NONE FIELDCOS.677
C Arguments PS050793.251
CHARACTER PS050793.252
& CMESSAGE*(*) !OUT error messages PS050793.253
LOGICAL PS050793.254
& LAST !IN indicates last record process PS050793.255
& ,OPER !IN indicates whether operational PS050793.256
& ,MODEL_FLAG !IN True => dumps, False => fieldsfile PS050793.257
& ,LCAL360 GSS1F304.306
INTEGER PS050793.258
& PPUNIT !IN unit no of required fieldsfile PS050793.259
& ,COS_PPUNIT !IN unit no of COS output file PS050793.260
& ,NUM_VALUES !IN No of data points NROWS*NCOLS PS050793.261
& ,IDIM !IN NUM_VALUES rounded to an even no PS050793.262
C ! used to dimension The output array PS050793.263
& ,DATA_ADD !IN The word address of the data. PS050793.264
& ,LEN1_LOOKUP !IN First dimension of the lookup PS050793.265
& ,PP_LEN2_LOOKUP !IN Size of the LOOKUP on the file PS050793.266
& ,IEXTRA(10) !IN Used within READFF PS050793.267
& ,IEXTRAW !IN no of words of extra data. PS050793.268
& ,ENTRY_NO !IN Lookup entry no of the Field. PS050793.269
& ,PP_FIXHD(*) !IN PPfile fixed header PS050793.270
& ,LOOKUP(LEN1_LOOKUP,PP_LEN2_LOOKUP) !IN integer lookup PS050793.271
& ,ICODE !OUT error code PS050793.272
REAL PS050793.273
& ROOKUP(LEN1_LOOKUP,PP_LEN2_LOOKUP) !IN Real lookup PS050793.274
C*--------------------------------------------------------------------- PS050793.275
C Called routines PS050793.276
EXTERNAL READFF,INT_FROM_REAL,CRAY2VAX,TIME2SEC,SEC2TIME PS050793.277
INTEGER INT_FROM_REAL,CRAY2VAX FIELDCOS.679
C*--------------------------------------------------------------------- PS050793.278
C arguments for called routines PS050793.279
INTEGER FIELDCOS.683
& MAX_LEN_ILABEL PS050793.280
& ,MAX_LEN_RLABEL PS050793.281
PARAMETER (MAX_LEN_ILABEL=45,MAX_LEN_RLABEL=32) PS050793.282
INTEGER FIELDCOS.699
& END_YEAR ! ) PS050793.283
& ,END_MONTH ! ) PS050793.284
& ,END_DAY ! ) arguments PS050793.285
& ,END_HOUR ! ) PS050793.286
& ,END_MINUTE ! ) for PS050793.287
& ,END_SECOND ! ) PS050793.288
& ,END_DAY_NUMBER ! ) TJ080294.61
& ,END_TIME_DAYS ! ) TJ080294.62
& ,END_TIME_SECS ! ) date/time PS050793.289
& ,START_TIME_SECS ! ) PS050793.290
& ,START_TIME_DAYS ! ) TJ080294.63
& ,DATA_YEAR ! ) conversion PS050793.291
& ,DATA_MONTH ! ) PS050793.292
& ,DATA_DAY ! ) when PS050793.293
& ,DATA_HOUR ! ) PS050793.294
& ,DATA_MINUTE ! ) OPER is TRUE PS050793.295
& ,DATA_SECOND ! ) PS050793.296
& ,DATA_DAY_NUMBER ! ) PS050793.297
& ,ADDR ! address in fld, used to process extra data PS050793.298
& ,VAX_ADDR ! address in VAX fld where extra data going. PS050793.299
& ,BIT_OFF ! what bit offset are we using PS050793.300
C (32 for odd, 0 for even values of addr) PS050793.301
& ,IER ! error RETURN CODE from conversion PS050793.302
& ,IV ! value of integer code for vectors PS050793.303
& ,LEN_ILABEL ! number of values in ILABEL PS050793.304
& ,LEN_RLABEL ! number of values in RLABEL PS050793.305
& ,DATA_VALUES ! number of values in real extra data PS050793.306
& ,ILABEL(MAX_LEN_ILABEL) ! holds integer part of LOOKUP PS050793.307
& ,VAX_LABEL((LEN1_LOOKUP+1)/2) ! holds VAX conversion of LABEL PS050793.308
PS050793.309
REAL FIELDCOS.702
& FIELD(IDIM) ! array holding data PS050793.310
& ,VAX_FIELD(IDIM/2) ! array holding VAX data PS050793.311
& ,RLABEL(MAX_LEN_RLABEL) ! holds real part of LOOKUP PS050793.312
PS050793.313
*CALL CLOOKADD PS050793.314
C*--------------------------------------------------------------------- FIELDCOS.708
C LOCAL VARIABLES FIELDCOS.709
INTEGER FIELDCOS.710
& I ! local counter PS050793.315
& ,PACK_TYPE ! packing type N1 of LBPACK PS050793.316
& ,DATA_COMP ! data compression code FIELDCOS.739
& ,DATA_COMP_DEF ! data compression definition FIELDCOS.740
& ,NUMBER_FORMAT ! number format FIELDCOS.741
& ,FCST_PRD PS050793.317
FIELDCOS.742
LOGICAL PACKED ! indicates whether the data is packed PS050793.318
FIELDCOS.744
C PS050793.319
FIELDCOS.746
DO 1 I=1,IDIM ! make sure FIELD is initialised. An odd FIELDCOS.747
FIELD(I)=0.0 ! number of points might upset conversion FIELDCOS.748
1 CONTINUE FIELDCOS.749
PACKED=.FALSE. FIELDCOS.750
C PS050793.320
CL access the Fields File. FIELDCOS.752
CALL READFF(PPUNIT,FIELD,IDIM,ENTRY_NO, FIELDCOS.753
*ILABEL,RLABEL,IEXTRA,PP_LEN2_LOOKUP,LEN1_LOOKUP, FIELDCOS.754
*PP_FIXHD,LOOKUP,ROOKUP,DATA_ADD, PS050793.321
*MODEL_FLAG,MAX_LEN_ILABEL,MAX_LEN_RLABEL, PS050793.322
*LEN_ILABEL,LEN_RLABEL, PS050793.323
*ICODE,CMESSAGE) PS050793.324
C FIELDCOS.756
IF(ICODE.NE.0) RETURN FIELDCOS.757
FIELDCOS.758
C----------------------------------------------------------------- FIELDCOS.759
FIELDCOS.760
C The data has now been read in and has 1) Been read in packed FIELDCOS.761
C and left packed or 2) read in as packed and then un-packed or FIELDCOS.762
C 3) The data was never packed at all. If packed FIELD will have FIELDCOS.763
C LBLREC/2 values if a DUMP and LBLREC values if a PP_FILE. If FIELDCOS.764
C the data is not packed FIELD will have the no of data points FIELDCOS.765
C length LBROW*LBNPT+LBEXT if a pp_file and LBLREC if a dump file. FIELDCOS.766
C FIELDCOS.767
C For a dump LBLREC will hold origonal no of data points. For a FIELDCOS.768
C pp_file LBLREC will hold the no of CRAY words needed to hold FIELDCOS.769
C the data (if un-packed also no of data points) FIELDCOS.770
C FIELDCOS.771
C The value returned in ILABEL(LBLREC) may have to change because FIELDCOS.772
C VAX only has a 32 bit word length compared to the CRAY's 64 FIELDCOS.773
C bit word length. In VAX ILABEL(LBLREC) will be no of 32 bit FIELDCOS.774
C words needed to hold the data . If the data is not packed (or FIELDCOS.775
C it has been un-packed) then this will be the no of data points. FIELDCOS.776
C If the data is left packed the value of ILABEL(LBLREC) FIELDCOS.777
C will have to be doubled as the no of 32bit words needed to FIELDCOS.778
C hold the data will twice that on the CRAY. FIELDCOS.779
FIELDCOS.780
C On output the data will either have been converted to VAX FIELDCOS.781
C numbers and stored in VAX_FIELD or left packed in FIELD,but with FIELDCOS.782
C 32 bit VAX numbers substituted into minimum values. FIELDCOS.783
C If packed then LBLREC/2 words of FIELD are written as LBLREC is FIELDCOS.784
C now the no of 32 bit words. If un-packed VAX_FIELD which has size FIELDCOS.785
C IDIM/2 (or NUM_VALUES/2) is written as it is. FIELDCOS.786
FIELDCOS.787
C----------------------------------------------------------------- FIELDCOS.788
c decode LBPACK FIELDCOS.789
PACK_TYPE = MOD(ILABEL(LBPACK),10) FIELDCOS.790
DATA_COMP = MOD(ILABEL(LBPACK),100) - PACK_TYPE FIELDCOS.791
DATA_COMP_DEF = MOD(ILABEL(LBPACK),1000) -DATA_COMP -PACK_TYPE FIELDCOS.792
NUMBER_FORMAT = ILABEL(LBPACK)/1000 FIELDCOS.793
FIELDCOS.794
IF(PACK_TYPE.GT.0) PACKED=.TRUE. FIELDCOS.795
IF(PACKED) THEN ! Data left in packed form. Number of PS290193.4
ILABEL(LBLREC)=ILABEL(LBLREC)*2 ! VAX words needed is 2*CRAY PS290193.5
ENDIF FIELDCOS.806
C verify that don't have extra data and packing at once FIELDCOS.807
IF (IEXTRAW.GT.0.AND.PACKED) THEN FIELDCOS.808
CMESSAGE='FIELDCOS: Extra data with packing not supported' FIELDCOS.809
ICODE=1 FIELDCOS.810
RETURN FIELDCOS.811
ENDIF FIELDCOS.812
FIELDCOS.813
CL Convert ILABEL to VAX integers. PS050793.325
C For either an accumulation or time mean (ie LBTIM.ne.0) the start & FIELDCOS.815
C end time are in a different order to the data and veri time for a FIELDCOS.816
C snap shot type field. This anomaly has to be catered for operational FIELDCOS.817
C use. Thus the PP package will not work properly on accum/time mn field FIELDCOS.818
C for operational Fields files. FIELDCOS.819
IF(ILABEL(LBTIM).NE.11.AND.OPER) THEN PS050793.326
C re -calculate the data time from the end time and fcst period FIELDCOS.821
C First calculate the no of seconds from day 0 FIELDCOS.822
END_YEAR=ILABEL(LBYRD) FIELDCOS.823
END_MONTH=ILABEL(LBMOND) FIELDCOS.824
END_DAY=ILABEL(LBDATD) FIELDCOS.825
END_HOUR=ILABEL(LBHRD) FIELDCOS.826
END_MINUTE=ILABEL(LBMIND) FIELDCOS.827
END_DAY_NUMBER=ILABEL(LBDAYD) TJ080294.78
END_SECOND=0 PS190494.4
FCST_PRD=ILABEL(LBFT) FIELDCOS.829
C WRITE(6,*)' START YR/MO/DA/HR/MIN BEFORE ',ILABEL(1),ILABEL(2), GIE0F403.172
C * ILABEL(3),ILABEL(4),ILABEL(5) FIELDCOS.831
C WRITE(6,*)' END YR/MO/DA/HR/MIN BEFORE ',ILABEL(7),ILABEL(8), GIE0F403.173
C * ILABEL(9),ILABEL(10),ILABEL(11) FIELDCOS.833
C WRITE(6,*)' FCST_PRD BEFORE ',FCST_PRD GIE0F403.174
CALL TIME2SEC (END_YEAR,END_MONTH,END_DAY,END_HOUR, FIELDCOS.835
* END_MINUTE,END_SECOND,0,0, TJ080294.64
* END_TIME_DAYS,END_TIME_SECS,LCAL360) GSS1F304.307
FIELDCOS.837
C Subtract forecast hours from end time in (days,seconds) TJ080294.88
TJ080294.89
CALL TIME_DF(END_TIME_DAYS,END_TIME_SECS,0,-FCST_PRD*3600, TJ080294.90
* START_TIME_DAYS,START_TIME_SECS) TJ080294.91
FIELDCOS.839
C Go back and re-calculate Year/Month/Day/Hour/Sec. FIELDCOS.840
CALL SEC2TIME(0,0,START_TIME_DAYS,START_TIME_SECS, TJ080294.66
* DATA_YEAR,DATA_MONTH,DATA_DAY, TJ080294.67
* DATA_HOUR,DATA_MINUTE,DATA_SECOND,DATA_DAY_NUMBER, GSS1F304.308
* LCAL360) GSS1F304.309
ILABEL(LBYRD)=DATA_YEAR FIELDCOS.844
ILABEL(LBMOND)=DATA_MONTH FIELDCOS.845
ILABEL(LBDATD)=DATA_DAY FIELDCOS.846
ILABEL(LBHRD)=DATA_HOUR FIELDCOS.847
ILABEL(LBMIND)=DATA_MINUTE FIELDCOS.848
ILABEL(LBDAYD)=DATA_DAY_NUMBER TJ080294.79
ILABEL(LBYR)=END_YEAR FIELDCOS.849
ILABEL(LBMON)=END_MONTH FIELDCOS.850
ILABEL(LBDAT)=END_DAY FIELDCOS.851
ILABEL(LBHR)=END_HOUR FIELDCOS.852
ILABEL(LBMIN)=END_MINUTE FIELDCOS.853
ILABEL(LBDAY)=END_DAY_NUMBER TJ080294.80
C WRITE(6,*)' -----------------------------------------------' GIE0F403.175
C WRITE(6,*)' Veri YR/MO/DA/HR/MIN AFTER ',ILABEL(1),ILABEL(2), GIE0F403.176
C * ILABEL(3),ILABEL(4),ILABEL(5) FIELDCOS.856
C WRITE(6,*)' Data YR/MO/DA/HR/MIN AFTER ',ILABEL(7),ILABEL(8), GIE0F403.177
C * ILABEL(9),ILABEL(10),ILABEL(11) FIELDCOS.858
C WRITE(6,*)' FCST_PRD AFTER ',FCST_PRD GIE0F403.178
C WRITE(6,*)' -----------------------------------------------' GIE0F403.179
C WRITE(6,*)' -----------------------------------------------' GIE0F403.180
ENDIF FIELDCOS.862
FIELDCOS.863
C data now in vax format FIELDCOS.864
ILABEL(LBPACK) = ILABEL(LBPACK) - NUMBER_FORMAT*1000 + 5000 FIELDCOS.865
FIELDCOS.866
CL Convert ILABEL to VAX Integer PS050793.327
BIT_OFF=0 FIELDCOS.867
VAX_ADDR = 1 PS050793.328
IER=CRAY2VAX(1,LEN_ILABEL,VAX_LABEL(VAX_ADDR),BIT_OFF,ILABEL) PS050793.329
IF(IER.NE.0) THEN FIELDCOS.869
ICODE=1 FIELDCOS.870
CMESSAGE=' FUNCTION CRAY2VAX not supported on T3E' UIE1F402.30
RETURN FIELDCOS.872
ENDIF FIELDCOS.873
CL Convert RLABEL to VAX Real. FIELDCOS.874
VAX_ADDR=LEN_ILABEL/2 PS050793.330
IF(VAX_ADDR*2.NE.LEN_ILABEL) BIT_OFF=32 PS050793.331
VAX_ADDR=VAX_ADDR+1 PS050793.332
IER=CRAY2VAX(2,LEN_RLABEL,VAX_LABEL(VAX_ADDR),BIT_OFF,RLABEL) PS050793.333
IF(IER.NE.0) THEN FIELDCOS.877
ICODE=1 FIELDCOS.878
CMESSAGE=' FUNCTION CRAY2VAX not supported on T3E' UIE1F402.31
RETURN FIELDCOS.880
ENDIF FIELDCOS.881
BIT_OFF=0 PS050793.334
IF(.NOT.PACKED) THEN FIELDCOS.882
CL Convert Real DATA to VAX Real if not packed. FIELDCOS.883
IF(ILABEL(DATA_TYPE).EQ.1) THEN ! Data Type Real FIELDCOS.884
if(ilabel(32).eq.74) then APS2F304.19
WRITE(6,*)'convert type 74 as logical and reset datatype' GIE0F403.181
IER = CRAY2VAX(5,NUM_VALUES-IEXTRAW,VAX_FIELD,BIT_OFF,FIELD) APS2F304.21
ILABEL(DATA_TYPE) = 3 APS2F304.22
else APS2F304.23
IER=CRAY2VAX(2,NUM_VALUES-IEXTRAW,VAX_FIELD,BIT_OFF,FIELD) FIELDCOS.885
IF(IER.NE.0) THEN FIELDCOS.886
ICODE=1 FIELDCOS.887
CMESSAGE='CRAY_VAX error converting REAL for VAX_FIELD' FIELDCOS.888
RETURN FIELDCOS.889
ENDIF FIELDCOS.890
endif APS2F304.24
CL Convert Integer data to VAX Integer. FIELDCOS.891
ELSEIF(ILABEL(DATA_TYPE).EQ.2) THEN ! Data Type Integer FIELDCOS.892
IER=CRAY2VAX(1,NUM_VALUES-IEXTRAW,VAX_FIELD,BIT_OFF,FIELD) FIELDCOS.893
IF(IER.NE.0) THEN FIELDCOS.894
ICODE=1 FIELDCOS.895
CMESSAGE='CRAY_VAX error calling USICTI for VAX_FIELD' FIELDCOS.896
RETURN FIELDCOS.897
ENDIF FIELDCOS.898
ELSEIF(ILABEL(DATA_TYPE).EQ.3) THEN ! Data Type Logical FIELDCOS.899
IER = CRAY2VAX(5,NUM_VALUES-IEXTRAW,VAX_FIELD,BIT_OFF,FIELD) APS2F304.25
IF(IER.NE.0) THEN APS2F304.26
ICODE=1 FIELDCOS.900
CMESSAGE='CRAY_VAX error converting logical for VAX_FIELD' APS2F304.27
RETURN FIELDCOS.902
ENDIF APS2F304.28
ENDIF FIELDCOS.903
ELSE FIELDCOS.904
WRITE(6,*)'WARNING ! WGDOS packed data contains IBM reals' GIE0F403.182
FIELDCOS.906
c code to be added here to convert ibm reals in packed data FIELDCOS.907
c to VAX reals FIELDCOS.908
FIELDCOS.909
ENDIF FIELDCOS.910
CL process extra data FIELDCOS.911
IF (IEXTRAW.GT.0) THEN ! process extra data as got some FIELDCOS.912
CL init values for while loop FIELDCOS.913
ADDR=NUM_VALUES-IEXTRAW+1 ! start address in field for extra dat FIELDCOS.914
VAX_ADDR=(ADDR+1)/2 FIELDCOS.915
IF (VAX_ADDR*2.EQ.ADDR) THEN FIELDCOS.916
BIT_OFF=32 FIELDCOS.917
ELSE FIELDCOS.918
BIT_OFF=0 FIELDCOS.919
ENDIF FIELDCOS.920
FIELDCOS.921
DO WHILE (ADDR.LT.NUM_VALUES) FIELDCOS.922
CL main while loop that works out code and then checks that code is FIELDCOS.923
CL ok. FIELDCOS.924
CL if code is ok then data_values weill contain the number of REAL entri FIELDCOS.925
CL the vector. FIELDCOS.926
IV=INT_FROM_REAL(FIELD(ADDR)) FIELDCOS.927
CALL CHECK_EXTRA(IV,DATA_VALUES,ICODE,CMESSAGE) FIELDCOS.928
IF (ICODE.NE.0) THEN FIELDCOS.929
RETURN FIELDCOS.930
ENDIF FIELDCOS.931
IER=CRAY2VAX(1,1,VAX_FIELD(VAX_ADDR),BIT_OFF,FIELD(ADDR)) FIELDCOS.932
C convert the integer from cray format to VAX format FIELDCOS.933
IF (IER.NE.0) THEN FIELDCOS.934
ICODE=1 FIELDCOS.935
CMESSAGE='CRAY_VAX: FAILED IN INTEGER CONV OF EXTRA DATA' FIELDCOS.936
RETURN FIELDCOS.937
ENDIF FIELDCOS.938
FIELDCOS.939
CL update bit_off, addr and VAX_addr FIELDCOS.940
IF (BIT_OFF.EQ.0) THEN FIELDCOS.941
BIT_OFF=32 FIELDCOS.942
ELSE FIELDCOS.943
BIT_OFF=0 FIELDCOS.944
VAX_ADDR=VAX_ADDR+1 ! gone on another word.. FIELDCOS.945
ENDIF FIELDCOS.946
ADDR=ADDR+1 ! increment address FIELDCOS.947
CL now to convert REAL vector to VAX format. FIELDCOS.948
IER=CRAY2VAX(2,DATA_VALUES,VAX_FIELD(VAX_ADDR), FIELDCOS.949
& BIT_OFF,FIELD(ADDR)) FIELDCOS.950
C convert the real data values FIELDCOS.951
IF (IER.NE.0) THEN FIELDCOS.952
ICODE=1 FIELDCOS.953
CMESSAGE='CRAY_VAX: FAILED IN REAL CONV OF EXTRA DATA' FIELDCOS.954
RETURN FIELDCOS.955
ENDIF FIELDCOS.956
CL update loop variables. FIELDCOS.957
ADDR=ADDR+DATA_VALUES FIELDCOS.958
VAX_ADDR=VAX_ADDR+DATA_VALUES/2 FIELDCOS.959
IF ((DATA_VALUES/2)*2.NE.DATA_VALUES) THEN ! odd no. of values FIELDCOS.960
IF (BIT_OFF.EQ.0) THEN FIELDCOS.961
BIT_OFF=32 FIELDCOS.962
ELSE FIELDCOS.963
BIT_OFF=0 FIELDCOS.964
VAX_ADDR=VAX_ADDR+1 ! gone on another word.. FIELDCOS.965
ENDIF FIELDCOS.966
ENDIF FIELDCOS.967
ENDDO ! continue unitil run out of data.... FIELDCOS.968
CL Verify addr and VAX_addr have correct values at end of whileloop FIELDCOS.969
CL first check that addr is ok FIELDCOS.970
IF (ADDR.NE.NUM_VALUES+1) THEN FIELDCOS.971
WRITE(CMESSAGE,109)ADDR,NUM_VALUES+1 FIELDCOS.972
109 FORMAT('CRAY_VAX: ADDR',I5,1X,'<> NUM_VALUES+1',I5) GPB0F405.147
ICODE=1 FIELDCOS.974
RETURN FIELDCOS.975
ENDIF FIELDCOS.976
CL and so is VAX_addr FIELDCOS.977
IF (BIT_OFF.EQ.0) VAX_ADDR=VAX_ADDR-1 FIELDCOS.978
IF (VAX_ADDR.NE.(NUM_VALUES+1)/2) THEN FIELDCOS.979
WRITE(CMESSAGE,110)VAX_ADDR,(NUM_VALUES+1)/2 FIELDCOS.980
110 FORMAT('CRAY_VAX: VAX_ADDR ',I5,1X,' <> (NUM_VALUES+1)/2',I5) GPB0F405.148
ICODE=1 FIELDCOS.982
RETURN FIELDCOS.983
ENDIF FIELDCOS.984
ENDIF ! end processing of extra data FIELDCOS.985
FIELDCOS.986
IF(PACKED) THEN FIELDCOS.987
WRITE(COS_PPUNIT) VAX_LABEL PS050793.336
WRITE(COS_PPUNIT) (FIELD(I),I=1,ILABEL(LBLREC)/2) PS050793.337
c WRITE(6,111) VAX_LABEL PS050793.338
c WRITE(6,111) (FIELD(I),I=1,50) PS050793.339
ELSE FIELDCOS.991
WRITE(COS_PPUNIT) VAX_LABEL PS050793.340
WRITE(COS_PPUNIT) VAX_FIELD FIELDCOS.993
c WRITE(6,111) VAX_LABEL PS050793.341
c WRITE(6,111) (VAX_FIELD(I),I=1,50) PS050793.342
ENDIF FIELDCOS.994
111 FORMAT(1X,5Z16) PS050793.343
C FIELDCOS.995
100 FORMAT(' WRITING COS FILE for IPROJ ITYPE FCT LEVEL',4I6) FIELDCOS.996
CL The last field has been processed. An extra field is now written FIELDCOS.997
CL to act as a delimeter for the M08 software. This extra fields is FIELDCOS.998
CL a duplicate,but with a PP field code of -99 . FIELDCOS.999
IF(LAST) THEN FIELDCOS.1000
BIT_OFF = 0 FIELDCOS.1001
WRITE(6,101) FIELDCOS.1002
101 FORMAT(' WRITING LAST RECORD IN THE COS FILE ') FIELDCOS.1003
ILABEL(23)=-99 FIELDCOS.1004
CL Convert ILABEL to VAX Integer PS050793.344
BIT_OFF=0 PS050793.345
VAX_ADDR = 1 PS050793.346
IER=CRAY2VAX(1,LEN_ILABEL,VAX_LABEL(VAX_ADDR),BIT_OFF,ILABEL) PS050793.347
IF(IER.NE.0) THEN FIELDCOS.1006
ICODE=1 FIELDCOS.1007
CMESSAGE=' FUNCTION CRAY2VAX not supported on T3E' UIE1F402.32
RETURN FIELDCOS.1009
ENDIF FIELDCOS.1010
CL Convert RLABEL to VAX Real. PS050793.348
VAX_ADDR=LEN_ILABEL/2 PS050793.349
IF(VAX_ADDR*2.NE.LEN_ILABEL) BIT_OFF=32 PS050793.350
VAX_ADDR=VAX_ADDR+1 PS050793.351
IER=CRAY2VAX(2,LEN_RLABEL,VAX_LABEL(VAX_ADDR),BIT_OFF,RLABEL) PS050793.352
IF(IER.NE.0) THEN PS050793.353
ICODE=1 PS050793.354
CMESSAGE=' FUNCTION CRAY2VAX not supported on T3E' UIE1F402.33
RETURN PS050793.356
ENDIF PS050793.357
IF(PACKED) THEN FIELDCOS.1011
WRITE(COS_PPUNIT) VAX_LABEL PS050793.358
WRITE(COS_PPUNIT) (FIELD(I),I=1,ILABEL(LBLREC)/2) PS050793.359
ELSE FIELDCOS.1014
WRITE(COS_PPUNIT) VAX_LABEL PS050793.360
WRITE(COS_PPUNIT) VAX_FIELD FIELDCOS.1016
ENDIF FIELDCOS.1017
ENDIF FIELDCOS.1018
9999 CONTINUE FIELDCOS.1019
RETURN FIELDCOS.1020
END FIELDCOS.1021
FIELDCOS.1022
CLL Routine: CRAY_IEEE------------------------------------------------- FIELDCOS.1023
CLL FIELDCOS.1024
CLL Purpose: To read a direct access PP file and convert it to a FIELDCOS.1025
CLL sequential file read to be passed in IEEE format FIELDCOS.1026
CLL FIELDCOS.1027
CLL Author: P.J .Smith Date: 26 June 1992 FIELDCOS.1028
CLL FIELDCOS.1029
CLL Tested under compiler: cft77 FIELDCOS.1030
CLL Tested under OS version: FIELDCOS.1031
CLL FIELDCOS.1032
CLL Model Modification history from model version 3.0: FIELDCOS.1033
CLL version Date FIELDCOS.1034
CLL FIELDCOS.1035
CLL Programming standard: UM Doc Paper 3, version 1 (15/1/90) FIELDCOS.1036
CLL FIELDCOS.1037
CLL Logical components covered: C41 FIELDCOS.1038
CLL FIELDCOS.1039
CLL Project task: C4 FIELDCOS.1040
CLL FIELDCOS.1041
CLL External documentation: FIELDCOS.1042
CLL FIELDCOS.1043
CLL ------------------------------------------------------------------- FIELDCOS.1044
C*L Interface and arguments: ------------------------------------------ FIELDCOS.1045
C FIELDCOS.1046
SUBROUTINE CRAY_IEEE(IDIM,NUM_VALUES,PPUNIT, 1,6FIELDCOS.1047
& LEN1_LOOKUP,PP_LEN2_LOOKUP,PP_FIXHD,LOOKUP, FIELDCOS.1048
& ROOKUP,ENTRY_NO,DATA_ADD,MODEL_FLAG, PS050793.361
& COS_PPUNIT,IEXTRA,IEXTRAW,LAST,OPER, PS050793.362
& ICODE,CMESSAGE,LCAL360) GSS1F304.310
IMPLICIT NONE FIELDCOS.1051
C Arguments PS050793.364
CHARACTER PS050793.365
& CMESSAGE*(*) !OUT error messages PS050793.366
LOGICAL PS050793.367
& LAST !IN indicates last record process PS050793.368
& ,OPER !IN indicates whether operational PS050793.369
& ,MODEL_FLAG !IN True => dumps, False => fieldsfile PS050793.370
& ,LCAL360 GSS1F304.311
INTEGER PS050793.371
& PPUNIT !IN unit no of required fieldsfile PS050793.372
& ,COS_PPUNIT !IN unit no of COS output file PS050793.373
& ,NUM_VALUES !IN No of data points NROWS*NCOLS PS050793.374
& ,IDIM !IN NUM_VALUES rounded to an even no PS050793.375
C ! used to dimension The output array PS050793.376
& ,DATA_ADD !IN The word address of the data. PS050793.377
& ,LEN1_LOOKUP !IN First dimension of the lookup PS050793.378
& ,PP_LEN2_LOOKUP !IN Size of the LOOKUP on the file PS050793.379
& ,IEXTRA(10) !IN Used within READFF PS050793.380
& ,IEXTRAW !IN no of words of extra data. PS050793.381
& ,ENTRY_NO !IN Lookup entry no of the Field. PS050793.382
& ,PP_FIXHD(*) !IN PPfile fixed header PS050793.383
& ,LOOKUP(LEN1_LOOKUP,PP_LEN2_LOOKUP) !IN integer lookup PS050793.384
& ,ICODE !OUT error code PS050793.385
REAL PS050793.386
& ROOKUP(LEN1_LOOKUP,PP_LEN2_LOOKUP) !IN Real lookup PS050793.387
C*--------------------------------------------------------------------- PS050793.388
C Called routines PS050793.389
EXTERNAL READFF,INT_FROM_REAL,CRI2IEG,TIME2SEC,SEC2TIME UIE1F402.39
INTEGER INT_FROM_REAL,CRI2IEG UIE1F402.40
C*--------------------------------------------------------------------- PS050793.391
C arguments for called routines PS050793.392
INTEGER FIELDCOS.1057
& MAX_LEN_ILABEL PS050793.393
& ,MAX_LEN_RLABEL PS050793.394
PARAMETER (MAX_LEN_ILABEL=45,MAX_LEN_RLABEL=32) PS050793.395
INTEGER FIELDCOS.1073
& END_YEAR ! ) PS050793.396
& ,END_MONTH ! ) PS050793.397
& ,END_DAY ! ) arguments PS050793.398
& ,END_HOUR ! ) PS050793.399
& ,END_MINUTE ! ) for PS050793.400
& ,END_SECOND ! ) PS050793.401
& ,END_DAY_NUMBER ! ) TJ080294.68
& ,END_TIME_DAYS ! ) TJ080294.69
& ,END_TIME_SECS ! ) date/time PS050793.402
& ,START_TIME_SECS ! ) PS050793.403
& ,START_TIME_DAYS ! ) TJ080294.70
& ,DATA_YEAR ! ) conversion PS050793.404
& ,DATA_MONTH ! ) PS050793.405
& ,DATA_DAY ! ) when PS050793.406
& ,DATA_HOUR ! ) PS050793.407
& ,DATA_MINUTE ! ) OPER is TRUE PS050793.408
& ,DATA_SECOND ! ) PS050793.409
& ,DATA_DAY_NUMBER ! ) PS050793.410
& ,ADDR ! address in fld, used to process extra data PS050793.411
& ,IEEE_ADDR ! address in ibm fld where extra data going. PS050793.412
& ,BIT_OFF ! what bit offset are we using PS050793.413
C (32 for odd, 0 for even values of addr) PS050793.414
& ,IER ! error RETURN CODE from conversion PS050793.415
& ,IV ! value of integer code for vectors PS050793.416
& ,LEN_ILABEL ! number of values in ILABEL PS050793.417
& ,LEN_RLABEL ! number of values in RLABEL PS050793.418
& ,DATA_VALUES ! number of values in real extra data PS050793.419
& ,ILABEL(MAX_LEN_ILABEL) ! holds integer part of LOOKUP PS050793.420
& ,IEEE_LABEL((LEN1_LOOKUP+1)/2)! holds IEEEconversion of LABEL PS050793.421
PS050793.422
REAL FIELDCOS.1076
& FIELD(IDIM) ! array holding data PS050793.423
& ,IEEE_FIELD(IDIM/2) ! array holding IEEE data PS050793.424
& ,RLABEL(MAX_LEN_RLABEL) ! holds real part of LOOKUP PS050793.425
PS050793.426
*CALL CLOOKADD PS050793.427
C*--------------------------------------------------------------------- FIELDCOS.1082
C LOCAL VARIABLES FIELDCOS.1083
INTEGER FIELDCOS.1084
& I ! local counter PS050793.428
& ,PACK_TYPE ! packing type N1 of LBPACK PS050793.429
& ,DATA_COMP ! data compression code FIELDCOS.1113
& ,DATA_COMP_DEF ! data compression definition FIELDCOS.1114
& ,NUMBER_FORMAT ! number format FIELDCOS.1115
& ,FCST_PRD PS050793.430
FIELDCOS.1116
LOGICAL PACKED ! indicates whether the data is packed PS050793.431
FIELDCOS.1118
PS050793.432
FIELDCOS.1120
DO 1 I=1,IDIM ! make sure FIELD is initialised. An odd FIELDCOS.1121
FIELD(I)=0.0 ! number of points might upset conversion FIELDCOS.1122
1 CONTINUE FIELDCOS.1123
PACKED=.FALSE. FIELDCOS.1124
FIELDCOS.1125
CL access the Fields File. FIELDCOS.1126
CALL READFF(PPUNIT,FIELD,IDIM,ENTRY_NO, FIELDCOS.1127
*ILABEL,RLABEL,IEXTRA,PP_LEN2_LOOKUP,LEN1_LOOKUP, FIELDCOS.1128
*PP_FIXHD,LOOKUP,ROOKUP,DATA_ADD, PS050793.433
*MODEL_FLAG,MAX_LEN_ILABEL,MAX_LEN_RLABEL, PS050793.434
*LEN_ILABEL,LEN_RLABEL, PS050793.435
*ICODE,CMESSAGE) PS050793.436
C FIELDCOS.1130
IF(ICODE.NE.0) RETURN FIELDCOS.1131
FIELDCOS.1132
C----------------------------------------------------------------- FIELDCOS.1133
FIELDCOS.1134
C The data has now been read in and has 1) Been read in packed FIELDCOS.1135
C and left packed or 2) read in as packed and then un-packed or FIELDCOS.1136
C 3) The data was never packed at all. If packed FIELD will have FIELDCOS.1137
C LBLREC/2 values if a DUMP and LBLREC values if a PP_FILE. If FIELDCOS.1138
C the data is not packed FIELD will have the no of data points FIELDCOS.1139
C length LBROW*LBNPT+LBEXT if a pp_file and LBLREC if a dump file. FIELDCOS.1140
C FIELDCOS.1141
C For a dump LBLREC will hold origonal no of data points. For a FIELDCOS.1142
C pp_file LBLREC will hold the no of CRAY words needed to hold FIELDCOS.1143
C the data (if un-packed also no of data points) FIELDCOS.1144
C FIELDCOS.1145
C The value returned in ILABEL(LBLREC) may have to change because FIELDCOS.1146
C IEEE only has a 32 bit word length compared to the CRAY's 64 FIELDCOS.1147
C bit word length. In IEEE ILABEL(LBLREC) will be no of 32 bit FIELDCOS.1148
C words needed to hold the data . If the data is not packed (or FIELDCOS.1149
C it has been un-packed) then this will be the no of data points. FIELDCOS.1150
C If the data is left packed the value of ILABEL(LBLREC) FIELDCOS.1151
C will have to be doubled as the no of 32bit words needed to FIELDCOS.1152
C hold the data will twice that on the CRAY. FIELDCOS.1153
FIELDCOS.1154
C On output the data will either have been converted to IEEE FIELDCOS.1155
C numbers and stored in IEEE_FIELD or left packed in FIELD,but with FIELDCOS.1156
C 32 bit ieee numbers substituted into minimum values. FIELDCOS.1157
C If packed then LBLREC/2 words of FIELD are written as LBLREC is FIELDCOS.1158
C now the no of 32 bit words. If un-packed IEEE_FIELD which has size FIELDCOS.1159
C IDIM/2 (or NUM_VALUES/2) is written as it is. FIELDCOS.1160
FIELDCOS.1161
C----------------------------------------------------------------- FIELDCOS.1162
c decode LBPACK FIELDCOS.1163
PACK_TYPE = MOD(ILABEL(LBPACK),10) FIELDCOS.1164
DATA_COMP = MOD(ILABEL(LBPACK),100) - PACK_TYPE FIELDCOS.1165
DATA_COMP_DEF = MOD(ILABEL(LBPACK),1000) -DATA_COMP -PACK_TYPE FIELDCOS.1166
NUMBER_FORMAT = ILABEL(LBPACK)/1000 FIELDCOS.1167
FIELDCOS.1168
IF(PACK_TYPE.GT.0) PACKED=.TRUE. FIELDCOS.1169
IF(PACKED) THEN ! Data left in packed form. Number of PS290193.6
ILABEL(LBLREC)=ILABEL(LBLREC)*2 ! IEEE words needed is 2*CRAY PS290193.7
ENDIF FIELDCOS.1180
C verify that don't have extra data and packing at once FIELDCOS.1181
IF (IEXTRAW.GT.0.AND.PACKED) THEN FIELDCOS.1182
CMESSAGE='FIELDCOS: Extra data with packing not supported' FIELDCOS.1183
ICODE=1 FIELDCOS.1184
RETURN FIELDCOS.1185
ENDIF FIELDCOS.1186
FIELDCOS.1187
CL Convert ILABEL to IBM(Hitachi) integers. FIELDCOS.1188
C For either an accumulation or time mean (ie LBTIM.ne.0) the start & FIELDCOS.1189
C end time are in a different order to the data and veri time for a FIELDCOS.1190
C snap shot type field. This anomaly has to be catered for operational FIELDCOS.1191
C use. Thus the PP package will not work properly on accum/time mn field FIELDCOS.1192
C for operational Fields files. FIELDCOS.1193
IF(ILABEL(lbtim).NE.11.AND.OPER) THEN PS050793.437
C re -calculate the data time from the end time and fcst period FIELDCOS.1195
C First calculate the no of seconds from day 0 FIELDCOS.1196
END_YEAR=ILABEL(LBYRD) FIELDCOS.1197
END_MONTH=ILABEL(LBMOND) FIELDCOS.1198
END_DAY=ILABEL(LBDATD) FIELDCOS.1199
END_HOUR=ILABEL(LBHRD) FIELDCOS.1200
END_MINUTE=ILABEL(LBMIND) FIELDCOS.1201
END_DAY_NUMBER=ILABEL(LBDAYD) TJ080294.81
END_SECOND=0 PS190494.5
FCST_PRD=ILABEL(LBFT) FIELDCOS.1203
C WRITE(6,*)' START YR/MO/DA/HR/MIN BEFORE ',ILABEL(1),ILABEL(2), GIE0F403.183
C * ILABEL(3),ILABEL(4),ILABEL(5) FIELDCOS.1205
C WRITE(6,*)' END YR/MO/DA/HR/MIN BEFORE ',ILABEL(7),ILABEL(8), GIE0F403.184
C * ILABEL(9),ILABEL(10),ILABEL(11) FIELDCOS.1207
C WRITE(6,*)' FCST_PRD BEFORE ',FCST_PRD GIE0F403.185
CALL TIME2SEC (END_YEAR,END_MONTH,END_DAY,END_HOUR, FIELDCOS.1209
* END_MINUTE,END_SECOND,0,0, TJ080294.71
* END_TIME_DAYS,END_TIME_SECS,LCAL360) GSS1F304.312
FIELDCOS.1211
C Subtract forecast hours from end time in (days,seconds) TJ080294.92
TJ080294.93
CALL TIME_DF(END_TIME_DAYS,END_TIME_SECS,0,-FCST_PRD*3600, TJ080294.94
* START_TIME_DAYS,START_TIME_SECS) TJ080294.95
FIELDCOS.1213
C Go back and re-calculate Year/Month/Day/Hour/Sec. FIELDCOS.1214
CALL SEC2TIME(0,0,START_TIME_DAYS,START_TIME_SECS, TJ080294.73
* DATA_YEAR,DATA_MONTH,DATA_DAY, TJ080294.74
* DATA_HOUR,DATA_MINUTE,DATA_SECOND,DATA_DAY_NUMBER, GSS1F304.313
* LCAL360) GSS1F304.314
ILABEL(LBYRD)=DATA_YEAR FIELDCOS.1218
ILABEL(LBMOND)=DATA_MONTH FIELDCOS.1219
ILABEL(LBDATD)=DATA_DAY FIELDCOS.1220
ILABEL(LBHRD)=DATA_HOUR FIELDCOS.1221
ILABEL(LBMIND)=DATA_MINUTE FIELDCOS.1222
ILABEL(LBDAYD)=DATA_DAY_NUMBER TJ080294.82
ILABEL(LBYR)=END_YEAR FIELDCOS.1223
ILABEL(LBMON)=END_MONTH FIELDCOS.1224
ILABEL(LBDAT)=END_DAY FIELDCOS.1225
ILABEL(LBHR)=END_HOUR FIELDCOS.1226
ILABEL(LBMIN)=END_MINUTE FIELDCOS.1227
ILABEL(LBDAY)=END_DAY_NUMBER TJ080294.83
C WRITE(6,*)' -----------------------------------------------' GIE0F403.186
C WRITE(6,*)' Veri YR/MO/DA/HR/MIN AFTER ',ILABEL(1),ILABEL(2), GIE0F403.187
C * ILABEL(3),ILABEL(4),ILABEL(5) FIELDCOS.1230
C WRITE(6,*)' Data YR/MO/DA/HR/MIN AFTER ',ILABEL(7),ILABEL(8), GIE0F403.188
C * ILABEL(9),ILABEL(10),ILABEL(11) FIELDCOS.1232
C WRITE(6,*)' FCST_PRD AFTER ',FCST_PRD GIE0F403.189
C WRITE(6,*)' -----------------------------------------------' GIE0F403.190
C WRITE(6,*)' -----------------------------------------------' GIE0F403.191
ENDIF FIELDCOS.1236
FIELDCOS.1237
C data now in IEEE format FIELDCOS.1238
ILABEL(LBPACK) = ILABEL(LBPACK) - NUMBER_FORMAT*1000 + 3000 FIELDCOS.1239
FIELDCOS.1240
CL Convert ILABEL to IEEE Integer PS050793.438
BIT_OFF=0 FIELDCOS.1241
IEEE_ADDR = 1 PS050793.439
IER=CRI2IEG(2,LEN_ILABEL,IEEE_LABEL(IEEE_ADDR),BIT_OFF,ILABEL, UIE1F402.41
& 1,64,32) UIE1F402.42
IF(IER.NE.0) THEN FIELDCOS.1243
ICODE=1 FIELDCOS.1244
CMESSAGE=' CRAY_IEEE error converting INT for IEEE_LABEL' PS050793.441
RETURN FIELDCOS.1246
ENDIF FIELDCOS.1247
CL Convert RLABEL to IEEE Real. FIELDCOS.1248
IEEE_ADDR=LEN_ILABEL/2 PS050793.442
IF(IEEE_ADDR*2.NE.LEN_ILABEL) BIT_OFF=32 PS050793.443
IEEE_ADDR=IEEE_ADDR+1 PS050793.444
IER=CRI2IEG(3,LEN_RLABEL,IEEE_LABEL(IEEE_ADDR),BIT_OFF,RLABEL, UIE1F402.43
& 1,64,32) UIE1F402.44
IF(IER.NE.0) THEN FIELDCOS.1251
ICODE=1 FIELDCOS.1252
CMESSAGE=' CRAY_IEEE error converting REAL for IEEE_LABEL' PS050793.446
RETURN FIELDCOS.1254
ENDIF FIELDCOS.1255
BIT_OFF=0 PS050793.447
IF(.NOT.PACKED) THEN FIELDCOS.1256
CL Convert Real DATA to IEEE Real if not packed. FIELDCOS.1257
IF(ILABEL(DATA_TYPE).EQ.1) THEN !Data Type Real FIELDCOS.1258
if(ilabel(32).eq.74) then APS2F304.29
WRITE(6,*)'convert type 74 as logical and reset datatype' GIE0F403.192
IER = CRI2IEG(5,NUM_VALUES-IEXTRAW,IEEE_FIELD,BIT_OFF,FIELD, UIE1F402.45
& 1,64,32) UIE1F402.46
ILABEL(DATA_TYPE) = 3 APS2F304.32
else APS2F304.33
IER=CRI2IEG(3,NUM_VALUES-IEXTRAW,IEEE_FIELD,BIT_OFF,FIELD, UIE1F402.47
& 1,64,32) UIE1F402.48
IF(IER.NE.0) THEN FIELDCOS.1260
ICODE=1 FIELDCOS.1261
CMESSAGE='CRAY_IEEE error converting REAL for IEEE_FIELD' FIELDCOS.1262
RETURN FIELDCOS.1263
ENDIF FIELDCOS.1264
endif APS2F304.34
CL Convert Integer data to IEEE Integer. FIELDCOS.1265
ELSEIF(ILABEL(DATA_TYPE).EQ.2) THEN !Data Type Integer FIELDCOS.1266
IER=CRI2IEG(2,NUM_VALUES-IEXTRAW,IEEE_FIELD,BIT_OFF,FIELD, UIE1F402.49
& 1,64,32) UIE1F402.50
IF(IER.NE.0) THEN FIELDCOS.1268
ICODE=1 FIELDCOS.1269
CMESSAGE='CRAY_IEEE error calling USICTI for IEEE_FIELD' FIELDCOS.1270
RETURN FIELDCOS.1271
ENDIF FIELDCOS.1272
ELSEIF(ILABEL(DATA_TYPE).EQ.3) THEN !Data Type Logical FIELDCOS.1273
IER = CRI2IEG(5,NUM_VALUES-IEXTRAW,IEEE_FIELD,BIT_OFF,FIELD, UIE1F402.51
& 1,64,32) UIE1F402.52
IF(IER.NE.0) THEN APS2F304.36
ICODE=1 FIELDCOS.1274
CMESSAGE='CRAY_IEEE error converting logical forIEEE_FIELD' APS2F304.37
RETURN FIELDCOS.1276
ENDIF APS2F304.38
ENDIF FIELDCOS.1277
ELSE FIELDCOS.1278
WRITE(6,*)'WARNING ! WGDOS packed data - contains IBM reals' GIE0F403.193
FIELDCOS.1280
c code to be added here to convert ibm reals in packed data FIELDCOS.1281
c to ieee reals FIELDCOS.1282
FIELDCOS.1283
ENDIF FIELDCOS.1284
FIELDCOS.1285
CL process extra data FIELDCOS.1286
IF (IEXTRAW.GT.0) THEN ! process extra data as got some FIELDCOS.1287
CL init values for while loop FIELDCOS.1288
ADDR=NUM_VALUES-IEXTRAW+1 ! start address in field for extra dat FIELDCOS.1289
IEEE_ADDR=(ADDR+1)/2 FIELDCOS.1290
IF (IEEE_ADDR*2.EQ.ADDR) THEN FIELDCOS.1291
BIT_OFF=32 FIELDCOS.1292
ELSE FIELDCOS.1293
BIT_OFF=0 FIELDCOS.1294
ENDIF FIELDCOS.1295
FIELDCOS.1296
DO WHILE (ADDR.LT.NUM_VALUES) FIELDCOS.1297
CL main while loop that works out code and then checks that code is FIELDCOS.1298
CL ok. FIELDCOS.1299
CL if code is ok then data_values weill contain the number of REAL entri FIELDCOS.1300
CL the vector. FIELDCOS.1301
IV=INT_FROM_REAL(FIELD(ADDR)) FIELDCOS.1302
CALL CHECK_EXTRA(IV,DATA_VALUES,ICODE,CMESSAGE) FIELDCOS.1303
IF (ICODE.NE.0) THEN FIELDCOS.1304
RETURN FIELDCOS.1305
ENDIF FIELDCOS.1306
IER=CRI2IEG(2,1,IEEE_FIELD(IEEE_ADDR),BIT_OFF,FIELD(ADDR), UIE1F402.53
& 1,64,32) UIE1F402.54
C convert the integer from cray format to IEEE format FIELDCOS.1308
IF (IER.NE.0) THEN FIELDCOS.1309
ICODE=1 FIELDCOS.1310
CMESSAGE='CRAY_IEEE: FAILED IN INTEGER CONV OF EXTRA DATA' FIELDCOS.1311
RETURN FIELDCOS.1312
ENDIF FIELDCOS.1313
FIELDCOS.1314
CL update bit_off, addr and IEEE_addr FIELDCOS.1315
IF (BIT_OFF.EQ.0) THEN FIELDCOS.1316
BIT_OFF=32 FIELDCOS.1317
ELSE FIELDCOS.1318
BIT_OFF=0 FIELDCOS.1319
IEEE_ADDR=IEEE_ADDR+1 ! gone on another word.. FIELDCOS.1320
ENDIF FIELDCOS.1321
ADDR=ADDR+1 ! increment address FIELDCOS.1322
CL now to convert REAL vector to IEEE format. FIELDCOS.1323
IER=CRI2IEG(3,DATA_VALUES,IEEE_FIELD(IEEE_ADDR), UIE1F402.55
& BIT_OFF,FIELD(ADDR),1,64,32) UIE1F402.56
C convert the real data values FIELDCOS.1326
IF (IER.NE.0) THEN FIELDCOS.1327
ICODE=1 FIELDCOS.1328
CMESSAGE='CRAY_IEEE: FAILED IN REAL CONV OF EXTRA DATA' FIELDCOS.1329
RETURN FIELDCOS.1330
ENDIF FIELDCOS.1331
CL update loop variables. FIELDCOS.1332
ADDR=ADDR+DATA_VALUES FIELDCOS.1333
IEEE_ADDR=IEEE_ADDR+DATA_VALUES/2 FIELDCOS.1334
IF ((DATA_VALUES/2)*2.NE.DATA_VALUES) THEN ! odd no. of values FIELDCOS.1335
IF (BIT_OFF.EQ.0) THEN FIELDCOS.1336
BIT_OFF=32 FIELDCOS.1337
ELSE FIELDCOS.1338
BIT_OFF=0 FIELDCOS.1339
IEEE_ADDR=IEEE_ADDR+1 ! gone on another word.. FIELDCOS.1340
ENDIF FIELDCOS.1341
ENDIF FIELDCOS.1342
ENDDO ! continue unitil run out of data.... FIELDCOS.1343
CL Verify addr and IEEE_addr have correct values at end of whileloop FIELDCOS.1344
CL first check that addr is ok FIELDCOS.1345
IF (ADDR.NE.NUM_VALUES+1) THEN FIELDCOS.1346
WRITE(CMESSAGE,109)ADDR,NUM_VALUES+1 FIELDCOS.1347
109 FORMAT('CRAY_IEEE: ADDR',I5,1X,'<> NUM_VALUES+1',I5) GPB0F405.149
ICODE=1 FIELDCOS.1349
RETURN FIELDCOS.1350
ENDIF FIELDCOS.1351
CL and so is IEEE_addr FIELDCOS.1352
IF (BIT_OFF.EQ.0) IEEE_ADDR=IEEE_ADDR-1 FIELDCOS.1353
IF (IEEE_ADDR.NE.(NUM_VALUES+1)/2) THEN FIELDCOS.1354
WRITE(CMESSAGE,110)IEEE_ADDR,(NUM_VALUES+1)/2 FIELDCOS.1355
110 FORMAT('CRAY_IEEE: IEEE_ADDR ',I5,1X, GPB0F405.150
& ' <> (NUM_VALUES+1)/2',I5) GPB0F405.151
ICODE=1 FIELDCOS.1357
RETURN FIELDCOS.1358
ENDIF FIELDCOS.1359
ENDIF ! end processing of extra data FIELDCOS.1360
FIELDCOS.1361
IF(PACKED) THEN FIELDCOS.1362
WRITE(COS_PPUNIT) IEEE_LABEL PS050793.449
WRITE(COS_PPUNIT) (FIELD(I),I=1,ILABEL(LBLREC)/2) PS050793.450
ELSE FIELDCOS.1366
WRITE(COS_PPUNIT) IEEE_LABEL PS050793.451
WRITE(COS_PPUNIT) IEEE_FIELD FIELDCOS.1368
ENDIF FIELDCOS.1369
C FIELDCOS.1370
100 FORMAT(' WRITING COS FILE for IPROJ ITYPE FCT LEVEL',4I6) FIELDCOS.1371
CL The last field has been processed. An extra field is now written FIELDCOS.1372
CL to act as a delimeter for the M08 software. This extra fields is FIELDCOS.1373
CL a duplicate,but with a PP field code of -99 . FIELDCOS.1374
IF(LAST) THEN FIELDCOS.1375
WRITE(6,101) FIELDCOS.1377
101 FORMAT(' WRITING LAST RECORD IN THE COS FILE ') FIELDCOS.1378
ILABEL(23)=-99 FIELDCOS.1379
CL Convert ILABEL to IEEE Integer PS050793.452
BIT_OFF=0 PS050793.453
IEEE_ADDR = 1 PS050793.454
IER=CRI2IEG(2,LEN_ILABEL,IEEE_LABEL(IEEE_ADDR),BIT_OFF,ILABEL, UIE1F402.57
& 1,64,32) UIE1F402.58
IF(IER.NE.0) THEN FIELDCOS.1381
ICODE=1 FIELDCOS.1382
CMESSAGE=' CRAY_IEEE error converting INT for IEEE_LABEL' PS050793.456
RETURN PS050793.457
ENDIF PS050793.458
CL Convert RLABEL to IEEE Real. PS050793.459
IEEE_ADDR=LEN_ILABEL/2 PS050793.460
IF(IEEE_ADDR*2.NE.LEN_ILABEL) BIT_OFF=32 PS050793.461
IEEE_ADDR=IEEE_ADDR+1 PS050793.462
IER=CRI2IEG(3,LEN_RLABEL,IEEE_LABEL(IEEE_ADDR),BIT_OFF,RLABEL, UIE1F402.59
& 1,64,32) UIE1F402.60
IF(IER.NE.0) THEN PS050793.464
ICODE=1 PS050793.465
CMESSAGE=' CRAY_IEEE error converting REAL for IEEE_LABEL' PS050793.466
RETURN FIELDCOS.1384
ENDIF FIELDCOS.1385
IF(PACKED) THEN FIELDCOS.1386
WRITE(COS_PPUNIT) IEEE_LABEL PS050793.467
WRITE(COS_PPUNIT) (FIELD(I),I=1,ILABEL(LBLREC)/2) PS050793.468
ELSE FIELDCOS.1389
WRITE(COS_PPUNIT) IEEE_LABEL PS050793.469
WRITE(COS_PPUNIT) IEEE_FIELD FIELDCOS.1391
ENDIF FIELDCOS.1392
ENDIF FIELDCOS.1393
9999 CONTINUE FIELDCOS.1394
RETURN FIELDCOS.1395
END FIELDCOS.1396
FIELDCOS.1397
!======================================================================= URS4F400.29
! Routine: CRAY_GRIB URS4F400.30
! URS4F400.31
! Purpose: To read a direct access PP file and convert it to a URS4F400.32
! pure grib file ready to be passed to HDS or workstation. URS4F400.33
! URS4F400.34
! Tested under compiler: cft77 URS4F400.35
! Tested under OS version: UNICOS 7 & 8 URS4F400.36
! URS4F400.37
! Model Modification history from model version 3.3: URS4F400.38
! version Date URS4F400.39
! 4.0 31/03/95 : Added to FIELDCOS URS4F400.40
! URS4F400.41
! Programming standard: UM Doc Paper 3, version 1 (15/1/90) URS4F400.42
! URS4F400.43
! Logical components covered: C41 URS4F400.44
! URS4F400.45
! Project task: C4 URS4F400.46
! URS4F400.47
! External documentation: URS4F400.48
! URS4F400.49
!----------------------------------------------------------------------- URS4F400.50
! Interface and arguments: ------------------------------------------ URS4F400.51
! URS4F400.52
SUBROUTINE CRAY_GRIB(IDIM,PPUNIT,TOTAL_WORDS,FORMAT_OUT, 1,1URS4F400.53
& LEN1_LOOKUP,PP_LEN2_LOOKUP,PP_FIXHD,LOOKUP, URS4F400.54
& ROOKUP,ENTRY_NO,DATA_ADD,MODEL_FLAG, URS4F400.55
& COS_PPUNIT,IEXTRA,ICODE,CMESSAGE) URS4F400.56
URS4F400.57
IMPLICIT NONE URS4F400.58
! Arguments URS4F400.59
CHARACTER URS4F400.60
& CMESSAGE*(*) !OUT error messages URS4F400.61
& ,FORMAT_OUT*6 !IN format required URS4F400.62
LOGICAL URS4F400.63
& MODEL_FLAG !IN True => dumps, False => fieldsfile URS4F400.64
INTEGER URS4F400.65
& PPUNIT !IN unit no of required fieldsfile URS4F400.66
& ,TOTAL_WORDS !IN total number of words written URS4F400.67
& ,COS_PPUNIT !IN unit no of COS output file URS4F400.68
& ,IDIM !IN NUM_VALUES rounded to an even no URS4F400.69
! ! used to dimension The output array URS4F400.70
& ,DATA_ADD !IN The word address of the data. URS4F400.71
& ,LEN1_LOOKUP !IN First dimension of the lookup URS4F400.72
& ,PP_LEN2_LOOKUP !IN Size of the LOOKUP on the file URS4F400.73
& ,IEXTRA(10) !IN Used within READFF URS4F400.74
& ,ENTRY_NO !IN Lookup entry no of the Field. URS4F400.75
& ,PP_FIXHD(*) !IN PPfile fixed header URS4F400.76
& ,LOOKUP(LEN1_LOOKUP,PP_LEN2_LOOKUP) !IN integer lookup URS4F400.77
& ,ICODE !OUT error code URS4F400.78
REAL URS4F400.79
& ROOKUP(LEN1_LOOKUP,PP_LEN2_LOOKUP) !IN Real lookup URS4F400.80
!---------------------------------------------------------------------- URS4F400.81
! Called routines URS4F400.82
EXTERNAL READFF,GBYTES,SBYTES URS4F400.83
!---------------------------------------------------------------------- URS4F400.84
! LOCAL VARIABLES URS4F400.85
INTEGER URS4F400.86
& MAX_LEN_ILABEL ! maximum length of INT part of pp header URS4F400.87
& ,MAX_LEN_RLABEL ! maximum length of REAL part of pp header URS4F400.88
PARAMETER (MAX_LEN_ILABEL=45,MAX_LEN_RLABEL=32) URS4F400.89
INTEGER URS4F400.90
& LEN_ILABEL ! number of values in ILABEL URS4F400.91
& ,LEN_RLABEL ! number of values in RLABEL URS4F400.92
& ,ILABEL(MAX_LEN_ILABEL) ! holds integer part of LOOKUP URS4F400.93
& ,I ! local counter URS4F400.94
& ,CARRY ! local counter URS4F400.95
& ,NEW_CODE ! new field code URS4F400.96
& ,ITEM ! item code URS4F400.97
& ,SECTION ! section code URS4F400.98
& ,SECTION1(16) ! UM octet 9 value URS4F400.99
URS4F400.100
REAL URS4F400.101
& FIELD(IDIM) ! array holding data URS4F400.102
& ,RLABEL(MAX_LEN_RLABEL) ! holds real part of LOOKUP URS4F400.103
URS4F400.104
*CALL CLOOKADD URS4F400.105
*CALL CGRIBTAB URS4F400.106
!---------------------------------------------------------------------- URS4F400.107
URS4F400.108
! access the Fields File. URS4F400.109
CALL READFF(PPUNIT,FIELD,IDIM,ENTRY_NO,ILABEL,RLABEL,IEXTRA, URS4F400.110
& PP_LEN2_LOOKUP,LEN1_LOOKUP,PP_FIXHD,LOOKUP,ROOKUP, URS4F400.111
& DATA_ADD,MODEL_FLAG,MAX_LEN_ILABEL,MAX_LEN_RLABEL, URS4F400.112
& LEN_ILABEL,LEN_RLABEL,ICODE,CMESSAGE) URS4F400.113
URS4F400.114
IF(ICODE.NE.0) RETURN URS4F400.115
URS4F400.116
!----------------------------------------------------------------- URS4F400.117
! Alter field codes if required URS4F400.118
! FORMAT_OUT URS4F400.119
! GRIB - UM stash codes - no change URS4F400.120
! GRIB1 - attempt to alter codes to standard table 2 values URS4F400.121
! GRIB2 - attempt to alter codes to other user table 2 URS4F400.122
! URS4F400.123
IF (FORMAT_OUT.EQ.'GRIB1'.OR.FORMAT_OUT.EQ.'GRIB2') THEN URS4F400.124
SECTION=ILABEL(42)/1000 URS4F400.125
ITEM=ILABEL(42) - SECTION*1000 URS4F400.126
NEW_CODE=GRIB_TABLE(SECTION,ITEM) URS4F400.127
IF (NEW_CODE.EQ.-99) THEN URS4F400.128
WRITE(6,*)' No standard grib code for field ',ilabel(42),' field GIE0F403.194
& will not be output' URS4F400.130
RETURN URS4F400.131
ELSE URS4F400.132
! Assumes running on a 64 bit word machine URS4F400.133
! Therefore section 0 is field (1) & section 1 starts at field(2) URS4F400.134
! Need to alter octets 4 and 9 in section 1 URS4F400.135
! decode first 16 octets of grib message URS4F400.136
CALL GBYTES(field(2),section1(1),0,8,0,16) URS4F400.137
SECTION1(4)=1 URS4F400.138
SECTION1(9)=new_code URS4F400.139
! recode first 16 octets of grib message URS4F400.140
CALL SBYTES(field(2),section1(1),0,8,0,16) URS4F400.141
ENDIF URS4F400.142
ENDIF URS4F400.143
!----------------------------------------------------------------- URS4F400.144
! write out pure grib code URS4F400.145
URS4F400.146
WRITE(COS_PPUNIT) (FIELD(I),I=1,ILABEL(LBLREC)) URS4F400.147
WRITE(6,100) ILABEL(42),ILABEL(LBLREC) URS4F400.148
TOTAL_WORDS=TOTAL_WORDS+ilabel(lblrec) URS4F400.149
100 FORMAT(1x,' written out grib for ',i6,' length of data',i8) URS4F400.150
URS4F400.151
RETURN URS4F400.152
END URS4F400.153
! ===================================================================== URS4F400.154
CLL Routine: READFF--------------------------------------------------- FIELDCOS.1398
CLL FIELDCOS.1399
CLL Purpose: To read a direct access PP file. FIELDCOS.1400
CLL FIELDCOS.1401
CLL Author: P.Trevelyan FIELDCOS.1402
CLL FIELDCOS.1403
CLL Tested under compiler: cft77 FIELDCOS.1404
CLL Tested under OS version: UNICOS 5.1 FIELDCOS.1405
CLL FIELDCOS.1406
CLL Model Modification history from model version 3.0: FIELDCOS.1407
CLL version Date FIELDCOS.1408
CLL FIELDCOS.1409
CLL 3.4 29/06/94 Correct unpacking of 32 bit data. Error affected UDR3F304.1
CLL odd-length fields. PP and Stash codes added to UDR3F304.2
CLL output. D. Robinson UDR3F304.3
CLL UDR3F304.4
CLL Programming standard: UM Doc Paper 3, version 1 (15/1/90) FIELDCOS.1410
CLL FIELDCOS.1411
CLL Logical components covered: FIELDCOS.1412
CLL FIELDCOS.1413
CLL Project task: FIELDCOS.1414
CLL FIELDCOS.1415
CLL External documentation: FIELDCOS.1416
CLL FIELDCOS.1417
CLL ------------------------------------------------------------------- FIELDCOS.1418
C*L Interface and arguments: ------------------------------------------ FIELDCOS.1419
SUBROUTINE READFF(PPUNIT,FIELD,IDIM,ENTRY_NO, 6,7FIELDCOS.1420
*ILABEL,RLABEL,IEXTRA,PP_LEN2_LOOKUP,LEN1_LOOKUP, FIELDCOS.1421
*PP_FIXHD,LOOKUP,ROOKUP,DATA_ADD, PS050793.470
*MODEL_FLAG,MAX_LEN_ILABEL,MAX_LEN_RLABEL, PS050793.471
*LEN_ILABEL,LEN_RLABEL, PS050793.472
*ICODE,CMESSAGE) PS050793.473
IMPLICIT NONE FIELDCOS.1423
C arguments PS050793.474
CHARACTER PS050793.475
& CMESSAGE*(*) !OUT error message PS050793.476
LOGICAL PS050793.477
& MODEL_FLAG !IN True => Dump False =>Fieldsfile PS050793.478
INTEGER FIELDCOS.1428
& LEN1_LOOKUP !IN first dimension of the lookup FIELDCOS.1429
& ,PP_LEN2_LOOKUP !IN secnd dimension of the lookup FIELDCOS.1430
& ,PPUNIT !IN unit no of required fieldsfile FIELDCOS.1431
& ,IDIM !IN dimension of FIELD FIELDCOS.1432
& ,MAX_LEN_RLABEL !IN max sixe of RLABEL PS050793.479
& ,MAX_LEN_ILABEL !IN max sixe of ILABEL PS050793.480
& ,IEXTRA(10) !IN spare for future use FIELDCOS.1434
& ,DATA_ADD !IN The word address of the data. FIELDCOS.1437
& ,ENTRY_NO !IN Lookup entry no of the Field. FIELDCOS.1438
& ,PP_FIXHD(*) !IN PPfile fixed header PS050793.481
& ,LOOKUP(LEN1_LOOKUP,PP_LEN2_LOOKUP) !IN integer lookup PS050793.482
& ,LEN_RLABEL !OUT actual size of RLABEL PS050793.483
& ,LEN_ILABEL !OUT actual size of ILABEL PS050793.484
& ,ILABEL(MAX_LEN_ILABEL) !OUT integer part of LOOKUP PS050793.485
& ,ICODE !OUT error code PS050793.486
REAL FIELDCOS.1442
& FIELD(IDIM) !OUT array holding final output data. FIELDCOS.1443
& ,ROOKUP(LEN1_LOOKUP,PP_LEN2_LOOKUP) !IN real lookup PS050793.487
& ,RLABEL(MAX_LEN_RLABEL) !OUT real part of LOOKUP PS050793.488
C*--------------------------------------------------------------------- PS050793.489
C Called routines PS050793.490
EXTERNAL SETPOS,READ_REC,IOERROR,COEX, PS050793.491
& INTEGER_TO _REAL,LOGICAL_TO_REAL PS050793.492
C*--------------------------------------------------------------------- PS050793.493
C arguments for called routines PS050793.494
INTEGER PS050793.495
& PACK_TYPE ! packing type N1 of LBPACK PS050793.496
& ,NUM_CRAY_WORDS ! number of words for field PS050793.497
& ,NVALS ! number of points in a data field PS050793.498
& ,IWA ! Word address in call SETPOS PS050793.499
C*--------------------------------------------------------------------- PS050793.500
C LOCAL VARIABLES FIELDCOS.1446
INTEGER FIELDCOS.1450
& I ! Local counter FIELDCOS.1451
& ,J ! Local counter FIELDCOS.1452
& ,LENGTH_OF_DATA ! Length of a particular field FIELDCOS.1457
& ,ADDR ! Address of a field in the data store FIELDCOS.1458
& ,IN_LBVC ! Local copy of LBVC required to searc FIELDCOS.1459
& ,NUM_IBM_WORDS ! No of IBM words used to hold the dat FIELDCOS.1460
& ,POS_RLABEL ! position of first REAL in PPhdr PS050793.501
& ,PACK_TYPE_I ! packing type N1 of LBPACK PS050793.502
& ,DATA_COMP ! data compression code PS050793.503
& ,DATA_COMP_DEF ! data compression definition PS050793.504
& ,NUMBER_FORMAT ! number format PS050793.505
REAL PS050793.506
& AMDI ! Missing data indicator for lookup UIE0F404.21
PS050793.509
*CALL CLOOKADD PS050793.510
*CALL C_MDI PS050793.511
PS050793.512
AMDI=ROOKUP(BMDI,ENTRY_NO) PS050793.513
IF (AMDI.NE.RMDI) WRITE(6,*)' NONE STANDARD MISSING DATA USED' GIE0F403.195
PS050793.515
C FIELDCOS.1470
c CALL PR_LOOK(LOOKUP(1,1),ROOKUP(1,1),ENTRY_NO) PS050793.516
C FIELDCOS.1477
c decode LBPACK FIELDCOS.1478
PACK_TYPE = MOD(LOOKUP(LBPACK,ENTRY_NO),10) FIELDCOS.1479
DATA_COMP = MOD(LOOKUP(LBPACK,ENTRY_NO),100) - PACK_TYPE FIELDCOS.1480
DATA_COMP_DEF = MOD(LOOKUP(LBPACK,ENTRY_NO),1000) FIELDCOS.1481
- -DATA_COMP -PACK_TYPE FIELDCOS.1482
NUMBER_FORMAT = LOOKUP(LBPACK,ENTRY_NO)/1000 FIELDCOS.1483
C---------------------------------------------------------------------- FIELDCOS.1484
C=== Reading a model type dump ======================================= FIELDCOS.1485
C A model dump has no direct addressing only relative. FIELDCOS.1486
C FIELDCOS.1487
IF(MODEL_FLAG) THEN FIELDCOS.1491
! Old Format dumpfiles UIE0F404.2
if((lookup(lbnrec,entry_no).eq.0) .or. UIE0F404.3
! Prog lookups in dump before vn3.2: UIE0F404.4
& ((lookup(lbnrec,entry_no).eq.imdi) .and. UIE0F404.5
& (pp_fixhd(12).le.301))) then UIE0F404.6
UIE0F404.7
IF(PACK_TYPE.EQ.2) THEN ! 32 bit packing. UDR3F304.5
NUM_CRAY_WORDS=(LOOKUP(LBLREC,ENTRY_NO)+1)/2 UDR3F304.6
ELSEIF(PACK_TYPE.GT.0) THEN UDR3F304.7
NUM_CRAY_WORDS=LOOKUP(LBLREC,ENTRY_NO)/2 FIELDCOS.1493
ELSE FIELDCOS.1494
NUM_CRAY_WORDS=LOOKUP(LBLREC,ENTRY_NO) FIELDCOS.1495
ENDIF FIELDCOS.1496
NVALS=LOOKUP(LBLREC,ENTRY_NO) ! No of data points FIELDCOS.1497
ADDR=DATA_ADD FIELDCOS.1498
IF(ENTRY_NO.GT.1) THEN FIELDCOS.1499
DO I=1,ENTRY_NO-1 FIELDCOS.1500
PACK_TYPE_I = MOD(LOOKUP(LBPACK,I),10) FIELDCOS.1501
IF(PACK_TYPE_I.EQ.2) THEN ! 32 Bit packed FIELDCOS.1502
LENGTH_OF_DATA=(LOOKUP(LBLREC,I)+1)/2 UDR3F304.8
ELSE FIELDCOS.1504
LENGTH_OF_DATA=LOOKUP(LBLREC,I) FIELDCOS.1505
ENDIF FIELDCOS.1506
ADDR=ADDR+LENGTH_OF_DATA FIELDCOS.1507
ENDDO FIELDCOS.1508
ELSE ! If the first entry. FIELDCOS.1509
ADDR=DATA_ADD ! FIELDCOS.1510
IF(PACK_TYPE.EQ.2) THEN ! 32 Bit packed FIELDCOS.1511
LENGTH_OF_DATA=(LOOKUP(LBLREC,1)+1)/2 UDR3F304.9
ELSE FIELDCOS.1513
LENGTH_OF_DATA=LOOKUP(LBLREC,1) FIELDCOS.1514
ENDIF FIELDCOS.1515
WRITE(6,*)' LENGTH_OF_DATA ',LENGTH_OF_DATA GIE0F403.196
ENDIF FIELDCOS.1517
IWA=ADDR ! Not -1 as this is already done in dump FIELDCOS.1518
Else UIE0F404.8
! New format Dumpfiles (vn4.4 onwards) UIE0F404.9
UIE0F404.10
If(pack_type.eq.2) then ! 32 bit packing. UIE0F404.11
num_cray_words=(lookup(lblrec,entry_no)+1)/2 UIE0F404.12
Elseif(pack_type.gt.0) then UIE0F404.13
num_cray_words=lookup(lblrec,entry_no)/2 UIE0F404.14
Else UIE0F404.15
num_cray_words=lookup(lblrec,entry_no) UIE0F404.16
Endif UIE0F404.17
iwa = lookup(lbegin,entry_no) UIE0F404.18
nvals = lookup(lbrow,entry_no) * lookup(lbnpt,entry_no) UIE0F404.19
Endif UIE0F404.20
ELSE FIELDCOS.1519
C=== Reading a PP type file.========================================== FIELDCOS.1520
NUM_CRAY_WORDS=LOOKUP(LBLREC,ENTRY_NO) ! PP type file FIELDCOS.1521
IWA=LOOKUP(LBEGIN,ENTRY_NO) FIELDCOS.1522
NVALS=LOOKUP(LBROW,ENTRY_NO)*LOOKUP(LBNPT,ENTRY_NO) FIELDCOS.1523
& +LOOKUP(LBEXT,ENTRY_NO) FIELDCOS.1524
ENDIF FIELDCOS.1525
C============================================================== FIELDCOS.1526
C WRITE(6,107) ENTRY_NO,NUM_CRAY_WORDS,NVALS FIELDCOS.1527
107 FORMAT(' ENTRY NO=',I5,'NUM_CRAY_WORDS= ',I6,'NVALS=',I6) FIELDCOS.1528
IF(IDIM.LT.NUM_CRAY_WORDS) THEN FIELDCOS.1529
ICODE=NUM_CRAY_WORDS FIELDCOS.1530
CMESSAGE='READFF Idim to small ICODE holds correct value' FIELDCOS.1531
GOTO 9999 FIELDCOS.1532
ENDIF FIELDCOS.1533
ICODE=0 FIELDCOS.1534
C RETURN FIELDCOS.1535
CALL READ_REC(FIELD,NUM_CRAY_WORDS,IWA,PPUNIT,ICODE,CMESSAGE) FIELDCOS.1536
2212 FORMAT(' FIELDS FILE NUMBER ',I2,' ON UNIT',I2,2X,'BEING READ') FIELDCOS.1537
NUM_IBM_WORDS=NUM_CRAY_WORDS*2 FIELDCOS.1538
UDR3F304.10
WRITE(7,106) ENTRY_NO, ! Field No UDR3F304.11
* LOOKUP(LBTYP,ENTRY_NO), ! M08 Type UDR3F304.12
* LOOKUP(LBFC,ENTRY_NO), ! PP Field Code UDR3F304.13
* LOOKUP(ITEM_CODE,ENTRY_NO), ! Stash Code UDR3F304.14
* LOOKUP(LBLEV,ENTRY_NO), ! M08 Level UDR3F304.15
* LOOKUP(LBFT,ENTRY_NO), ! Forecast period UDR3F304.16
* LOOKUP(LBPROJ,ENTRY_NO), ! M08 Projection no UDR3F304.17
* NUM_IBM_WORDS, UDR3F304.18
* NVALS, UDR3F304.19
* PACK_TYPE ! Packing Code UIE0F404.22
UDR3F304.22
106 FORMAT(' Field No ',I4,' M08/PP/Stash Code ',I3,I5,I6, UDR3F304.23
& ' Level ',I5,' Fcst ',I5,' Proj ',I3, UDR3F304.24
& ' NWords=',I6,' NVals=',I5,' Pack Type=',I2) UIE0F404.23
UDR3F304.26
IF(ICODE.EQ.0) THEN FIELDCOS.1548
POS_RLABEL=MOD(LOOKUP(LBREL,ENTRY_NO),100) PS050793.517
PS050793.518
! Treat lookup(45) as an integer to preserve submodel UIE0F402.1
! identifier in PP fields transferred between Cray and IBM. UIE0F402.2
POS_RLABEL=46 UIE0F402.3
PS050793.526
PS050793.527
LEN_RLABEL=1+LEN1_LOOKUP-POS_RLABEL PS050793.528
LEN_ILABEL=LEN1_LOOKUP-LEN_RLABEL PS050793.529
DO I=1,LEN_ILABEL PS050793.530
ILABEL(I)=LOOKUP(I,ENTRY_NO) PS050793.531
ENDDO PS050793.532
PS190494.6
C check for valid release number PS190494.7
if(ilabel(lbrel).lt.1) then PS190494.8
WRITE(6,*)' resetting LBREL from',ilabel(lbrel),' to 2' GIE0F403.197
ilabel(lbrel)=2 PS190494.10
endif PS190494.11
PS050793.533
C test of header with position of reals PS050793.534
PS050793.535
c ilabel(lbrel)= 3*1000 + pos_rlabel PS050793.536
c ilabel(lbrel)= 3 PS050793.537
c ilabel(lbsrce)=pos_rlabel PS050793.538
PS050793.539
c end of test PS050793.540
PS050793.541
DO I=1,LEN_RLABEL PS050793.542
RLABEL(I)=ROOKUP(I+POS_RLABEL-1,ENTRY_NO) PS050793.543
ENDDO PS050793.544
ENDIF FIELDCOS.1555
C======================================================================= FIELDCOS.1556
C At this point FIELD holds the data either PACKED or UN-PACKED FIELDCOS.1557
C Is the packing indicator set and is un-packing required? If so then FIELDCOS.1558
C the data is temp un-packed into a work ARRAY of length IDIM FIELDCOS.1559
IF(PACK_TYPE.GT.0) THEN ! Is the field packed. FIELDCOS.1560
IF(IEXTRA(1).EQ.0) THEN ! unpacking is required FIELDCOS.1561
CALL UN_PACK(PACK_TYPE,IDIM,FIELD,NUM_CRAY_WORDS, PS050793.545
& ILABEL,LEN_ILABEL,aMDI,PP_FIXHD,ICODE,CMESSAGE) PS050793.546
C WRITE(7,*) ' NOW UNPACKED INTO ',ILABEL(LBLREC),' WORDS' UDR3F304.27
ENDIF FIELDCOS.1564
ELSEIF(LOOKUP(DATA_TYPE,ENTRY_NO).EQ.3) THEN !Fld is logical FIELDCOS.1565
CALL LOGICAL_TO_REAL(IDIM,FIELD,FIELD,NVALS, FIELDCOS.1566
& ILABEL,ICODE,CMESSAGE) FIELDCOS.1567
ELSEIF(LOOKUP(DATA_TYPE,ENTRY_NO).EQ.2) THEN !Fld is integer FIELDCOS.1568
CALL INTEGER_TO_REAL(IDIM,FIELD,FIELD,NVALS, FIELDCOS.1569
& ILABEL,ICODE,CMESSAGE) FIELDCOS.1570
ENDIF FIELDCOS.1571
C======================================================================= FIELDCOS.1572
9999 CONTINUE FIELDCOS.1573
100 FORMAT(//,32X,' ARRAY ',//,32(16F5.0/)) FIELDCOS.1574
101 FORMAT(//,32X,' LOOKUP ',//,32(16I5/)) FIELDCOS.1575
103 FORMAT(' LENIN ',I12) FIELDCOS.1576
RETURN FIELDCOS.1577
END FIELDCOS.1578
FIELDCOS.1579
CLL Routine: READ_REC-------------------------------------------------- FIELDCOS.1580
CLL FIELDCOS.1581
CLL Purpose: To read a data record from a pp file FIELDCOS.1582
CLL FIELDCOS.1583
CLL Tested under compiler: cft77 FIELDCOS.1584
CLL Tested under OS version: UNICOS 5.1 FIELDCOS.1585
CLL FIELDCOS.1586
CLL Model Modification history from model version 3.0: FIELDCOS.1587
CLL version Date FIELDCOS.1588
CLL FIELDCOS.1589
CLL Programming standard: UM Doc Paper 3, version 1 (15/1/90) FIELDCOS.1590
CLL FIELDCOS.1591
CLL Logical components covered: ... FIELDCOS.1592
CLL FIELDCOS.1593
CLL Project task: ... FIELDCOS.1594
CLL FIELDCOS.1595
CLL External documentation: FIELDCOS.1596
CLL FIELDCOS.1597
CLL ------------------------------------------------------------------- FIELDCOS.1598
C*L Interface and arguments: ------------------------------------------ FIELDCOS.1599
C FIELDCOS.1600
SUBROUTINE READ_REC(FIELD,NUM_CRAY_WORDS,IWA,PPUNIT, 3,6FIELDCOS.1601
& ICODE,CMESSAGE) FIELDCOS.1602
IMPLICIT NONE FIELDCOS.1603
C arguments PS050793.547
CHARACTER CMESSAGE*(*) !OUT error message PS050793.548
INTEGER FIELDCOS.1606
& NUM_CRAY_WORDS !IN No of CRAY words holding the data PS050793.549
& ,PPUNIT !IN unit no of the PP FILE PS050793.550
& ,IWA !IN WORD address of field to be read FIELDCOS.1610
& ,ICODE !OUT error code PS050793.551
REAL FIELDCOS.1611
& FIELD(NUM_CRAY_WORDS) !OUT array holding data FIELDCOS.1612
C*--------------------------------------------------------------------- PS050793.552
C Called routines PS050793.553
EXTERNAL SETPOS,BUFFIN PS050793.554
C*--------------------------------------------------------------------- PS050793.555
C arguments for called routines PS050793.556
INTEGER PS050793.557
& LEN_IO ! length of data read by BUFFIN PS050793.558
REAL PS050793.559
& A_IO ! return code from BUFFIN PS050793.560
C LOCAL VARIABLES FIELDCOS.1613
INTEGER FIELDCOS.1614
& I ! local counter FIELDCOS.1615
& ,J ! local counter FIELDCOS.1616
& ,IX ! used in the UNIT command FIELDCOS.1617
PS050793.561
CALL SETPOS(PPUNIT,IWA,ICODE) GTD0F400.77
CALL BUFFIN(PPUNIT,FIELD,NUM_CRAY_WORDS,LEN_IO,A_IO) FIELDCOS.1623
PS050793.562
RETURN FIELDCOS.1625
END FIELDCOS.1626
CLL Routine: UN_PACK ------------------------------------------------- FIELDCOS.1627
CLL FIELDCOS.1628
CLL Purpose: To unpack data from the input array FIELD and return FIELDCOS.1629
CLL the data in FIELD. FIELDCOS.1630
CLL FIELDCOS.1631
CLL Tested under compiler: cft77 FIELDCOS.1632
CLL Tested under OS version: UNICOS 5.1 FIELDCOS.1633
CLL FIELDCOS.1634
CLL Model Modification history from model version 3.0: FIELDCOS.1635
CLL version Date FIELDCOS.1636
CLL FIELDCOS.1637
CLL Programming standard: UM Doc Paper 3, version 1 (15/1/90) FIELDCOS.1638
CLL FIELDCOS.1639
CLL Logical components covered: FIELDCOS.1640
CLL FIELDCOS.1641
CLL Project task: FIELDCOS.1642
CLL FIELDCOS.1643
CLL External documentation: FIELDCOS.1644
CLL FIELDCOS.1645
CLL ------------------------------------------------------------------- FIELDCOS.1646
C*L Interface and arguments: ------------------------------------------ FIELDCOS.1647
SUBROUTINE UN_PACK(PACK_TYPE,IDIM,FIELD,NUM_CRAY_WORDS, 4,10FIELDCOS.1648
& ILABEL,LEN_ILABEL,AMDI,PP_FIXHD,ICODE,CMESSAGE) PS050793.563
IMPLICIT NONE PS050793.564
C arguments PS050793.565
CHARACTER PS050793.566
& CMESSAGE*(*) !OUT error mesages. PS050793.567
INTEGER FIELDCOS.1650
& PACK_TYPE !INOUT Type of packing used PS050793.568
& ,IDIM !IN full unpacked size of a field PS050793.569
& ,PP_FIXHD(*) !IN PPfile fixed length header PS050793.570
& ,NUM_CRAY_WORDS !IN length of input field PS050793.571
& ,LEN_ILABEL !IN length of ilabel array PS050793.572
& ,ILABEL(LEN_ILABEL) !INOUT holds integer part of LOOKUP PS050793.573
& ,ICODE !OUT Non zero for any error PS050793.574
REAL FIELDCOS.1656
& FIELD(IDIM) !INOUT Input contains packed data. PS050793.575
C ! Output contains un-packed data. PS050793.576
& ,AMDI !IN Missing data indicator. PS050793.577
C*--------------------------------------------------------------------- PS050793.578
C Called routines PS050793.579
EXTERNAL COEX,EXPAND21,P21BITS UIE1F403.12
INTEGER P21BITS FIELDCOS.1665
C*--------------------------------------------------------------------- PS050793.580
C arguments for called routines PS050793.581
INTEGER FIELDCOS.1670
& LEN_FULL_WORD ! The length of a FULL_WORD FIELDCOS.1671
& ,IXX ! Returned X dimension from COEX FIELDCOS.1672
& ,IYY ! Returned Y dimension from COEX FIELDCOS.1673
& ,IDUM ! Dummy variable FIELDCOS.1674
REAL PS050793.582
& WORK_ARRAY(IDIM) !WORK array used for un_packing PS050793.583
PS050793.584
C LOCAL VARIABLES PS050793.585
INTEGER PS050793.586
& NUM_UNPACK_VALUES ! Number of numbers originally packed PS050793.587
& ,I ! loop counter PS050793.588
C FIELDCOS.1677
*CALL CLOOKADD FIELDCOS.1678
C FIELDCOS.1679
DATA LEN_FULL_WORD/64/ FIELDCOS.1680
C FIELDCOS.1681
IF(PACK_TYPE.EQ.1) THEN ! WGDOS packing FIELDCOS.1682
CALL COEX(WORK_ARRAY,IDIM,FIELD,NUM_CRAY_WORDS,IXX,IYY, FIELDCOS.1683
& IDUM,IDUM,.FALSE.,AMDI,LEN_FULL_WORD) FIELDCOS.1684
NUM_UNPACK_VALUES=IXX*IYY FIELDCOS.1685
ILABEL(LBLREC)=ILABEL(LBROW)*ILABEL(LBNPT)+ILABEL(LBEXT) PS050793.589
ELSEIF(PACK_TYPE.EQ.2) THEN ! 32 Bit CRAY packing UIE1F403.13
NUM_CRAY_WORDS=NUM_CRAY_WORDS*2 UIE1F403.14
CALL EXPAND21(NUM_CRAY_WORDS,FIELD,WORK_ARRAY, UIE1F403.15
& P21BITS(PP_FIXHD(12))) UIE1F403.16
NUM_UNPACK_VALUES=NUM_CRAY_WORDS UIE1F403.17
ELSEIF(PACK_TYPE.EQ.3) THEN ! GRIB packing APS2F304.39
CALL DEGRIB(FIELD,WORK_ARRAY,IDIM,NUM_CRAY_WORDS, APS2F304.40
& ILABEL,AMDI,NUM_UNPACK_VALUES,LEN_FULL_WORD) APS2F304.41
ELSE FIELDCOS.1691
ICODE=6 FIELDCOS.1692
CMESSAGE=' UNPACK - packing type not yet supported' FIELDCOS.1693
ENDIF FIELDCOS.1694
DO 8 I=1,NUM_UNPACK_VALUES FIELDCOS.1695
FIELD(I)=WORK_ARRAY(I) FIELDCOS.1696
8 CONTINUE FIELDCOS.1697
ILABEL(DATA_TYPE)=1 ! data must now be real PS050793.590
ILABEL(LBPACK)=ILABEL(LBPACK)-PACK_TYPE ! data no longer packed FIELDCOS.1699
PACK_TYPE=0 ! data now not packed PS050793.591
RETURN FIELDCOS.1700
END FIELDCOS.1701
CLL Routine: LOGICAL_TO_REAL ------------------------------------------ FIELDCOS.1702
CLL FIELDCOS.1754
CLL Purpose: To convert logical data within FIELD to real data. FIELDCOS.1755
CLL the data in FIELD. FIELDCOS.1756
CLL FIELDCOS.1757
CLL Tested under compiler: cft77 FIELDCOS.1758
CLL Tested under OS version: UNICOS 5.1 FIELDCOS.1759
CLL FIELDCOS.1760
CLL Model Modification history from model version 3.0: FIELDCOS.1761
CLL version Date FIELDCOS.1762
CLL FIELDCOS.1763
CLL Programming standard: UM Doc Paper 3, version 1 (15/1/90) FIELDCOS.1764
CLL FIELDCOS.1765
CLL Logical components covered: FIELDCOS.1766
CLL FIELDCOS.1767
CLL Project task: FIELDCOS.1768
CLL FIELDCOS.1769
CLL External documentation: FIELDCOS.1770
CLL FIELDCOS.1771
CLL ------------------------------------------------------------------- FIELDCOS.1772
C*L Interface and arguments: ------------------------------------------ FIELDCOS.1773
SUBROUTINE LOGICAL_TO_REAL(IDIM,LOGICAL_FIELD,FIELD,NVALS, 3PS050793.592
& ILABEL,ICODE,CMESSAGE) FIELDCOS.1775
IMPLICIT NONE PS050793.593
C arguments PS050793.594
CHARACTER PS050793.595
& CMESSAGE*(*) !OUT error mesages. PS050793.596
INTEGER FIELDCOS.1776
& IDIM !IN full unpacked size of a field PS050793.597
& ,NVALS !IN no of values in an input field PS050793.598
& ,ILABEL(44) !OUT integer part of LOOKUP PS050793.599
& ,ICODE !OUT error code PS050793.600
REAL FIELDCOS.1781
& FIELD(IDIM) !OUT contains Real data. PS050793.601
LOGICAL PS050793.602
& LOGICAL_FIELD(IDIM) !IN contains logical data. PS050793.603
C ! contains the un-packed data. FIELDCOS.1783
c Local variables PS050793.604
INTEGER FIELDCOS.1787
& I ! loop counter PS050793.605
C FIELDCOS.1789
*CALL CLOOKADD FIELDCOS.1790
C FIELDCOS.1791
PS050793.606
DO I=1,NVALS PS050793.607
IF(LOGICAL_FIELD(I))THEN PS050793.608
FIELD(I)=1.0 PS050793.609
ELSE PS050793.610
FIELD(I)=0.0 PS050793.611
ENDIF PS050793.612
ENDDO PS050793.613
ILABEL(DATA_TYPE)=1 ! The data type must now be real PS050793.614
ICODE=0 PS050793.615
RETURN PS050793.616
END PS050793.617
CLL Routine: INTEGER_TO_REAL ------------------------------------------ PS050793.618
CLL PS050793.619
CLL Purpose: To convert logical data within FIELD to real data. PS050793.620
CLL the data in FIELD. PS050793.621
CLL PS050793.622
CLL Tested under compiler: cft77 PS050793.623
CLL Tested under OS version: UNICOS 5.1 PS050793.624
CLL PS050793.625
CLL Model Modification history: PS050793.626
CLL version Date PS050793.627
CLL PS050793.628
CLL Programming standard: UM Doc Paper 3, version 1 (15/1/90) PS050793.629
CLL PS050793.630
CLL Logical components covered: PS050793.631
CLL PS050793.632
CLL Project task: PS050793.633
CLL PS050793.634
CLL External documentation: PS050793.635
CLL PS050793.636
CLL ------------------------------------------------------------------- PS050793.637
C*L Interface and arguments: ------------------------------------------ PS050793.638
SUBROUTINE INTEGER_TO_REAL(IDIM,INTEGER_FIELD,FIELD,NVALS, 3PS050793.639
& ILABEL,ICODE,CMESSAGE) PS050793.640
IMPLICIT NONE PS050793.641
C arguments PS050793.642
CHARACTER PS050793.643
& CMESSAGE*(*) !OUT error mesages. PS050793.644
INTEGER PS050793.645
& IDIM !IN full unpacked size of a field PS050793.646
& ,NVALS !IN no of values in an input field PS050793.647
& ,INTEGER_FIELD(IDIM) !IN contains integer data. PS050793.648
& ,ILABEL(44) !OUT integer part of LOOKUP PS050793.649
& ,ICODE !OUT error code PS050793.650
REAL PS050793.651
& FIELD(IDIM) !OUT contains Real data. PS050793.652
c Local variables PS050793.653
INTEGER PS050793.654
& I ! loop counter PS050793.655
C PS050793.656
*CALL CLOOKADD PS050793.657
C PS050793.658
PS050793.659
DO I=1,NVALS FIELDCOS.1792
FIELD(I)=INTEGER_FIELD(I) FIELDCOS.1793
ENDDO FIELDCOS.1794
ILABEL(DATA_TYPE)=1 ! The data type must now be real PS050793.660
ICODE=0 FIELDCOS.1796
RETURN FIELDCOS.1797
END FIELDCOS.1798
*ENDIF FIELDCOS.1799
FIELDCOS.1800
INTEGER FUNCTION INT_FROM_REAL(number) 3FIELDCOS.1801
C function to return the integer EQUIVALENCE of a real number FIELDCOS.1802
integer number FIELDCOS.1803
int_from_real=number FIELDCOS.1804
RETURN FIELDCOS.1805
END FIELDCOS.1806
FIELDCOS.1807
CLL Routine: CHECK_EXTRA ---------------------------------------------- PS050793.661
CLL PS050793.662
CLL Purpose: To check that code is correct for vector PS050793.663
CLL PS050793.664
CLL Tested under compiler: cft77 PS050793.665
CLL Tested under OS version: UNICOS 5.1 PS050793.666
CLL PS050793.667
CLL Model Modification history: PS050793.668
CLL version Date PS050793.669
CLL PS050793.670
CLL Programming standard: UM Doc Paper 3, version 1 (15/1/90) PS050793.671
CLL PS050793.672
CLL Logical components covered: PS050793.673
CLL PS050793.674
CLL Project task: PS050793.675
CLL PS050793.676
CLL External documentation: PS050793.677
CLL PS050793.678
CLL ------------------------------------------------------------------- PS050793.679
C*L Interface and arguments: ------------------------------------------ PS050793.680
SUBROUTINE CHECK_EXTRA(CODE,DATA_VALUES,ICODE,CMESSAGE) 3PS050793.681
IMPLICIT NONE PS050793.682
C arguments PS050793.683
CHARACTER PS050793.684
& CMESSAGE*(*) !OUT error message PS050793.685
INTEGER PS050793.686
& CODE !IN Code to be checked PS050793.687
& ,DATA_VALUES !IN Number of data values in vector PS050793.688
& ,ICODE !OUT error code PS050793.689
c Local variables PS050793.690
INTEGER PS050793.691
& TYPE PS050793.692
FIELDCOS.1815
DATA_VALUES=CODE/1000 PS050793.693
TYPE=CODE-DATA_VALUES*1000 PS050793.694
IF (.NOT.(TYPE.LT.10.AND.TYPE.GT.0)) THEN ! TYPE is one of real se PS050793.695
ICODE=1 PS050793.696
IF (CODE.EQ.10) THEN PS050793.697
CMESSAGE='CHECK_DATA: Char extra not supported at present' PS050793.698
ELSE FIELDCOS.1823
CMESSAGE='CHECK_DATA: Unrecognized code in extra data' PS050793.699
ENDIF FIELDCOS.1825
RETURN FIELDCOS.1826
ENDIF FIELDCOS.1827
RETURN FIELDCOS.1828
END FIELDCOS.1829
FIELDCOS.1830
INTEGER FUNCTION CRAY2VAX(I,LEN_RLABEL, 10UIE1F402.23
& VAX_LABEL,BIT_OFF,RLABEL) UIE1F402.24
INTEGER I,LEN_RLABEL,BIT_OFF,VAX_LABEL UIE1F402.25
REAL RLABEL UIE1F402.26
CRAY2VAX=-1 UIE1F402.27
RETURN UIE1F402.28
END UIE1F402.29