SUBROUTINE UM_READDUMP(NFTIN,FIXHD,LEN_FIXHD 6,20GPB4F403.340
& ,INTHD,LEN_INTHD READDM1A.26
& ,REALHD,LEN_REALHD READDM1A.27
& ,LEVDEPC,LEN1_LEVDEPC,LEN2_LEVDEPC READDM1A.28
& ,ROWDEPC,LEN1_ROWDEPC,LEN2_ROWDEPC READDM1A.29
& ,COLDEPC,LEN1_COLDEPC,LEN2_COLDEPC READDM1A.30
& ,FLDDEPC,LEN1_FLDDEPC,LEN2_FLDDEPC READDM1A.31
& ,EXTCNST,LEN_EXTCNST READDM1A.32
& ,DUMPHIST,LEN_DUMPHIST READDM1A.33
& ,CFI1,LEN_CFI1 READDM1A.34
& ,CFI2,LEN_CFI2 READDM1A.35
& ,CFI3,LEN_CFI3 READDM1A.36
& ,LOOKUP,LEN1_LOOKUP,LEN2_LOOKUP TJ300394.89
*IF DEF,MPP GSM1F403.167
& ,MPP_LOOKUP,MPP_LEN1_LOOKUP GSM1F403.168
*ENDIF GPB0F401.69
& ,SUBMODEL_ID,N_OBJS_D1,D1_ADDR GPB4F403.341
& ,LEN_DATA,D1, GDG0F401.1185
*CALL ARGPPX 
GDG0F401.1186
& READHDR,ICODE,CMESSAGE) GKR3F403.3
READDM1A.39
IMPLICIT NONE READDM1A.40
READDM1A.41
INTEGER READDM1A.42
* NFTIN !IN Unit no of dump READDM1A.43
*,LEN_FIXHD !IN Length of fixed length header READDM1A.44
*,LEN_INTHD !IN Length of integer header READDM1A.45
*,LEN_REALHD !IN Length of real header READDM1A.46
*,LEN1_LEVDEPC !IN 1st dim of level dep consts READDM1A.47
*,LEN2_LEVDEPC !IN 2nd dim of level dep consts READDM1A.48
*,LEN1_ROWDEPC !IN 1st dim of row dep consts READDM1A.49
*,LEN2_ROWDEPC !IN 2nd dim of row dep consts READDM1A.50
&,LEN1_COLDEPC !IN 1st dim of column dep consts READDM1A.51
&,LEN2_COLDEPC !IN 2nd dim of column dep consts READDM1A.52
&,LEN1_FLDDEPC !IN 1st dim of field dep consts READDM1A.53
&,LEN2_FLDDEPC !IN 2nd dim of field dep consts READDM1A.54
&,LEN_EXTCNST !IN Length of extra constants READDM1A.55
&,LEN_DUMPHIST !IN Length of history block READDM1A.56
&,LEN_CFI1 !IN Length of comp field index 1 READDM1A.57
&,LEN_CFI2 !IN Length of comp field index 2 READDM1A.58
&,LEN_CFI3 !IN Length of comp field index 3 READDM1A.59
&,LEN1_LOOKUP !IN 1st dim of lookup READDM1A.60
&,LEN2_LOOKUP !IN 2nd dim of lookup READDM1A.61
*IF DEF,MPP GSM1F403.169
&,MPP_LEN1_LOOKUP !IN 1st dim of MPP lookup GSM1F403.170
*ENDIF GSM1F403.171
&,SUBMODEL_ID !IN submodel of dump GPB4F403.342
&,N_OBJS_D1 !IN number of objects (3D fields) in D1 GPB4F403.343
GPB4F403.344
! Parameters required for dimensioning the D1_ADDR array GPB4F403.345
*CALL D1_ADDR GPB4F403.346
GPB4F403.347
INTEGER GPB4F403.348
& D1_ADDR(D1_LIST_LEN,N_OBJS_D1) ! IN D1 addressing info. GPB4F403.349
GPB4F403.350
READDM1A.62
INTEGER READDM1A.63
* LEN_DATA !IN Length of model data TJ300394.90
*,ICODE !OUT Return code; successful=0 READDM1A.66
* ! error > 0 READDM1A.67
READDM1A.68
CHARACTER*(80) TS150793.149
* CMESSAGE !OUT Error message if ICODE > 0 READDM1A.70
READDM1A.71
INTEGER GPB4F403.351
& object_index, ! pointer to entry in D1_ADDR GSM3F405.3
& level, ! level number of multi-level field GSM3F405.4
& d1_item_code ! sec/item in d1_addr converted into single code GSM3F405.5
GPB4F403.354
INTEGER READDM1A.72
* FIXHD(LEN_FIXHD) !IN Fixed length header READDM1A.73
*,INTHD(LEN_INTHD) !IN Integer header READDM1A.74
*,LOOKUP(LEN1_LOOKUP,LEN2_LOOKUP) !IN PP lookup tables READDM1A.75
*IF DEF,MPP GPB0F401.70
C Local addressing of D1 GSM1F403.172
*,MPP_LOOKUP(MPP_LEN1_LOOKUP,LEN2_LOOKUP) ! OUT GSM1F403.173
*ENDIF GPB0F401.75
*,CFI1(LEN_CFI1+1) !IN Compressed field index no 1 READDM1A.76
*,CFI2(LEN_CFI2+1) !IN Compressed field index no 2 READDM1A.77
*,CFI3(LEN_CFI3+1) !IN Compressed field index no 3 READDM1A.78
READDM1A.79
REAL READDM1A.80
& REALHD(LEN_REALHD) !IN Real header READDM1A.81
&,LEVDEPC(1+LEN1_LEVDEPC*LEN2_LEVDEPC) !IN Lev dep consts READDM1A.82
&,ROWDEPC(1+LEN1_ROWDEPC*LEN2_ROWDEPC) !IN Row dep consts READDM1A.83
&,COLDEPC(1+LEN1_COLDEPC*LEN2_COLDEPC) !IN Col dep consts READDM1A.84
&,FLDDEPC(1+LEN1_FLDDEPC*LEN2_FLDDEPC) !IN Field dep consts READDM1A.85
&,EXTCNST(LEN_EXTCNST+1) !IN Extra constants READDM1A.86
&,DUMPHIST(LEN_DUMPHIST+1) !IN History block READDM1A.87
*,D1(LEN_DATA) !IN Real equivalence of data block READDM1A.88
READDM1A.89
LOGICAL GKR3F403.4
& READHDR !IN True if header is to be read in GKR3F403.5
*CALL CSUBMODL GDG0F401.1188
*CALL CPPXREF GDG0F401.1189
*CALL PPXLOOK GDG0F401.1190
*CALL CLOOKADD READDM1A.90
*CALL C_MDI GPB0F305.200
*IF DEF,MPP GBC5F404.250
*CALL DECOMPTP GPB4F403.355
*CALL PARVARS GPB0F305.201
*ENDIF GPB0F305.202
*CALL CNTL_IO GBC5F404.251
READDM1A.91
C ------------------------------------------------------------- READDM1A.92
C Local arrays:------------------------------------------------ READDM1A.93
TJ300394.91
C ------------------------------------------------------------- READDM1A.95
C*L External subroutines called:------------------------------- READDM1A.96
EXTERNAL IOERROR,POSERROR,READHEAD,PR_LOOK,PR_IFLD,PR_RFLD READDM1A.97
*,PR_LFLD DR221193.166
*,BUFFIN,EXPAND32B TJ300394.92
C Cray specific functions UNIT,LENGTH READDM1A.100
C*------------------------------------------------------------- READDM1A.101
C Local variables:--------------------------------------------- READDM1A.102
INTEGER START_BLOCK ! Pointer to current position in file READDM1A.103
*,LEN_IO ! No of 64-bit words buffered in READDM1A.104
*,K,I ! Loop counts READDM1A.105
*,IPTS ! No of 64-bit words requested to be READDM1A.106
* ! buffered in READDM1A.107
*IF DEF,MPP GPB0F305.203
&, orig_decomp ! original decomposition type GPB4F403.356
&, local_len ! length of local field from buffin GPB0F305.204
&, address ! address of field in local D1 array GPB0F305.205
*ENDIF GPB0F305.206
c GBC5F404.252
integer real_start_block ! Real disk address GBC5F404.253
2 , l ! loop counter GBC5F404.254
3 , word_address ! word address on disk of the record GBC5F404.255
4 , um_sector_ipts ! number fo words to read, rounded up GBC5F404.256
5 ! to a sector size GBC5F404.257
6 , l_ipts ! local value of ipts for address calc. GBC5F404.258
7 , ipts_read ! number of words actually read from disk GBC5F404.259
*IF -DEF,MPP,AND,DEF,GLOBAL APB1F402.184
INTEGER ppxref_grid_type,field_model,field_sect,field_item APB1F402.185
INTEGER EXPPXI APB1F402.186
EXTERNAL EXPPXI APB1F402.187
REAL p_pole_val APB1F402.188
LOGICAL p_const APB1F402.189
*ENDIF APB1F402.190
REAL A ! Error code returned by UNIT READDM1A.108
C-------------------------------------------------------------- READDM1A.109
READDM1A.110
*IF DEF,MPP GPB0F305.207
IF (mype .EQ. 0) THEN GPB0F305.208
*ENDIF GPB0F305.209
WRITE(6,'(/,'' READING UNIFIED MODEL DUMP ON UNIT'',I3)')NFTIN READDM1A.111
WRITE(6,'('' #####################################'',/)') READDM1A.112
*IF DEF,MPP GPB0F305.210
ENDIF GPB0F305.211
*ENDIF GPB0F305.212
ICODE=0 READDM1A.113
CMESSAGE=' ' READDM1A.114
*IF DEF,MPP GPB4F403.357
! Select the relevant decomposition type for this dump GPB4F403.358
GPB4F403.359
orig_decomp=current_decomp_type GPB4F403.360
GPB4F403.361
IF (SUBMODEL_ID .EQ. A_IM) THEN GPB4F403.362
IF (current_decomp_type .NE. decomp_standard_atmos) GPB4F403.363
& CALL CHANGE_DECOMPOSITION(decomp_standard_atmos,ICODE) GPB4F403.364
GPB4F403.365
ELSEIF (SUBMODEL_ID .EQ. O_IM) THEN GPB4F403.366
IF (current_decomp_type .NE. decomp_standard_ocean) GPB4F403.367
& CALL CHANGE_DECOMPOSITION(decomp_standard_ocean,ICODE) GPB4F403.368
GPB4F403.369
ELSE ! unsupported decomposition type GPB4F403.370
WRITE(6,*) 'READDUMP : Error - Only atmosphere and ocean ', GPB1F404.103
& 'submodels are currently supported for MPP code.' GPB4F403.372
ICODE=1 GPB4F403.373
CMESSAGE='Unsupported submodel for MPP code' GPB4F403.374
GOTO 9999 GPB4F403.375
ENDIF GPB4F403.376
GPB4F403.377
IF (ICODE .NE. 0) THEN GPB4F403.378
WRITE(6,*) 'READDUMP : Error - Could not set decomposition ', GPB4F403.379
& 'for selected submodel.' GPB4F403.380
CMESSAGE='Unsupported decomposition selected for MPP code' GPB4F403.381
GOTO 9999 GPB4F403.382
ENDIF GPB4F403.383
*ENDIF GPB4F403.384
READDM1A.115
CL 1. Read in all header records and check for consistency. READDM1A.116
C START_BLOCK points to position of model data block READDM1A.117
C on return READDM1A.118
READDM1A.119
IF (READHDR) THEN GKR3F403.6
GKR3F403.7
CALL READHEAD(NFTIN,FIXHD,LEN_FIXHD, GDG0F401.1191
& INTHD,LEN_INTHD, GDG0F401.1192
& REALHD,LEN_REALHD, GDG0F401.1193
& LEVDEPC,LEN1_LEVDEPC,LEN2_LEVDEPC, GDG0F401.1194
& ROWDEPC,LEN1_ROWDEPC,LEN2_ROWDEPC, GDG0F401.1195
& COLDEPC,LEN1_COLDEPC,LEN2_COLDEPC, GDG0F401.1196
& FLDDEPC,LEN1_FLDDEPC,LEN2_FLDDEPC, GDG0F401.1197
& EXTCNST,LEN_EXTCNST, GDG0F401.1198
& DUMPHIST,LEN_DUMPHIST, GDG0F401.1199
& CFI1,LEN_CFI1, GDG0F401.1200
& CFI2,LEN_CFI2, GDG0F401.1201
& CFI3,LEN_CFI3, GDG0F401.1202
& LOOKUP,LEN1_LOOKUP,LEN2_LOOKUP, GDG0F401.1203
& LEN_DATA, GDG0F401.1204
*CALL ARGPPX GDG0F401.1205
& START_BLOCK,ICODE,CMESSAGE) GDG0F401.1206
READDM1A.135
IF(ICODE.GT.0)RETURN READDM1A.136
GKR3F403.8
ELSE GKR3F403.9
! If header not read START_BLOCK must be set GKR3F403.10
START_BLOCK = FIXHD(160) GKR3F403.11
ENDIF GKR3F403.12
READDM1A.137
*IF DEF,MPP GPB0F305.217
address=1 GPB0F305.222
*ENDIF GPB0F305.223
CL 2. Buffer in model data one field at a time for READDM1A.138
CL conversion from 32-bit to 64-bit numbers READDM1A.139
READDM1A.140
IF(FIXHD(160).GT.0)THEN READDM1A.141
READDM1A.142
C Check for error in file pointers READDM1A.143
real_start_block=start_block GBC5F404.260
if(start_block.ne.fixhd(160)) then GBC5F404.261
C If new format Dumpfile, we must reset the start address GBC5F404.262
if((lookup(lbnrec,1).eq.0) .or. GBC5F404.263
2 ((lookup(lbnrec,1).eq.imdi) .and. (fixhd(12).le.301))) then GBC5F404.264
CMESSAGE='READDUMP: Addressing conflict' READDM1A.145
ICODE=1 READDM1A.146
CALL POSERROR('model data', READDM1A.147
* START_BLOCK,160,FIXHD(160)) READDM1A.148
RETURN READDM1A.149
else GBC5F404.265
real_start_block=fixhd(160) GBC5F404.266
endif GBC5F404.267
ENDIF READDM1A.150
READDM1A.151
C Move to start of data. @DYALLOC.3089
CALL SETPOS (NFTIN,FIXHD(160)-1,ICODE) GTD0F400.123
@DYALLOC.3091
GPB4F403.385
object_index=1 GPB4F403.386
level=1 GPB4F403.387
C Loop over number of fields in data block READDM1A.152
DO 200 K=1,FIXHD(152) READDM1A.153
READDM1A.154
IF (D1_ADDR(d1_object_type,object_index).eq.diagnostic) THEN GSM3F405.6
! Check that diagnostic in dump matches that expected from D1_ADDR GSM3F405.7
GSM3F405.8
d1_item_code = (d1_addr(d1_section,object_index)*1000) GSM3F405.9
& +d1_addr(d1_item,object_index) GSM3F405.10
GSM3F405.11
IF (LOOKUP(ITEM_CODE,K).NE.d1_item_code)THEN GSM3F405.12
write(6,*)'READDM1A: Dump field ',K, GSM3F405.13
& ' does not match STASH request for item ', GSM3F405.14
& d1_addr(d1_item,object_index), GSM3F405.15
& ' section ',d1_addr(d1_section,object_index) GSM3F405.16
WRITE(6,*)' Expected code ',LOOKUP(ITEM_CODE,K) GSM3F405.17
GSM3F405.18
CMESSAGE = GSM3F405.19
& 'READDM1A: Dump does not match STASH list - see output' GSM3F405.20
ICODE=1 GSM3F405.21
GOTO 9999 GSM3F405.22
ENDIF GSM3F405.23
ENDIF GSM3F405.24
GSM3F405.25
*IF DEF,MPP GPB0F401.76
MPP_LOOKUP(P_LBLREC,K)=0 GSM1F403.174
MPP_LOOKUP(P_NADDR,K)=address GSM1F403.175
*ENDIF GPB0F401.79
IF (LOOKUP(LBLREC,K).GT.0) THEN ! Any data for this field ? @DYALLOC.3092
@DYALLOC.3093
C Test whether data stored as 32-bit on disk READDM1A.155
IF (MOD((LOOKUP(LBPACK,K)),10).EQ.2) THEN TJ300394.93
IPTS=(LOOKUP(LBLREC,K)+1)/2 TJ300394.94
ELSE TJ300394.95
IPTS=LOOKUP(LBLREC,K) TJ300394.96
ENDIF TJ300394.97
GBC5F404.268
C Compute word address in file from which to begin I/O GBC5F404.269
GBC5F404.270
C Old Format dumpfiles GBC5F404.271
if((lookup(lbnrec,k).eq.0) .or. GBC5F404.272
C Prog lookups in dump before vn3.2: GBC5F404.273
2 ((lookup(lbnrec,k).eq.imdi) .and. (fixhd(12).le.301))) then GBC5F404.274
C Dump and ancillary files GBC5F404.275
word_address=1 GBC5F404.276
if(k.gt.1)then GBC5F404.277
do l=2,k GBC5F404.278
if(mod(lookup(lbpack,l-1),10).eq.2) then GBC5F404.279
l_ipts=(lookup(lblrec,l-1)+1)/2 GBC5F404.280
else GBC5F404.281
l_ipts=(lookup(lblrec,l-1)) GBC5F404.282
endif GBC5F404.283
word_address=word_address+l_ipts GBC5F404.284
end do GBC5F404.285
endif GBC5F404.286
word_address=fixhd(160)+word_address-2 GBC5F404.287
um_sector_ipts=ipts GBC5F404.288
GBC5F404.289
else GBC5F404.290
GBC5F404.291
C PP type files and new format Dumpfiles (vn4.4 onwards) GBC5F404.292
word_address=lookup(lbegin,k) GBC5F404.293
C Use the stored round-up value GBC5F404.294
um_sector_ipts=lookup(lbnrec,k) GBC5F404.295
endif GBC5F404.296
GBC5F404.297
! If this is the last field in the dump, then set the size of data GPB0F405.67
! to be read in to be the real size of the data, and not the GPB0F405.68
! size including the padding. GPB0F405.69
IF (K .EQ. FIXHD(152)) THEN GPB0F405.70
UM_SECTOR_IPTS=IPTS GPB0F405.71
ENDIF GPB0F405.72
ipts_read=ipts GBC5F404.298
GBC5F404.299
C Position file pointer GBC5F404.300
call setpos(nftin, word_address, icode) GBC5F404.301
GBC5F404.302
READDM1A.161
C Read data into final position READDM1A.162
C Check that data_type is valid no: 1 to 3 or -1 to -3 READDM1A.163
IF((LOOKUP(DATA_TYPE,K).GE.1.AND.LOOKUP(DATA_TYPE,K).LE.3) .OR. READDM1A.164
+ (LOOKUP(DATA_TYPE,K).LE.-1.AND.LOOKUP(DATA_TYPE,K).GE.-3)) READDM1A.165
+ THEN READDM1A.166
*IF -DEF,MPP GPB0F305.224
CALL BUFFIN(NFTIN,D1(LOOKUP(NADDR,K)),IPTS,LEN_IO,A) READDM1A.167
*ELSE GPB0F305.225
IF (SUBMODEL_ID .EQ. O_IM) THEN GPB4F403.388
IF (D1_ADDR(d1_object_type,object_index) .EQ. diagnostic) GPB4F403.389
& THEN GPB4F403.390
CALL CHANGE_DECOMPOSITION(decomp_nowrap_ocean,ICODE) GPB4F403.391
ELSE GPB4F403.392
CALL CHANGE_DECOMPOSITION(decomp_standard_ocean,ICODE) GPB4F403.393
ENDIF GPB4F403.394
ENDIF GPB4F403.395
ipts_read=um_sector_ipts GBC5F404.303
call read_multi(nftin,d1(address),um_sector_ipts,len_io, GBC5F404.304
& local_len,A,LOOKUP(1,k),FIXHD(12), GPB0F401.547
& D1_ADDR(1,object_index), GPB4F403.396
& CMESSAGE) GPB0F401.548
MPP_LOOKUP(P_LBLREC,K)=local_len GSM1F403.176
address=address+local_len GPB0F305.228
IF (A .EQ. 100.0) THEN ! problem expanding data in read_multi GPB0F305.229
WRITE(6,*) 'READMULTI :attempt to expand a non-real field' GPB0F305.230
ICODE=100 GPB0F305.231
CALL IOERROR('BUFFER IN FROM READDUMP',A,LEN_IO,IPTS) GPB0F305.233
RETURN GPB0F305.234
ENDIF GPB0F305.235
*ENDIF GPB0F305.236
if ((a.ne.-1.0).or.(len_io.ne.ipts_read)) then GBC5F404.305
WRITE(6,*)'ERROR READING DUMP ON UNIT ',NFTIN DR221193.168
ICODE=2 DR221193.169
CMESSAGE='READDUMP: BAD BUFFIN OF DATA' DR221193.170
CALL IOERROR('BUFFER IN FROM READDUMP',A,LEN_IO,IPTS) DR221193.171
RETURN DR221193.172
END IF DR221193.173
C Error in lookup(data_type,k) READDM1A.168
ELSE READDM1A.169
IF (FIXHD(5).LT.6 .OR. FIXHD(5).GT.8) THEN ! Not AC/Var Obs/Cx VSB1F304.148
CALL PR_LOOK( GDG0F401.1207
*CALL ARGPPX GDG0F401.1208
& LOOKUP,LOOKUP,LEN1_LOOKUP,K) GDG0F401.1209
END IF VSB1F304.150
ICODE=3 READDM1A.171
CMESSAGE='READDUMP: Invalid code in LOOKUP(DATA_TYPE,K)' READDM1A.172
END IF READDM1A.173
*IF -DEF,MPP GPB0F305.237
C Expand if necessary READDM1A.174
IF (MOD((LOOKUP(LBPACK,K)),10).EQ.2) THEN READDM1A.175
IF (LOOKUP(DATA_TYPE,K).EQ.1) THEN READDM1A.177
C Expand real data and copy into final position TJ300394.98
CALL EXPAND32B( LOOKUP(LBLREC,K) , D1(LOOKUP(NADDR,K)), TJ300394.99
& FIXHD(12) ) TJ300394.100
ELSE TJ300394.101
ICODE=100 TJ300394.102
CMESSAGE=' READDUMP: Attempt to expand a non-real field' TJ300394.103
WRITE(6,*) 'READDUMP :attempt to expand a non-real field' TJ300394.104
RETURN TJ300394.105
END IF READDM1A.183
END IF READDM1A.184
*IF DEF,GLOBAL APB1F402.191
field_item=MOD(LOOKUP(42,K),1000) APB1F402.192
field_sect=(LOOKUP(42,K)-field_item)/1000 APB1F402.193
field_model=LOOKUP(45,K) APB1F402.194
APB1F402.195
ppxref_grid_type=EXPPXI(field_model,field_sect,field_item, APB1F402.196
& ppx_grid_type, APB1F402.197
*CALL ARGPPX APB1F402.198
& ICODE,CMESSAGE) APB1F402.199
APB1F402.200
IF ((ppxref_grid_type .LE. 3) .AND. APB1F402.201
& (LOOKUP(LBHEM,K) .EQ. 0) .AND. APB1F402.202
& (LOOKUP(ITEM_CODE,K) .EQ. 1)) THEN APB1F402.203
! This is P field APB1F402.204
! Search for non-constant value on pole rows APB1F402.205
p_const=.TRUE. APB1F402.206
APB1F402.207
p_pole_val=D1(LOOKUP(NADDR,K)) APB1F402.208
DO I=2,LOOKUP(LBNPT,K) APB1F402.209
IF (D1(LOOKUP(NADDR,K)+I-1) .NE. p_pole_val) APB1F402.210
& p_const=.FALSE. APB1F402.211
ENDDO APB1F402.212
APB1F402.213
p_pole_val=D1(LOOKUP(NADDR,K)+ APB1F402.214
& (LOOKUP(LBROW,K)-1)*LOOKUP(LBNPT,K)) APB1F402.215
DO I=2,LOOKUP(LBNPT,K) APB1F402.216
IF (D1(LOOKUP(NADDR,K)+ APB1F402.217
& (LOOKUP(LBROW,K)-1)*LOOKUP(LBNPT,K)+I-1) .NE. APB1F402.218
& p_pole_val) APB1F402.219
& p_const=.FALSE. APB1F402.220
ENDDO APB1F402.221
APB1F402.222
IF (.NOT. p_const) THEN APB1F402.223
WRITE(6,*) 'Non constant polar row found in dump : ', APB1F402.224
& 'field ',K APB1F402.225
WRITE(6,*) 'Dump must be reconfigured' APB1F402.226
WRITE(6,*) 'Model run aborted' APB1F402.227
ICODE=1 APB1F402.228
CMESSAGE='Non constant polar PSTAR found in dump' APB1F402.229
GOTO 9999 APB1F402.230
ENDIF APB1F402.231
APB1F402.232
ENDIF ! is this a p field APB1F402.233
*ENDIF APB1F402.234
*ELSE GPB0F305.238
! Code to expand field is contained within read_multi GPB0F305.239
*ENDIF GPB0F305.240
READDM1A.185
*IF DEF,DIAG80 READDM1A.186
IF (FIXHD(5).LT.6 .OR. FIXHD(5).GT.8) THEN ! Not AC/Var Obs/Cx VSB1F304.151
C Print out header and summary of data field READDM1A.187
CALL PR_LOOK( GDG0F401.1210
*CALL ARGPPX GDG0F401.1211
& LOOKUP,LOOKUP,LEN1_LOOKUP,K) GDG0F401.1212
IF (FIXHD(5).NE.5) THEN ! Skip if boundary dataset DR221193.176
IF (LOOKUP(DATA_TYPE,K).EQ.1) THEN ! Real DR221193.177
CALL PR_RFLD(LOOKUP,LOOKUP,D1(LOOKUP(NADDR,K)),K) READDM1A.190
ELSE IF(LOOKUP(DATA_TYPE,K).EQ.2) THEN ! Integer DR221193.178
CALL PR_IFLD(LOOKUP,LOOKUP,D1(LOOKUP(NADDR,K)),K) READDM1A.192
ELSE IF(LOOKUP(DATA_TYPE,K).EQ.3) THEN ! Logical DR221193.179
CALL PR_LFLD(LOOKUP,LOOKUP,LEN1_LOOKUP,D1(LOOKUP(NADDR,K)),K) DR221193.180
END IF DR221193.181
END IF DR260593.139
END IF READDM1A.193
*ENDIF READDM1A.194
@DYALLOC.3094
ENDIF ! Skip to here if no data for this field @DYALLOC.3095
READDM1A.195
START_BLOCK=START_BLOCK+LOOKUP(LBLREC,K) READDM1A.196
real_start_block=real_start_block+um_sector_ipts GBC5F404.306
READDM1A.197
level=level+1 GPB4F403.397
IF (level .GT. D1_ADDR(d1_no_levels,object_index)) THEN GPB4F403.398
level=1 GPB4F403.399
object_index=object_index+1 GPB4F403.400
ENDIF GPB4F403.401
200 CONTINUE READDM1A.198
READDM1A.199
*IF DEF,MPP GPB0F305.241
IF (mype .EQ. 0) THEN GPB0F305.242
*ENDIF GPB0F305.243
WRITE(6,'('' '')') READDM1A.200
IF (FIXHD(5).GE.6 .AND. FIXHD(5).LE.8) THEN ! AC/Var Obs/ Cx file VSB1F304.152
WRITE(6,'('' OBSERVATION DATA'')') READDM1A.202
ELSE READDM1A.203
WRITE(6,'('' MODEL DATA'')') READDM1A.204
ENDIF READDM1A.205
WRITE(6,'('' '',I8,'' words long'')')FIXHD(161) READDM1A.206
*IF DEF,MPP GPB0F305.244
ENDIF ! mype .EQ. 0 GPB0F305.245
*ENDIF GPB0F305.246
READDM1A.207
ENDIF READDM1A.208
READDM1A.209
*IF DEF,MPP GPB4F403.402
! Reset to original decomposition type GPB4F403.403
CALL CHANGE_DECOMPOSITION(orig_decomp,ICODE) GPB4F403.404
*ENDIF GPB4F403.405
*IF DEF,MPP GPB0F305.247
IF (mype .EQ. 0) THEN GPB0F305.248
*ENDIF GPB0F305.249
WRITE(6,'('' '')') READDM1A.210
WRITE(6,'('' INITIAL DATA SUCCESSFULLY READ -'',I9, READDM1A.211
*'' WORDS FROM UNIT'',I3)')START_BLOCK,NFTIN READDM1A.212
if(real_start_block.ne.start_block) then GBC5F404.307
write(6,'(/'' Number of Words Read from Disk was '',i9)') GBC5F404.308
2 real_start_block GBC5F404.309
endif GBC5F404.310
*IF DEF,MPP GPB0F305.250
ENDIF ! mype .EQ. 0 GPB0F305.251
*ENDIF GPB0F305.252
READDM1A.213
9999 CONTINUE APB1F402.235
RETURN READDM1A.214
END READDM1A.215
CLL SUBROUTINE READDUMP--------------------------------------- GPB4F403.406
CLL GPB4F403.407
CLL Purpose: Reads in model obs dump on unit NFTIN and checks model GPB4F403.408
CLL and dump dimensions for consistency. GPB4F403.409
CLL GPB4F403.410
CLL Code mostly copied from original READDUMP GPB4F403.411
CLL GPB4F403.412
CLL Model Modification history from model version 4.3: GPB4F403.413
CLL version Date GPB4F403.414
CLL 4.3 19/3/97 New deck introduced P.Burton GPB4F403.415
CLL GPB4F403.416
CLL Programming standard: Unified Model Documentation Paper No 3 GPB4F403.417
CLL Version No 1 15/1/90 GPB4F403.418
CLL GPB4F403.419
CLL Logical component: R30 GPB4F403.420
CLL GPB4F403.421
CLL System task: F3 GPB4F403.422
CLL GPB4F403.423
CLL Documentation: Unified Model Documentation Paper No F3 GPB4F403.424
CLL Version No 5 9/2/90 GPB4F403.425
CLLEND--------------------------------------------------------- GPB4F403.426
C GPB4F403.427
C*L Arguments:------------------------------------------------- GPB4F403.428
SUBROUTINE READDUMP(NFTIN,FIXHD,LEN_FIXHD ,7GPB4F403.429
& ,INTHD,LEN_INTHD GPB4F403.430
& ,REALHD,LEN_REALHD GPB4F403.431
& ,LEVDEPC,LEN1_LEVDEPC,LEN2_LEVDEPC GPB4F403.432
& ,ROWDEPC,LEN1_ROWDEPC,LEN2_ROWDEPC GPB4F403.433
& ,COLDEPC,LEN1_COLDEPC,LEN2_COLDEPC GPB4F403.434
& ,FLDDEPC,LEN1_FLDDEPC,LEN2_FLDDEPC GPB4F403.435
& ,EXTCNST,LEN_EXTCNST GPB4F403.436
& ,DUMPHIST,LEN_DUMPHIST GPB4F403.437
& ,CFI1,LEN_CFI1 GPB4F403.438
& ,CFI2,LEN_CFI2 GPB4F403.439
& ,CFI3,LEN_CFI3 GPB4F403.440
& ,LOOKUP,LEN1_LOOKUP,LEN2_LOOKUP GPB4F403.441
& ,LEN_DATA,D1, GPB4F403.442
*CALL ARGPPX GPB4F403.443
& ICODE,CMESSAGE) GPB4F403.444
GPB4F403.445
IMPLICIT NONE GPB4F403.446
GPB4F403.447
INTEGER GPB4F403.448
* NFTIN !IN Unit no of dump GPB4F403.449
*,LEN_FIXHD !IN Length of fixed length header GPB4F403.450
*,LEN_INTHD !IN Length of integer header GPB4F403.451
*,LEN_REALHD !IN Length of real header GPB4F403.452
*,LEN1_LEVDEPC !IN 1st dim of level dep consts GPB4F403.453
*,LEN2_LEVDEPC !IN 2nd dim of level dep consts GPB4F403.454
*,LEN1_ROWDEPC !IN 1st dim of row dep consts GPB4F403.455
*,LEN2_ROWDEPC !IN 2nd dim of row dep consts GPB4F403.456
&,LEN1_COLDEPC !IN 1st dim of column dep consts GPB4F403.457
&,LEN2_COLDEPC !IN 2nd dim of column dep consts GPB4F403.458
&,LEN1_FLDDEPC !IN 1st dim of field dep consts GPB4F403.459
&,LEN2_FLDDEPC !IN 2nd dim of field dep consts GPB4F403.460
&,LEN_EXTCNST !IN Length of extra constants GPB4F403.461
&,LEN_DUMPHIST !IN Length of history block GPB4F403.462
&,LEN_CFI1 !IN Length of comp field index 1 GPB4F403.463
&,LEN_CFI2 !IN Length of comp field index 2 GPB4F403.464
&,LEN_CFI3 !IN Length of comp field index 3 GPB4F403.465
&,LEN1_LOOKUP !IN 1st dim of lookup GPB4F403.466
&,LEN2_LOOKUP !IN 2nd dim of lookup GPB4F403.467
GPB4F403.468
INTEGER GPB4F403.469
* LEN_DATA !IN Length of model data GPB4F403.470
*,ICODE !OUT Return code; successful=0 GPB4F403.471
* ! error > 0 GPB4F403.472
GPB4F403.473
CHARACTER*(80) GPB4F403.474
* CMESSAGE !OUT Error message if ICODE > 0 GPB4F403.475
GPB4F403.476
INTEGER GPB4F403.477
* FIXHD(LEN_FIXHD) !IN Fixed length header GPB4F403.478
*,INTHD(LEN_INTHD) !IN Integer header GPB4F403.479
*,LOOKUP(LEN1_LOOKUP,LEN2_LOOKUP) !IN PP lookup tables GPB4F403.480
GPB4F403.481
*,CFI1(LEN_CFI1+1) !IN Compressed field index no 1 GPB4F403.482
*,CFI2(LEN_CFI2+1) !IN Compressed field index no 2 GPB4F403.483
*,CFI3(LEN_CFI3+1) !IN Compressed field index no 3 GPB4F403.484
GPB4F403.485
REAL GPB4F403.486
& REALHD(LEN_REALHD) !IN Real header GPB4F403.487
&,LEVDEPC(1+LEN1_LEVDEPC*LEN2_LEVDEPC) !IN Lev dep consts GPB4F403.488
&,ROWDEPC(1+LEN1_ROWDEPC*LEN2_ROWDEPC) !IN Row dep consts GPB4F403.489
&,COLDEPC(1+LEN1_COLDEPC*LEN2_COLDEPC) !IN Col dep consts GPB4F403.490
&,FLDDEPC(1+LEN1_FLDDEPC*LEN2_FLDDEPC) !IN Field dep consts GPB4F403.491
&,EXTCNST(LEN_EXTCNST+1) !IN Extra constants GPB4F403.492
&,DUMPHIST(LEN_DUMPHIST+1) !IN History block GPB4F403.493
*,D1(*) GCJ3F405.1
GPB4F403.495
*CALL CSUBMODL GPB4F403.496
*CALL CPPXREF GPB4F403.497
*CALL PPXLOOK GPB4F403.498
*CALL CLOOKADD GPB4F403.499
*IF DEF,MPP GPB4F403.500
*CALL PARVARS GPB4F403.501
*ENDIF GPB4F403.502
*CALL C_MDI GBC5F404.311
*CALL CNTL_IO GBC5F404.312
GPB4F403.503
C ------------------------------------------------------------- GPB4F403.504
C Local arrays:------------------------------------------------ GPB4F403.505
GPB4F403.506
C ------------------------------------------------------------- GPB4F403.507
C*L External subroutines called:------------------------------- GPB4F403.508
EXTERNAL IOERROR,POSERROR,READHEAD,PR_LOOK,PR_IFLD,PR_RFLD GPB4F403.509
*,PR_LFLD GPB4F403.510
*,BUFFIN,EXPAND32B GPB4F403.511
C Cray specific functions UNIT,LENGTH GPB4F403.512
C*------------------------------------------------------------- GPB4F403.513
C Local variables:--------------------------------------------- GPB4F403.514
INTEGER START_BLOCK ! Pointer to current position in file GPB4F403.515
*,LEN_IO ! No of 64-bit words buffered in GPB4F403.516
*,K,I ! Loop counts GPB4F403.517
*,IPTS ! No of 64-bit words requested to be GPB4F403.518
* ! buffered in GPB4F403.519
REAL A ! Error code returned by UNIT GPB4F403.520
c GBC5F404.313
integer real_start_block ! Real disk address GBC5F404.314
2 , l ! loop counter GBC5F404.315
3 , word_address ! word address on disk of the record GBC5F404.316
4 , um_sector_ipts ! number fo words to read, rounded up GBC5F404.317
5 ! to a sector size GBC5F404.318
6 , l_ipts ! local value of ipts for address calc. GBC5F404.319
C-------------------------------------------------------------- GPB4F403.521
GPB4F403.522
*IF DEF,MPP GPB4F403.523
IF (mype .EQ. 0) THEN GPB4F403.524
*ENDIF GPB4F403.525
WRITE(6,'(/,'' READING UNIFIED MODEL DUMP ON UNIT'',I3)')NFTIN GPB4F403.526
WRITE(6,'('' #####################################'',/)') GPB4F403.527
*IF DEF,MPP GPB4F403.528
ENDIF GPB4F403.529
*ENDIF GPB4F403.530
ICODE=0 GPB4F403.531
CMESSAGE=' ' GPB4F403.532
GPB4F403.533
CL 1. Read in all header records and check for consistency. GPB4F403.534
C START_BLOCK points to position of model data block GPB4F403.535
C on return GPB4F403.536
GPB4F403.537
CALL READHEAD(NFTIN,FIXHD,LEN_FIXHD, GPB4F403.538
& INTHD,LEN_INTHD, GPB4F403.539
& REALHD,LEN_REALHD, GPB4F403.540
& LEVDEPC,LEN1_LEVDEPC,LEN2_LEVDEPC, GPB4F403.541
& ROWDEPC,LEN1_ROWDEPC,LEN2_ROWDEPC, GPB4F403.542
& COLDEPC,LEN1_COLDEPC,LEN2_COLDEPC, GPB4F403.543
& FLDDEPC,LEN1_FLDDEPC,LEN2_FLDDEPC, GPB4F403.544
& EXTCNST,LEN_EXTCNST, GPB4F403.545
& DUMPHIST,LEN_DUMPHIST, GPB4F403.546
& CFI1,LEN_CFI1, GPB4F403.547
& CFI2,LEN_CFI2, GPB4F403.548
& CFI3,LEN_CFI3, GPB4F403.549
& LOOKUP,LEN1_LOOKUP,LEN2_LOOKUP, GPB4F403.550
& LEN_DATA, GPB4F403.551
*CALL ARGPPX GPB4F403.552
& START_BLOCK,ICODE,CMESSAGE) GPB4F403.553
GPB4F403.554
IF(ICODE.GT.0)RETURN GPB4F403.555
GPB4F403.556
GPB4F403.557
CL 2. Buffer in model data one field at a time for GPB4F403.558
CL conversion from 32-bit to 64-bit numbers GPB4F403.559
GPB4F403.560
IF(FIXHD(160).GT.0)THEN GPB4F403.561
GPB4F403.562
C Check for error in file pointers GPB4F403.563
real_start_block=start_block GBC5F404.320
if(start_block.ne.fixhd(160)) then GBC5F404.321
C If new format Dumpfile, we must reset the start address GBC5F404.322
if((lookup(lbnrec,1).eq.0.and.lookup(lblrec,1).gt.0) .or. GCJ3F405.2
C Ocean ACOBS Files (?) GBC5F404.324
2 ((lookup(lbnrec,1).eq.imdi) .or. (lookup(lbegin,1).eq.imdi)) GBC5F404.325
3 .or. GBC5F404.326
C Prog lookups in dump before vn3.2: GBC5F404.327
4 ((lookup(lbnrec,1).eq.imdi) .and. (fixhd(12).le.301))) then GBC5F404.328
CMESSAGE='READDUMP: Addressing conflict' GPB4F403.565
ICODE=1 GPB4F403.566
CALL POSERROR('model data', GPB4F403.567
* START_BLOCK,160,FIXHD(160)) GPB4F403.568
RETURN GPB4F403.569
else GBC5F404.329
real_start_block=fixhd(160) GBC5F404.330
endif GBC5F404.331
ENDIF GPB4F403.570
GPB4F403.571
C Move to start of data. GPB4F403.572
CALL SETPOS (NFTIN,FIXHD(160)-1,ICODE) GPB4F403.573
GPB4F403.574
C Loop over number of fields in data block GPB4F403.575
DO 200 K=1,FIXHD(152) GPB4F403.576
GPB4F403.577
IF (LOOKUP(LBLREC,K).GT.0) THEN ! Any data for this field ? GPB4F403.578
GPB4F403.579
C Test whether data stored as 32-bit on disk GPB4F403.580
IF (MOD((LOOKUP(LBPACK,K)),10).EQ.2) THEN GPB4F403.581
IPTS=(LOOKUP(LBLREC,K)+1)/2 GPB4F403.582
ELSE GPB4F403.583
IPTS=LOOKUP(LBLREC,K) GPB4F403.584
ENDIF GPB4F403.585
GBC5F404.332
C Compute word address in file from which to begin I/O GBC5F404.333
GBC5F404.334
C Old Format dumpfiles GBC5F404.335
if((lookup(lbnrec,k).eq.0) .or. GBC5F404.336
C Ocean ACOBS Files (?) GBC5F404.337
2 ((lookup(lbnrec,k).eq.imdi) .or. (lookup(lbegin,k).eq.imdi)) GBC5F404.338
3 .or. GBC5F404.339
C Prog lookups in dump before vn3.2: GBC5F404.340
4 ((lookup(lbnrec,k).eq.imdi) .and. (fixhd(12).le.301))) then GBC5F404.341
C Dump and ancillary files GBC5F404.342
word_address=1 GBC5F404.343
if(k.gt.1)then GBC5F404.344
do l=2,k GBC5F404.345
if(mod(lookup(lbpack,l-1),10).eq.2) then GBC5F404.346
l_ipts=(lookup(lblrec,l-1)+1)/2 GBC5F404.347
else GBC5F404.348
l_ipts=(lookup(lblrec,l-1)) GBC5F404.349
endif GBC5F404.350
word_address=word_address+l_ipts GBC5F404.351
end do GBC5F404.352
endif GBC5F404.353
word_address=fixhd(160)+word_address-2 GBC5F404.354
um_sector_ipts=ipts GBC5F404.355
GBC5F404.356
else GBC5F404.357
GBC5F404.358
C PP type files and new format Dumpfiles (vn4.4 onwards) GBC5F404.359
word_address=lookup(lbegin,k) GBC5F404.360
C Use the stored round-up value GBC5F404.361
um_sector_ipts=lookup(lbnrec,k) GBC5F404.362
endif GBC5F404.363
GBC5F404.364
! If this is the last field in the dump, then set the size of data GPB0F405.73
! to be read in to be the real size of the data, and not the GPB0F405.74
! size including the padding. GPB0F405.75
IF (K .EQ. FIXHD(152)) THEN GPB0F405.76
UM_SECTOR_IPTS=IPTS GPB0F405.77
ENDIF GPB0F405.78
C Position file pointer GBC5F404.365
call setpos(nftin,word_address,icode) GBC5F404.366
GBC5F404.367
GPB4F403.586
C Read data into final position GPB4F403.587
C Check that data_type is valid no: 1 to 3 or -1 to -3 GPB4F403.588
IF((LOOKUP(DATA_TYPE,K).GE.1.AND.LOOKUP(DATA_TYPE,K).LE.3) .OR. GPB4F403.589
+ (LOOKUP(DATA_TYPE,K).LE.-1.AND.LOOKUP(DATA_TYPE,K).GE.-3)) GPB4F403.590
+ THEN GPB4F403.591
ipts=um_sector_ipts GBC5F404.368
*IF -DEF,MPP GPB4F403.592
CALL BUFFIN(NFTIN,D1(LOOKUP(NADDR,K)),IPTS,LEN_IO,A) GPB4F403.593
*ELSE GPB4F403.594
CALL BUFFIN_shmem(NFTIN,D1(LOOKUP(NADDR,K)),IPTS,LEN_IO,A) GPB4F403.595
IF(MYPE.EQ.0)WRITE(0,*)K,IPTS,'READ IN TO',LOOKUP(NADDR,K) GPB4F403.596
*ENDIF GPB4F403.597
IF ((A.NE.-1.0).OR.(LEN_IO.NE.IPTS)) THEN GPB4F403.598
WRITE(6,*)'ERROR READING DUMP ON UNIT ',NFTIN GPB4F403.599
ICODE=2 GPB4F403.600
CMESSAGE='READDUMP: BAD BUFFIN OF DATA' GPB4F403.601
CALL IOERROR('BUFFER IN FROM READDUMP',A,LEN_IO,IPTS) GPB4F403.602
RETURN GPB4F403.603
END IF GPB4F403.604
C Error in lookup(data_type,k) GPB4F403.605
ELSE GPB4F403.606
ICODE=3 GPB4F403.607
CMESSAGE='READDUMP: Invalid code in LOOKUP(DATA_TYPE,K)' GPB4F403.608
END IF GPB4F403.609
*IF -DEF,MPP GPB4F403.610
C Expand if necessary GPB4F403.611
IF (MOD((LOOKUP(LBPACK,K)),10).EQ.2) THEN GPB4F403.612
IF (LOOKUP(DATA_TYPE,K).EQ.1) THEN GPB4F403.613
C Expand real data and copy into final position GPB4F403.614
CALL EXPAND32B( LOOKUP(LBLREC,K) , D1(LOOKUP(NADDR,K)), GPB4F403.615
& FIXHD(12) ) GPB4F403.616
ELSE GPB4F403.617
ICODE=100 GPB4F403.618
CMESSAGE=' READDUMP: Attempt to expand a non-real field' GPB4F403.619
WRITE(6,*) 'READDUMP :attempt to expand a non-real field' GPB4F403.620
RETURN GPB4F403.621
END IF GPB4F403.622
END IF GPB4F403.623
*ELSE GPB4F403.624
! Code to expand field is contained within read_multi GPB4F403.625
*ENDIF GPB4F403.626
GPB4F403.627
ENDIF ! Skip to here if no data for this field GPB4F403.628
GPB4F403.629
START_BLOCK=START_BLOCK+LOOKUP(LBLREC,K) GPB4F403.630
real_start_block=real_start_block+um_sector_ipts GBC5F404.369
GPB4F403.631
200 CONTINUE GPB4F403.632
GPB4F403.633
*IF DEF,MPP GPB4F403.634
IF (mype .EQ. 0) THEN GPB4F403.635
*ENDIF GPB4F403.636
WRITE(6,'('' '')') GPB4F403.637
IF (FIXHD(5).GE.6 .AND. FIXHD(5).LE.8) THEN ! AC/Var Obs/ Cx file GPB4F403.638
WRITE(6,'('' OBSERVATION DATA'')') GPB4F403.639
ELSE GPB4F403.640
WRITE(6,'('' MODEL DATA'')') GPB4F403.641
ENDIF GPB4F403.642
WRITE(6,'('' '',I8,'' words long'')')FIXHD(161) GPB4F403.643
*IF DEF,MPP GPB4F403.644
ENDIF ! mype .EQ. 0 GPB4F403.645
*ENDIF GPB4F403.646
GPB4F403.647
ENDIF GPB4F403.648
GPB4F403.649
*IF DEF,MPP GPB4F403.650
IF (mype .EQ. 0) THEN GPB4F403.651
*ENDIF GPB4F403.652
WRITE(6,'('' '')') GPB4F403.653
WRITE(6,'('' INITIAL DATA SUCCESSFULLY READ -'',I9, GPB4F403.654
*'' WORDS FROM UNIT'',I3)')START_BLOCK,NFTIN GPB4F403.655
if(real_start_block.ne.start_block) then GBC5F404.370
write(6,'(/'' Number of Words Read from Disk was '',i9)') GBC5F404.371
2 real_start_block GBC5F404.372
endif GBC5F404.373
*IF DEF,MPP GPB4F403.656
ENDIF ! mype .EQ. 0 GPB4F403.657
*ENDIF GPB4F403.658
GPB4F403.659
9999 CONTINUE GPB4F403.660
RETURN GPB4F403.661
END GPB4F403.662
SUBROUTINE READACOBS(NFTIN,FIXHD,LEN_FIXHD ,7AAM1F404.277
& ,INTHD,LEN_INTHD AAM1F404.278
& ,REALHD,LEN_REALHD AAM1F404.279
& ,LEVDEPC,LEN1_LEVDEPC,LEN2_LEVDEPC AAM1F404.280
& ,ROWDEPC,LEN1_ROWDEPC,LEN2_ROWDEPC AAM1F404.281
& ,COLDEPC,LEN1_COLDEPC,LEN2_COLDEPC AAM1F404.282
& ,FLDDEPC,LEN1_FLDDEPC,LEN2_FLDDEPC AAM1F404.283
& ,EXTCNST,LEN_EXTCNST AAM1F404.284
& ,DUMPHIST,LEN_DUMPHIST AAM1F404.285
& ,CFI1,LEN_CFI1 AAM1F404.286
& ,CFI2,LEN_CFI2 AAM1F404.287
& ,CFI3,LEN_CFI3 AAM1F404.288
& ,LOOKUP,LEN1_LOOKUP,LEN2_LOOKUP AAM1F404.289
& ,LEN_DATA,D1, AAM1F404.290
*CALL ARGPPX AAM1F404.291
& ICODE,CMESSAGE AAM1F404.292
*IF DEF,MPP AAM1F404.293
& ,IPT AAM1F404.294
*ENDIF AAM1F404.295
& ) AAM1F404.296
AAM1F404.297
IMPLICIT NONE AAM1F404.298
AAM1F404.299
INTEGER IPT AAM1F404.300
INTEGER AAM1F404.301
* NFTIN !IN Unit no of dump AAM1F404.302
*,LEN_FIXHD !IN Length of fixed length header AAM1F404.303
*,LEN_INTHD !IN Length of integer header AAM1F404.304
*,LEN_REALHD !IN Length of real header AAM1F404.305
*,LEN1_LEVDEPC !IN 1st dim of level dep consts AAM1F404.306
*,LEN2_LEVDEPC !IN 2nd dim of level dep consts AAM1F404.307
*,LEN1_ROWDEPC !IN 1st dim of row dep consts AAM1F404.308
*,LEN2_ROWDEPC !IN 2nd dim of row dep consts AAM1F404.309
&,LEN1_COLDEPC !IN 1st dim of column dep consts AAM1F404.310
&,LEN2_COLDEPC !IN 2nd dim of column dep consts AAM1F404.311
&,LEN1_FLDDEPC !IN 1st dim of field dep consts AAM1F404.312
&,LEN2_FLDDEPC !IN 2nd dim of field dep consts AAM1F404.313
&,LEN_EXTCNST !IN Length of extra constants AAM1F404.314
&,LEN_DUMPHIST !IN Length of history block AAM1F404.315
&,LEN_CFI1 !IN Length of comp field index 1 AAM1F404.316
&,LEN_CFI2 !IN Length of comp field index 2 AAM1F404.317
&,LEN_CFI3 !IN Length of comp field index 3 AAM1F404.318
&,LEN1_LOOKUP !IN 1st dim of lookup AAM1F404.319
&,LEN2_LOOKUP !IN 2nd dim of lookup AAM1F404.320
AAM1F404.321
INTEGER AAM1F404.322
* LEN_DATA !IN Length of model data AAM1F404.323
*,ICODE !OUT Return code; successful=0 AAM1F404.324
* ! error > 0 AAM1F404.325
AAM1F404.326
CHARACTER*(80) AAM1F404.327
* CMESSAGE !OUT Error message if ICODE > 0 AAM1F404.328
AAM1F404.329
INTEGER AAM1F404.330
* FIXHD(LEN_FIXHD) !IN Fixed length header AAM1F404.331
*,INTHD(LEN_INTHD) !IN Integer header AAM1F404.332
*,LOOKUP(LEN1_LOOKUP,LEN2_LOOKUP) !IN PP lookup tables AAM1F404.333
AAM1F404.334
*,CFI1(LEN_CFI1+1) !IN Compressed field index no 1 AAM1F404.335
*,CFI2(LEN_CFI2+1) !IN Compressed field index no 2 AAM1F404.336
*,CFI3(LEN_CFI3+1) !IN Compressed field index no 3 AAM1F404.337
AAM1F404.338
REAL AAM1F404.339
& REALHD(LEN_REALHD) !IN Real header AAM1F404.340
&,LEVDEPC(1+LEN1_LEVDEPC*LEN2_LEVDEPC) !IN Lev dep consts AAM1F404.341
&,ROWDEPC(1+LEN1_ROWDEPC*LEN2_ROWDEPC) !IN Row dep consts AAM1F404.342
&,COLDEPC(1+LEN1_COLDEPC*LEN2_COLDEPC) !IN Col dep consts AAM1F404.343
&,FLDDEPC(1+LEN1_FLDDEPC*LEN2_FLDDEPC) !IN Field dep consts AAM1F404.344
&,EXTCNST(LEN_EXTCNST+1) !IN Extra constants AAM1F404.345
&,DUMPHIST(LEN_DUMPHIST+1) !IN History block AAM1F404.346
*,D1(LEN_DATA) !IN Real equivalence of data block AAM1F404.347
AAM1F404.348
*CALL CSUBMODL AAM1F404.349
*CALL CPPXREF AAM1F404.350
*CALL PPXLOOK AAM1F404.351
*CALL CLOOKADD AAM1F404.352
*IF DEF,MPP AAM1F404.353
*CALL PARVARS AAM1F404.354
*ENDIF AAM1F404.355
*CALL C_MDI GCJ2F405.1
*CALL CNTL_IO GCJ2F405.2
AAM1F404.356
C ------------------------------------------------------------- AAM1F404.357
C Local arrays:------------------------------------------------ AAM1F404.358
AAM1F404.359
C ------------------------------------------------------------- AAM1F404.360
C*L External subroutines called:------------------------------- AAM1F404.361
EXTERNAL IOERROR,POSERROR,READHEAD,PR_LOOK,PR_IFLD,PR_RFLD AAM1F404.362
*,PR_LFLD AAM1F404.363
*,BUFFIN,EXPAND32B AAM1F404.364
C Cray specific functions UNIT,LENGTH AAM1F404.365
C*------------------------------------------------------------- AAM1F404.366
C Local variables:--------------------------------------------- AAM1F404.367
INTEGER START_BLOCK ! Pointer to current position in file AAM1F404.368
*,LEN_IO ! No of 64-bit words buffered in AAM1F404.369
*,K,I ! Loop counts AAM1F404.370
*,IPTS ! No of 64-bit words requested to be AAM1F404.371
* ! buffered in AAM1F404.372
REAL A ! Error code returned by UNIT AAM1F404.373
c GCJ2F405.3
integer real_start_block ! Real disk address GCJ2F405.4
2 , l ! loop counter GCJ2F405.5
3 , word_address ! word address on disk of the record GCJ2F405.6
4 , um_sector_ipts ! number fo words to read, rounded up GCJ2F405.7
5 ! to a sector size GCJ2F405.8
6 , l_ipts ! local value of ipts for address calc. GCJ2F405.9
C-------------------------------------------------------------- AAM1F404.374
AAM1F404.375
*IF DEF,MPP AAM1F404.376
IF (mype .EQ. 0) THEN AAM1F404.377
*ENDIF AAM1F404.378
WRITE(6,'(/,'' READING ACOBS FILE ON UNIT'',I3)')NFTIN GCJ2F405.10
WRITE(6,'('' #####################################'',/)') AAM1F404.380
*IF DEF,MPP AAM1F404.381
ENDIF AAM1F404.382
*ENDIF AAM1F404.383
ICODE=0 AAM1F404.384
CMESSAGE=' ' AAM1F404.385
AAM1F404.386
CL 1. Read in all header records and check for consistency. AAM1F404.387
C START_BLOCK points to position of model data block AAM1F404.388
C on return AAM1F404.389
AAM1F404.390
CALL READHEAD(NFTIN,FIXHD,LEN_FIXHD, AAM1F404.391
& INTHD,LEN_INTHD, AAM1F404.392
& REALHD,LEN_REALHD, AAM1F404.393
& LEVDEPC,LEN1_LEVDEPC,LEN2_LEVDEPC, AAM1F404.394
& ROWDEPC,LEN1_ROWDEPC,LEN2_ROWDEPC, AAM1F404.395
& COLDEPC,LEN1_COLDEPC,LEN2_COLDEPC, AAM1F404.396
& FLDDEPC,LEN1_FLDDEPC,LEN2_FLDDEPC, AAM1F404.397
& EXTCNST,LEN_EXTCNST, AAM1F404.398
& DUMPHIST,LEN_DUMPHIST, AAM1F404.399
& CFI1,LEN_CFI1, AAM1F404.400
& CFI2,LEN_CFI2, AAM1F404.401
& CFI3,LEN_CFI3, AAM1F404.402
& LOOKUP,LEN1_LOOKUP,LEN2_LOOKUP, AAM1F404.403
& LEN_DATA, AAM1F404.404
*CALL ARGPPX AAM1F404.405
& START_BLOCK,ICODE,CMESSAGE) AAM1F404.406
AAM1F404.407
IF(ICODE.GT.0)RETURN AAM1F404.408
AAM1F404.409
AAM1F404.410
CL 2. Buffer in model data one field at a time for AAM1F404.411
CL conversion from 32-bit to 64-bit numbers AAM1F404.412
AAM1F404.413
IF(FIXHD(160).GT.0)THEN AAM1F404.414
AAM1F404.415
C Check for error in file pointers AAM1F404.416
real_start_block=start_block GCJ2F405.11
if(start_block.ne.fixhd(160)) then GCJ2F405.12
C If new format Dumpfile, we must reset the start address GCJ2F405.13
if((lookup(lbnrec,1).eq.0.and.lookup(lblrec,1).gt.0) .or. GCJ2F405.14
C Ocean ACOBS Files (?) GCJ2F405.15
2 ((lookup(lbnrec,1).eq.imdi) .or. (lookup(lbegin,1).eq.imdi)) GCJ2F405.16
3 .or. GCJ2F405.17
C Prog lookups in dump before vn3.2: GCJ2F405.18
4 ((lookup(lbnrec,1).eq.imdi) .and. (fixhd(12).le.301))) then GCJ2F405.19
CMESSAGE='READACOBS: Addressing conflict' AAM1F404.418
ICODE=1 AAM1F404.419
CALL POSERROR('model data', AAM1F404.420
* START_BLOCK,160,FIXHD(160)) AAM1F404.421
RETURN AAM1F404.422
else GCJ2F405.20
real_start_block=fixhd(160) GCJ2F405.21
endif GCJ2F405.22
ENDIF AAM1F404.423
AAM1F404.424
C Move to start of data. AAM1F404.425
CALL SETPOS (NFTIN,FIXHD(160)-1,ICODE) AAM1F404.426
AAM1F404.427
C Loop over number of fields in data block AAM1F404.428
DO 200 K=1,FIXHD(152) AAM1F404.429
AAM1F404.430
IF (LOOKUP(LBLREC,K).GT.0) THEN ! Any data for this field ? AAM1F404.431
AAM1F404.432
C Test whether data stored as 32-bit on disk AAM1F404.433
IF (MOD((LOOKUP(LBPACK,K)),10).EQ.2) THEN AAM1F404.434
IPTS=(LOOKUP(LBLREC,K)+1)/2 AAM1F404.435
ELSE AAM1F404.436
IPTS=LOOKUP(LBLREC,K) AAM1F404.437
ENDIF AAM1F404.438
AAM1F404.439
GCJ2F405.23
C Compute word address in file from which to begin I/O GCJ2F405.24
GCJ2F405.25
C Old Format dumpfiles GCJ2F405.26
if((lookup(lbnrec,k).eq.0) .or. GCJ2F405.27
C Ocean ACOBS Files (?) GCJ2F405.28
2 ((lookup(lbnrec,k).eq.imdi) .or. (lookup(lbegin,k).eq.imdi)) GCJ2F405.29
3 .or. GCJ2F405.30
C Prog lookups in dump before vn3.2: GCJ2F405.31
4 ((lookup(lbnrec,k).eq.imdi) .and. (fixhd(12).le.301))) then GCJ2F405.32
C Dump and ancillary files GCJ2F405.33
word_address=1 GCJ2F405.34
if(k.gt.1)then GCJ2F405.35
do l=2,k GCJ2F405.36
if(mod(lookup(lbpack,l-1),10).eq.2) then GCJ2F405.37
l_ipts=(lookup(lblrec,l-1)+1)/2 GCJ2F405.38
else GCJ2F405.39
l_ipts=(lookup(lblrec,l-1)) GCJ2F405.40
endif GCJ2F405.41
word_address=word_address+l_ipts GCJ2F405.42
end do GCJ2F405.43
endif GCJ2F405.44
word_address=fixhd(160)+word_address-2 GCJ2F405.45
um_sector_ipts=ipts GCJ2F405.46
GCJ2F405.47
else GCJ2F405.48
GCJ2F405.49
C PP type files and new format Dumpfiles (vn4.4 onwards) GCJ2F405.50
word_address=lookup(lbegin,k) GCJ2F405.51
C Use the stored round-up value GCJ2F405.52
um_sector_ipts=lookup(lbnrec,k) GCJ2F405.53
endif GCJ2F405.54
GCJ2F405.55
C Position file pointer GCJ2F405.56
call setpos(nftin,word_address,icode) GCJ2F405.57
GCJ2F405.58
C Read data into final position AAM1F404.440
C Check that data_type is valid no: 1 to 3 or -1 to -3 AAM1F404.441
IF((LOOKUP(DATA_TYPE,K).GE.1.AND.LOOKUP(DATA_TYPE,K).LE.3) .OR. AAM1F404.442
+ (LOOKUP(DATA_TYPE,K).LE.-1.AND.LOOKUP(DATA_TYPE,K).GE.-3)) AAM1F404.443
+ THEN AAM1F404.444
ipts=um_sector_ipts GCJ2F405.59
*IF -DEF,MPP AAM1F404.445
CALL BUFFIN(NFTIN,D1(LOOKUP(NADDR,K)),IPTS,LEN_IO,A) AAM1F404.446
*ELSE AAM1F404.447
CALL BUFFIN_acobs(NFTIN,D1(LOOKUP(NADDR,K)),IPTS,LEN_IO,A, AAM1F404.448
& IPT) AAM1F404.449
IF(MYPE.EQ.0)WRITE(0,*)K,IPTS,'READ IN TO',LOOKUP(NADDR,K) AAM1F404.450
*ENDIF AAM1F404.451
IF ((A.NE.-1.0).OR.(LEN_IO.NE.IPTS)) THEN AAM1F404.452
WRITE(6,*)'ERROR READING DUMP ON UNIT ',NFTIN AAM1F404.453
ICODE=2 AAM1F404.454
CMESSAGE='READACOBS: BAD BUFFIN OF DATA' AAM1F404.455
CALL IOERROR('BUFFER IN FROM READACOBS',A,LEN_IO,IPTS) AAM1F404.456
RETURN AAM1F404.457
END IF AAM1F404.458
C Error in lookup(data_type,k) AAM1F404.459
ELSE AAM1F404.460
ICODE=3 AAM1F404.461
CMESSAGE='READACOBS: Invalid code in LOOKUP(DATA_TYPE,K)' AAM1F404.462
END IF AAM1F404.463
*IF -DEF,MPP AAM1F404.464
C Expand if necessary AAM1F404.465
IF (MOD((LOOKUP(LBPACK,K)),10).EQ.2) THEN AAM1F404.466
IF (LOOKUP(DATA_TYPE,K).EQ.1) THEN AAM1F404.467
C Expand real data and copy into final position AAM1F404.468
CALL EXPAND32B( LOOKUP(LBLREC,K) , D1(LOOKUP(NADDR,K)), AAM1F404.469
& FIXHD(12) ) AAM1F404.470
ELSE AAM1F404.471
ICODE=100 AAM1F404.472
CMESSAGE=' READACOBS: Attempt to expand a non-real field' AAM1F404.473
WRITE(6,*) 'READACOBS :attempt to expand a non-real field' AAM1F404.474
RETURN AAM1F404.475
END IF AAM1F404.476
END IF AAM1F404.477
*ELSE AAM1F404.478
! Code to expand field is contained within read_multi AAM1F404.479
*ENDIF AAM1F404.480
AAM1F404.481
ENDIF ! Skip to here if no data for this field AAM1F404.482
AAM1F404.483
START_BLOCK=START_BLOCK+LOOKUP(LBLREC,K) AAM1F404.484
real_start_block=real_start_block+um_sector_ipts GCJ2F405.60
AAM1F404.485
200 CONTINUE AAM1F404.486
AAM1F404.487
*IF DEF,MPP AAM1F404.488
IF (mype .EQ. 0) THEN AAM1F404.489
*ENDIF AAM1F404.490
WRITE(6,'('' '')') AAM1F404.491
IF (FIXHD(5).GE.6 .AND. FIXHD(5).LE.8) THEN ! AC/Var Obs/ Cx file AAM1F404.492
WRITE(6,'('' OBSERVATION DATA'')') AAM1F404.493
ELSE AAM1F404.494
WRITE(6,'('' MODEL DATA'')') AAM1F404.495
ENDIF AAM1F404.496
WRITE(6,'('' '',I8,'' words long'')')FIXHD(161) AAM1F404.497
*IF DEF,MPP AAM1F404.498
ENDIF ! mype .EQ. 0 AAM1F404.499
*ENDIF AAM1F404.500
AAM1F404.501
ENDIF AAM1F404.502
AAM1F404.503
*IF DEF,MPP AAM1F404.504
IF (mype .EQ. 0) THEN AAM1F404.505
*ENDIF AAM1F404.506
WRITE(6,'('' '')') AAM1F404.507
WRITE(6,'('' INITIAL DATA SUCCESSFULLY READ -'',I9, AAM1F404.508
*'' WORDS FROM UNIT'',I3)')START_BLOCK,NFTIN AAM1F404.509
if(real_start_block.ne.start_block) then GCJ2F405.61
write(6,'(/'' Number of Words Read from Disk was '',i9)') GCJ2F405.62
2 real_start_block GCJ2F405.63
endif GCJ2F405.64
*IF DEF,MPP AAM1F404.510
ENDIF ! mype .EQ. 0 AAM1F404.511
*ENDIF AAM1F404.512
AAM1F404.513
9999 CONTINUE AAM1F404.514
RETURN AAM1F404.515
END AAM1F404.516
*ENDIF READDM1A.216
*ENDIF AJC0F405.271