*IF DEF,C80_1A,OR,DEF,UTILIO,OR,DEF,RECON UIE3F404.53
*IF -DEF,SCMA AJC0F405.280
C ******************************COPYRIGHT****************************** GTS2F400.8011
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.8012
C GTS2F400.8013
C Use, duplication or disclosure of this code is subject to the GTS2F400.8014
C restrictions as set forth in the contract. GTS2F400.8015
C GTS2F400.8016
C Meteorological Office GTS2F400.8017
C London Road GTS2F400.8018
C BRACKNELL GTS2F400.8019
C Berkshire UK GTS2F400.8020
C RG12 2SZ GTS2F400.8021
C GTS2F400.8022
C If no contract has been raised with this copy of the code, the use, GTS2F400.8023
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.8024
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.8025
C Modelling at the above address. GTS2F400.8026
C ******************************COPYRIGHT****************************** GTS2F400.8027
C GTS2F400.8028
CLL SUBROUTINE READFLDS--------------------------------------- READFL1A.3
CLL READFL1A.4
CLL Purpose: Buffers in NUMBER_OF_FIELDS fields from DATA block on unit READFL1A.5
CLL NFTIN. 32-bit and 64-bit real numbers and integer/logical READFL1A.6
CLL data types are handled. The I/O starts at field number READFL1A.7
CLL POSITION, where POSITION is the number of the PP header READFL1A.8
CLL pointing to the 1st field to be read. The code uses SETPOS READFL1A.9
CLL to position the file pointer. The input file must therefore READFL1A.10
CLL be unblocked, ie use assign ... -su ... in the script. READFL1A.11
CLL READFL1A.12
CLL AD, DR, TJ <- programmer of some or all of previous code or changes READFL1A.13
CLL READFL1A.14
CLL Model Modification history from model version 3.0: READFL1A.15
CLL version Date READFL1A.16
CLL AD060593.12
CLL 3.1 19/02/93 Use FIXHD(12) not FIXHD(1) as Version no in P21BITS DR221193.182
CLL 3.2 06/05/93 Extend code to recognise PP type files AD060593.13
CLL Author: A. Dickinson Reviewer: D. Richardson AD060593.14
CLL 3.3 22/11/93 Call PR_LFLD to print logical fields. Skip DIAG80 DR221193.183
CLL diagnostics for observation files. Skip field DR221193.184
CLL summaries for boundary data, fields packed by DR221193.185
CLL WGDOS method or compressed by GRIB method. DR221193.186
CLL D. Robinson & D Goddard. DR221193.187
CLL 3.3 08/12/93 Extra argument - first dimension of lookup table. DR081293.1
CLL Remove hard wired value of 64. D. Robinson DR081293.2
CLL 4.1 11/05/96 Allowed for Var and OPS files. Author Colin Parrett VSB1F401.388
!LL 4.1 30/04/96 Added MPP code. P.Burton GPB0F401.273
CLL 4.1 03/01/96 Relace Char*100 with Char*80 (N Farnon) ANF0F401.1
! 4.1 18/06/96 Changes to cope with changes in STASH addressing GDG0F401.1213
! Author D.M. Goddard. GDG0F401.1214
! 4.2 12/11/96 Detects non-constant PSTAR on pole rows APB1F402.109
! P.Burton APB1F402.110
!LL 4.2 15/11/96 Allows MPP code to read LBC files. P.Burton APB1F402.236
!LL 4.4 21/07/97 Set IPTS correctly for packed MPP fields GPB1F404.100
!LL P.Burton GPB1F404.101
CLL 4.3 17/04/97 Tidy DEFS and code so that blank source is not GEX1F403.133
CLL produced (A. Brady) GEX1F403.134
! 4.3 22/04/97 Modifications to allow MPP use with read_multi GPB4F403.663
! which now requires an extra argument to GPB4F403.664
! describe the date being read. P.Burton GPB4F403.665
! 4.3 15/04/97 Extra argument for READFLDS for IEEE only to UDG2F404.153
! select 32-64 expansion routine UDG6F403.7
! EXPAND21 or C90_EXPAND21 UDG6F403.8
! D.M.Goddard UDG6F403.9
! 4.4 28/10/97 Cleared bottom two rows to avoid NaNs in UV GPB1F404.134
! fields. P.Burton GPB1F404.135
! 4.4 13/06/97 Filled in extra elements of fake_D1_ADDR array GPB0F404.163
! required for MPP code so rdmult knows which IM GPB0F404.164
! field belongs to. P.Burton GPB0F404.165
! 4.4 25/09/97 Correct the propogation of ICODE/P_CONST for GBCXF404.1
! Multi-field read with well-formed I/O GBCXF404.2
! Author: Bob Carruthers, Cray Research GBCXF404.3
! 4.4 25/04/97 Changes to read well-formed records if the GBC5F404.374
! input dumpfile is in that format (almost PP file GBC5F404.375
! format) GBC5F404.376
! Author: Bob Carruthers, Cray Research GBC5F404.377
! 4.4 25/07/97 Extra argument for READFLDS for IEEE only to UDG2F404.154
! enable ieee to cray format conversion for UDG2F404.155
! 32 bit packed dumps UDG2F404.156
! 4.5 08/07/98 Corrected error, when reading last GPB0F405.79
! field could cause data to be written past the GPB0F405.80
! end of the input array. Paul Burton GPB0F405.81
! 4.5 28/10/98 Introduce Single Column Model. J-C Thil. AJC0F405.281
! 4.5 27/07/98 For LBC data set fake_D1_ADDR for all GSI1F405.354
! sub-models. S.Ineson GSI1F405.355
! 4.5 05/11/98 Prevent failure in small utilities when UDG1F405.1550
! land-sea mask in fieldsfile. UDG1F405.1551
! Author D.M. Goddard UDG1F405.1552
CLL READFL1A.17
CLL Programming standard: Unified Model Documentation Paper No 3 READFL1A.18
CLL Version No 1 15/1/90 READFL1A.19
CLL READFL1A.20
CLL Logical component: C25 READFL1A.21
CLL READFL1A.22
CLL System task: F3 READFL1A.23
CLL READFL1A.24
CLL Documentation: Unified Model Documentation Paper No F3 READFL1A.25
CLL Version No 5 9/2/90 READFL1A.26
CLL------------------------------------------------------------ READFL1A.27
C*L Arguments:------------------------------------------------- READFL1A.28
READFL1A.29
SUBROUTINE READFLDS(NFTIN,NUMBER_OF_FIELDS, ! Intent (In) 136,24GDG0F401.1215
& POSITION,LOOKUP,LEN1_LOOKUP, ! GDG0F401.1216
& D1,LEN_BUF,FIXHD, ! GDG0F401.1217
*CALL ARGPPX 
GDG0F401.1218
*IF DEF,CONVIEEE UDG6F403.10
& IEEE_TYPE,LPVP, UDG2F404.157
*ENDIF UDG6F403.12
*IF DEF,CONVIEEE,OR,DEF,CUMF,OR,DEF,PUMF,OR,DEF,CAMDUMP GEX1F403.135
& wgdos_expand,icode,cmessage) ! Intent (In/Out) UBC1F402.2
*ELSE UBC1F402.3
& ICODE,CMESSAGE) ! Intent (Out) GDG0F401.1219
*ENDIF UBC1F402.4
READFL1A.32
IMPLICIT NONE READFL1A.33
READFL1A.34
INTEGER READFL1A.35
* NFTIN !IN Unit number for I/O READFL1A.36
*,ICODE !OUT Return code =0 normal exit; >0 error READFL1A.37
*,NUMBER_OF_FIELDS !IN No of fields to be read READFL1A.38
*,LEN_BUF !IN Length of I/O buffer READFL1A.39
*,POSITION !IN Field number from which to begin I/O READFL1A.40
*,FIXHD(*) !IN Fixed length header READFL1A.41
*,LEN1_LOOKUP !IN First dimension of lookup table DR081293.5
*,LOOKUP(LEN1_LOOKUP,*) !IN PP lookup starting at field no 1 DR081293.6
*IF DEF,CONVIEEE UDG6F403.13
INTEGER IEEE_TYPE UDG6F403.14
LOGICAL LPVP UDG2F404.158
*ENDIF UDG6F403.15
*IF DEF,CONVIEEE,OR,DEF,CUMF,OR,DEF,PUMF,OR,DEF,CAMDUMP GEX1F403.136
integer wgdos_expand UBC1F402.6
*ENDIF UBC1F402.7
READFL1A.43
REAL READFL1A.44
* D1(*) !IN Start address of data to be read in READFL1A.45
READFL1A.46
CHARACTER*80 ANF0F401.2
* CMESSAGE !OUT Message returned if ICODE>0 READFL1A.48
C ------------------------------------------------------------- READFL1A.49
C Local arrays:------------------------------------------------ READFL1A.50
REAL BUF(LEN_BUF) !I/O buffer READFL1A.51
C ------------------------------------------------------------- READFL1A.52
C External subroutines called:--------------------------------- READFL1A.53
EXTERNAL PR_LOOK,PR_RFLD,IOERROR,EXPAND21,SETPOS,PR_IFLD,BUFFIN READFL1A.54
* ,P21BITS,PR_LFLD DR221193.188
*IF DEF,CONVIEEE UDG6F403.16
& ,C90_EXPAND21 UDG6F403.17
*ENDIF UDG6F403.18
INTEGER P21BITS READFL1A.56
C*------------------------------------------------------------- READFL1A.57
*IF DEF,MPP GPB0F401.274
! Common blocks and parameters for MPP code GPB0F401.275
*CALL PARVARS GPB0F401.276
GPB4F403.666
! Stuff required for fake D1_ADDR record GPB4F403.667
*CALL D1_ADDR GPB4F403.668
*ENDIF GPB0F401.277
*CALL CNTL_IO GBC5F404.378
C Local variables:--------------------------------------------- READFL1A.58
INTEGER READFL1A.59
* K,J ! Indicies READFL1A.60
*,LEN_IO ! Length of I/O returned by LENGTH READFL1A.61
*,IPTS ! No of values to be read from disk READFL1A.62
*,WORD_ADDRESS ! word address to begin I/O READFL1A.63
*,PACK_CODE ! word address to begin I/O DR221193.189
*IF DEF,MPP GPB0F401.278
*,local_len ! length of local part of field read in GPB0F401.279
*ENDIF GPB0F401.280
c GBC5F404.379
integer l ! loop counter GBC5F404.380
2 , um_sector_ipts ! number fo words to read, rounded up GBC5F404.381
3 ! to a sector size GBC5F404.382
4 , l_ipts ! local value of ipts for address calc. GBC5F404.383
5 , ipts_read ! number of words actually read from disk GBC5F404.384
READFL1A.64
REAL A_IO READFL1A.65
INTEGER I APB1F402.112
INTEGER ppxref_grid_type,field_model,field_sect,field_item APB1F402.113
INTEGER EXPPXI APB1F402.114
CHARACTER*36 EXPPXC APB1F402.115
EXTERNAL EXPPXI,EXPPXC APB1F402.116
*IF -DEF,MPP GPB4F403.669
REAL p_pole_val APB1F402.117
LOGICAL p_const APB1F402.118
*ENDIF APB1F402.119
logical global_p_const ! Used to hold the accumulated GBCXF404.4
! value of p_const over all fields GBCXF404.5
INTEGER JCODE !return code from EXPPXI and EXPPXC GPB4F403.670
GPB4F403.671
*IF DEF,MPP GPB4F403.672
GPB4F403.673
! Fake D1_ADDR record to be fed to read_multi GPB4F403.674
GPB4F403.675
INTEGER fake_D1_ADDR(D1_LIST_LEN) GPB4F403.676
INTEGER unset ! those values I won't set GPB4F403.677
PARAMETER (unset=-1) GPB4F403.678
GPB4F403.679
*ENDIF GPB4F403.680
*IF DEF,RECON APB1F402.120
CHARACTER*36 PHRASE APB1F402.121
*ENDIF APB1F402.122
C ------------------------------------------------------------- READFL1A.66
READFL1A.67
! Comdecks:---------------------------------------------------------- GDG0F401.1220
*CALL CSUBMODL GDG0F401.1221
*CALL CPPXREF GDG0F401.1222
*CALL PPXLOOK GDG0F401.1223
*CALL CLOOKADD READFL1A.68
*CALL C_MDI AD060593.15
*IF DEF,CONVIEEE,OR,DEF,CUMF,OR,DEF,PUMF,OR,DEF,CAMDUMP GEX1F403.137
real amdi UBC1F402.9
c UBC1F402.10
integer num_cray_words, num_unpack_values, idim, len_full_word, UBC1F402.11
2 ixx, iyy, idum, pack_type UBC1F402.12
c UBC1F402.13
idum=0 UBC1F402.14
idim=len_buf UBC1F402.15
amdi=rmdi UBC1F402.16
c UBC1F402.17
*ENDIF UBC1F402.18
READFL1A.69
ICODE=0 READFL1A.70
global_p_const=.true. GBCXF404.6
CMESSAGE=' ' READFL1A.71
READFL1A.72
READFL1A.91
CL 2. Buffer in NUMBER_OF_FIELDS fields of real data: READFL1A.92
J=0 READFL1A.93
DO 200 K=POSITION,POSITION+NUMBER_OF_FIELDS-1 READFL1A.94
GBC5F404.385
c--compute the number of words in this record GBC5F404.386
if(mod(lookup(lbpack,k),10).eq.2) then GBC5F404.387
ipts=(lookup(lblrec,k)+1)/2 GBC5F404.388
else GBC5F404.389
ipts=lookup(lblrec,k) GBC5F404.390
endif GBC5F404.391
GBC5F404.392
C Compute word address in file from which to begin I/O GBC5F404.393
GBC5F404.394
C Old Format dumpfiles GBC5F404.395
if((lookup(lbnrec,k).eq.0) .or. GBC5F404.396
C Ocean ACOBS Files (?) GBC5F404.397
2 ((lookup(lbnrec,k).eq.imdi) .or. (lookup(lbegin,k).eq.imdi)) GBC5F404.398
3 .or. GBC5F404.399
C Prog lookups in dump before vn3.2: GBC5F404.400
4 ((lookup(lbnrec,k).eq.imdi) .and. (fixhd(12).le.301))) then GBC5F404.401
C Dump and ancillary files GBC5F404.402
word_address=1 GBC5F404.403
if(k.gt.1)then GBC5F404.404
do l=2,k GBC5F404.405
if(mod(lookup(lbpack,l-1),10).eq.2) then GBC5F404.406
l_ipts=(lookup(lblrec,l-1)+1)/2 GBC5F404.407
else GBC5F404.408
l_ipts=(lookup(lblrec,l-1)) GBC5F404.409
endif GBC5F404.410
word_address=word_address+l_ipts GBC5F404.411
end do GBC5F404.412
endif GBC5F404.413
word_address=fixhd(160)+word_address-2 GBC5F404.414
um_sector_ipts=ipts GBC5F404.415
GBC5F404.416
else GBC5F404.417
GBC5F404.418
C PP type files and new format Dumpfiles (vn4.4 onwards) GBC5F404.419
word_address=lookup(lbegin,k) GBC5F404.420
C Use the stored round-up value GBC5F404.421
um_sector_ipts=lookup(lbnrec,k) GBC5F404.422
endif GBC5F404.423
GBC5F404.424
ipts_read=ipts GBC5F404.425
GBC5F404.426
! If this is the last field to be read, then set the size of data GPB0F405.82
! to be read in to be the real size of the data, and not the GPB0F405.83
! size including the padding. GPB0F405.84
IF (K .EQ. (POSITION+NUMBER_OF_FIELDS-1)) THEN GPB0F405.85
UM_SECTOR_IPTS=IPTS GPB0F405.86
ENDIF GPB0F405.87
C Position file pointer GBC5F404.427
call setpos(nftin,word_address,icode) GBC5F404.428
GPB4F403.681
*IF -DEF,PUMF,AND,-DEF,CUMF,AND,-DEF,CONVIEEE,AND,-DEF,CAMDUMP GPB4F403.682
! Get some information about this field GPB4F403.683
GPB4F403.684
field_item=MOD(LOOKUP(42,K),1000) GPB4F403.685
field_sect=(LOOKUP(42,K)-field_item)/1000 GPB4F403.686
field_model=LOOKUP(45,K) GPB4F403.687
GPB4F403.688
ppxref_grid_type=EXPPXI(field_model,field_sect,field_item, GPB4F403.689
& ppx_grid_type, GPB4F403.690
*CALL ARGPPX GPB4F403.691
& JCODE,CMESSAGE) GPB4F403.692
GPB4F403.693
*ENDIF GPB4F403.694
READFL1A.95
*IF -DEF,MPP GPB0F401.281
C Test whether data stored as 32-bit on disk READFL1A.96
*IF DEF,CONVIEEE,OR,DEF,CUMF,OR,DEF,PUMF,OR,DEF,CAMDUMP GEX1F403.138
pack_type=mod((lookup(lbpack,k)),10) UBC1F402.21
c--check for packing UBC1F402.22
if(pack_type.ne.0) then UBC1F402.23
c--check for a direct read into D1 for WGDOS data not being unpacked UBC1F402.25
if(pack_type.eq.1 .and. wgdos_expand.ne.1) then UBC1F402.26
call buffin(nftin,d1(j+1),ipts,len_io,a_io) UBC1F402.27
else UBC1F402.28
call buffin(nftin,buf(1),ipts,len_io,a_io) UBC1F402.29
endif UBC1F402.30
else UBC1F402.31
call buffin(nftin,d1(j+1),ipts,len_io,a_io) UBC1F402.32
endif UBC1F402.33
*ELSE UBC1F402.34
IF(MOD((LOOKUP(LBPACK,K)),10).EQ.2) THEN READFL1A.97
CALL BUFFIN(NFTIN,BUF(1),IPTS,LEN_IO,A_IO) READFL1A.99
ELSE READFL1A.100
CALL BUFFIN(NFTIN,D1(J+1),IPTS,LEN_IO,A_IO) READFL1A.102
ENDIF READFL1A.103
*ENDIF UBC1F402.35
*ELSE GPB0F401.282
IF ( LOOKUP(LBHEM,K) .EQ. 99 ) THEN ! This is LBC data APB1F402.237
! LBC data is read in as one big chunk of many fields APB1F402.238
IPTS=LEN_BUF APB1F402.239
um_sector_ipts=len_buf GBC5F404.429
ELSE APB1F402.240
ENDIF APB1F402.242
GPB4F403.696
! Set up fake D1_ADDR record to describe data to be read in GPB4F403.697
! Only set those items actually required by read_multi GPB4F403.698
! Assume that no diagnostic type fields will be read. GPB4F403.699
GPB4F403.700
DO i=1,D1_LIST_LEN GPB4F403.701
fake_D1_ADDR(i)=unset GPB4F403.702
ENDDO GPB4F403.703
GPB4F403.704
fake_D1_ADDR(d1_object_type)=prognostic GPB4F403.705
fake_D1_ADDR(d1_imodl)=field_model GPB0F404.166
fake_D1_ADDR(d1_section)=field_sect GPB0F404.167
fake_D1_ADDR(d1_item)=field_item GPB0F404.168
IF (LOOKUP(17,K) .EQ. 99) THEN ! LBC data - grid type is wrong GPB4F403.706
IF (field_model .eq. 1) THEN GSI1F405.356
fake_D1_ADDR(d1_grid_type)=ppx_atm_rim GSI1F405.357
ELSE IF (field_model .eq. 2) THEN GSI1F405.358
fake_D1_ADDR(d1_grid_type)=ppx_ocn_rim GSI1F405.359
ELSE IF (field_model .eq. 4) THEN GSI1F405.360
fake_D1_ADDR(d1_grid_type)=ppx_wam_rim GSI1F405.361
ELSE GSI1F405.362
icode=9 GSI1F405.363
write(6,*)' READFLDS: field_model = ',field_model GSI1F405.364
cmessage=' READFLDS: no rim gridtype for this submodel' GSI1F405.365
ENDIF GSI1F405.366
ELSE GPB4F403.708
fake_D1_ADDR(d1_grid_type)=ppxref_grid_type GPB4F403.709
ENDIF GPB4F403.710
fake_D1_ADDR(d1_length)=lasize(1)*lasize(2) GPB4F403.711
fake_D1_ADDR(d1_no_levels)=1 GPB4F403.712
GPB4F403.713
! The d1_length value is only used by "normal" fields - it is GPB4F403.714
! ignored for LBC and other non-standard grids GPB4F403.715
GPB4F403.716
DO i=(lasize(2)-2)*lasize(1)+1,lasize(1)*lasize(2) GPB1F404.136
D1(J+i)=0.0 GPB1F404.137
ENDDO GPB1F404.138
ipts_read=um_sector_ipts GBC5F404.430
call read_multi(nftin,d1(j+1),um_sector_ipts, GBC5F404.431
& len_io,local_len,a_io, GBC5F404.432
& LOOKUP(1,K),FIXHD(12),fake_D1_ADDR,CMESSAGE) GPB4F403.717
*ENDIF GPB0F401.285
READFL1A.104
C Check for I/O errors READFL1A.105
if(a_io.ne.-1.0.or.len_io.ne.ipts_read) then GBC5F404.433
WRITE(6,'('' *ERROR* Reading field no'',I5)')K READFL1A.107
IF (FIXHD(5).LT.6 .OR. FIXHD(5).GT.10) THEN ! Not AC/Cx/Cov/ObSt VSB1F401.389
CALL PR_LOOK( GDG0F401.1224
*CALL ARGPPX GDG0F401.1225
& LOOKUP,LOOKUP,LEN1_LOOKUP,K) GDG0F401.1226
ENDIF DR221193.191
CALL IOERROR('buffer in of real data',A_IO,LEN_IO, READFL1A.109
* IPTS) READFL1A.110
ICODE=NINT(A_IO)+1 READFL1A.111
CMESSAGE='READFLDS:I/O error' READFL1A.112
RETURN READFL1A.113
ENDIF READFL1A.114
READFL1A.115
*IF -DEF,MPP GPB0F401.286
C Unpack 32-bit numbers using P21BITS for exponent (fn of dump release) READFL1A.116
*IF DEF,CONVIEEE,OR,DEF,CUMF,OR,DEF,PUMF,OR,DEF,CAMDUMP GEX1F403.139
c UBC1F402.37
num_cray_words=ipts UBC1F402.38
num_unpack_values=lookup(lblrec,k) GBC5F404.434
len_full_word=64 UBC1F402.40
c UBC1F402.41
write(6,9964) k, lookup(lbfc, k), lookup(lbcfc, k), UBC1F402.42
2 lookup(data_type, k), lookup(lbpack, k), pack_type, UBC1F402.43
3 lookup(lblrec,k), word_address UBC1F402.44
9964 format(/'Field ',i4,' Field Codes = ',2i7,' Data Type = ',i7, UBC1F402.45
2 ' Packing Flag = ',i5,' Pack_type = ',i3/ UBC1F402.46
3 'Length from Header = ',i7,' Read from Address = ',i12) GBC5F404.435
c UBC1F402.48
c--check if we have packed data UBC1F402.49
if(pack_type.eq.1) then ! WGDOS packing UBC1F402.50
c--confirm that we should expand this WGDOS Field UBC1F402.51
if(wgdos_expand.eq.1) then UBC1F402.52
call coex(d1(j+1),idim,buf(1),num_cray_words,ixx,iyy, UBC1F402.53
& idum,idum,.false.,amdi,len_full_word) UBC1F402.54
num_unpack_values=ixx*iyy UBC1F402.55
endif UBC1F402.56
C Unpack 32-bit numbers using P21BITS for exponent (fn of dump release) UBC1F402.57
elseif(abs(pack_type).eq.2) then ! 32 Bit CRAY packing UDG1F405.1557
*IF DEF,CONVIEEE UDG6F403.19
IF(IEEE_TYPE.EQ.32.OR.LPVP)THEN UDG2F404.159
*ENDIF UDG6F403.21
call expand21(num_unpack_values,buf(1),d1(j+1), UBC1F402.60
& p21bits(fixhd(12))) UBC1F402.61
*IF DEF,CONVIEEE UDG6F403.22
ELSE UDG6F403.23
CALL C90_EXPAND21(num_unpack_values,buf(1),d1(j+1), UDG6F403.24
& p21bits(fixhd(12))) UDG6F403.25
ENDIF UDG6F403.26
*ENDIF UDG6F403.27
elseif(pack_type.eq.3) then ! GRIB packing UBC1F402.62
call degrib(buf(1),d1(j+1),idim,num_cray_words, UBC1F402.63
& lookup(1,k),amdi,num_unpack_values,len_full_word) UBC1F402.64
else if(pack_type.ne.0) then UBC1F402.65
icode=6 UBC1F402.66
cmessage=' READFLDS: packing type not yet supported' UBC1F402.67
endif UBC1F402.68
c UBC1F402.69
if(idim.lt.num_unpack_values) then UBC1F402.70
icode=7 UBC1F402.71
write(6,*)'READFLDS: IDIM = ',idim, UBC1F402.72
2 ' but NUM_UNPACK_VALUES = ',num_unpack_values UBC1F402.73
cmessage=' READFLDS: IDIM is too small for Unpacked Data' UBC1F402.74
return UBC1F402.75
endif UBC1F402.76
c UBC1F402.77
write(6,9968) num_cray_words, num_unpack_values UBC1F402.78
9968 format('NUM_CRAY_WORDS = ',i6,' NUM_UNPACK_VALUES = ',i6) UBC1F402.79
c UBC1F402.80
c--adjust the value of the length in case we have done UBC1F402.81
c unpacking UBC1F402.82
if(pack_type.gt.0) then UBC1F402.83
if(pack_type.eq.2) then UBC1F402.84
if(lookup(lblrec, k).ne.num_unpack_values .and. UBC1F402.85
2 lookup(lblrec, k)+1.ne.num_unpack_values) then UBC1F402.86
icode=8 UBC1F402.87
write(6,*)' READFLDS: Number of words for Cray Packed', UBC1F402.88
2 ' Data in the Header is ',lookup(lblrec, k),' but ', UBC1F402.89
3 num_unpack_values,' have been Found' UBC1F402.90
cmessage=' READFLDS: Record length is wrong for Cray '// UBC1F402.91
2 'Packed Data' UBC1F402.92
endif UBC1F402.93
else UBC1F402.94
if(lookup(lblrec, k).ne.num_unpack_values) then UBC1F402.95
write(6,'(''Field '',i4,'' - Record Length Changed from '', UBC1F402.96
2 i10,'' to '',i10)') position, UBC1F402.97
3 lookup(lblrec, k), num_unpack_values UBC1F402.98
lookup(lblrec, k)=num_unpack_values UBC1F402.99
endif UBC1F402.100
endif UBC1F402.101
endif UBC1F402.102
*ELSE UBC1F402.103
IF(MOD((LOOKUP(LBPACK,K)),10).EQ.2) THEN READFL1A.117
CALL EXPAND21(LOOKUP(LBLREC,K),BUF(1),D1(J+1), READFL1A.118
* P21BITS(FIXHD(12))) TJ190293.9
ENDIF READFL1A.120
*ENDIF UBC1F402.104
*IF -DEF,PUMF,AND,-DEF,CUMF,AND,-DEF,CONVIEEE,AND,-DEF,CAMDUMP GEX1F403.140
*IF DEF,RECON APB1F402.132
PHRASE=EXPPXC(field_model,field_sect,field_item, APB1F402.133
*CALL ARGPPX APB1F402.134
& JCODE,CMESSAGE) GPB4F403.695
Write(6,'(''Processing Field '',i5,'' Stash Code='',i5 APB1F402.136
& '' : '',a36)')k,field_sect*1000+field_item,phrase APB1F402.137
*ENDIF APB1F402.138
IF ((ppxref_grid_type .LE. 3) .AND. APB1F402.139
& (LOOKUP(LBHEM,K) .EQ. 0) APB1F402.140
*IF -DEF,RECON APB1F402.141
& .AND.(LOOKUP(ITEM_CODE,K) .EQ. 1) APB1F402.142
*ELSE APB1F402.143
& .AND.(LOOKUP(ITEM_CODE,K) .NE. 30) APB1F402.144
*ENDIF APB1F402.145
& ) THEN APB1F402.146
! This is P field APB1F402.147
! Search for non-constant value on pole rows APB1F402.148
p_const=.TRUE. APB1F402.149
APB1F402.150
p_pole_val=D1(J+1) APB1F402.151
DO I=2,LOOKUP(LBNPT,K) APB1F402.152
IF (D1(J+I) .NE. p_pole_val) p_const=.FALSE. APB1F402.153
ENDDO APB1F402.154
APB1F402.155
p_pole_val=D1(J+1+(LOOKUP(LBROW,K)-1)*LOOKUP(LBNPT,K)) APB1F402.156
DO I=2,LOOKUP(LBNPT,K) APB1F402.157
IF (D1(J+I+(LOOKUP(LBROW,K)-1)*LOOKUP(LBNPT,K)) .NE. APB1F402.158
& p_pole_val) APB1F402.159
& p_const=.FALSE. APB1F402.160
ENDDO APB1F402.161
APB1F402.162
IF (.NOT. p_const) THEN APB1F402.163
global_p_const=global_p_const.and.p_const GBCXF404.7
*IF DEF,RECON APB1F402.164
WRITE(6,*) 'Warning - non-constant polar row for ', APB1F402.165
& 'field ',K APB1F402.166
ICODE=1501 APB1F402.167
*ELSE APB1F402.168
WRITE(6,*) 'Non constant polar row found in dump : ', APB1F402.169
& 'field ',K APB1F402.170
WRITE(6,*) 'Dump must be reconfigured' APB1F402.171
WRITE(6,*) 'Model run aborted' APB1F402.172
ICODE=1 APB1F402.173
CMESSAGE='Non constant polar PSTAR found in dump' APB1F402.174
GOTO 9999 APB1F402.175
*ENDIF APB1F402.176
ENDIF APB1F402.177
APB1F402.178
ENDIF ! is this a p field APB1F402.179
*ENDIF APB1F402.180
READFL1A.121
*ENDIF GPB0F401.287
*IF DEF,DIAG80 READFL1A.122
*IF DEF,MPP GPB0F401.288
IF (mype .EQ. 0) THEN GPB0F401.289
*ENDIF GPB0F401.290
IF (FIXHD(5).LT.6 .OR. FIXHD(5).GT.10) THEN ! Not AC/Cx/Cov/ObSt VSB1F401.390
C Print out PP header DR221193.193
CALL PR_LOOK( GDG0F401.1227
*CALL ARGPPX GDG0F401.1228
& LOOKUP,LOOKUP,LEN1_LOOKUP,K) GDG0F401.1229
PACK_CODE=MOD(LOOKUP(LBPACK,K),10) DR221193.194
*IF DEF,CONVIEEE,OR,DEF,CUMF,OR,DEF,PUMF,OR,DEF,CAMDUMP GEX1F403.141
if (pack_code.eq.1 .and. wgdos_expand.ne.1) then UBC1F402.106
*ELSE UBC1F402.107
IF (PACK_CODE.EQ.1) THEN DR221193.195
*ENDIF UBC1F402.108
WRITE (6,*) DR221193.196
* 'WGDOS packing not supported. Field summary omitted.' DR221193.197
WRITE (6,*) ' ' DR221193.198
ELSEIF (PACK_CODE.EQ.3) THEN DR221193.199
WRITE (6,*) DR221193.200
* 'GRIB data compression not supported. Field summary omitted.' DR221193.201
WRITE (6,*) ' ' DR221193.202
ELSEIF (FIXHD(5).EQ.5) THEN DR221193.203
WRITE (6,*) 'Boundary dataset : Field summary omitted.' DR221193.204
WRITE (6,*) ' ' DR221193.205
ELSE DR221193.206
C Print out summary of data field DR221193.207
IF(FIXHD(2).EQ.1.AND.LOOKUP(ITEM_CODE,K).EQ.30)THEN UDG1F405.1553
! Land-sea mask is a special case data_type set to real in STASHmaster UDG1F405.1554
CALL PR_LFLD(LOOKUP,LOOKUP,64,D1(J+1),K) UDG1F405.1555
ELSE IF(LOOKUP(DATA_TYPE,K).EQ.1) THEN ! Real UDG1F405.1556
CALL PR_RFLD(LOOKUP,LOOKUP,D1(J+1),K) DR221193.209
ELSE IF(LOOKUP(DATA_TYPE,K).EQ.2) THEN ! Integer DR221193.210
CALL PR_IFLD(LOOKUP,LOOKUP,D1(J+1),K) DR221193.211
ELSE IF(LOOKUP(DATA_TYPE,K).EQ.3) THEN ! Logical DR221193.212
CALL PR_LFLD(LOOKUP,LOOKUP,64,D1(J+1),K) DR221193.213
ELSE IF(LOOKUP(DATA_TYPE,K).LT.0) THEN ! Time series field DR221193.214
WRITE (6,*) 'Field summary omitted : Time series field' DR221193.215
WRITE (6,*) ' ' DR221193.216
ENDIF DR221193.217
ENDIF DR221193.218
ENDIF READFL1A.129
*IF DEF,MPP GPB0F401.291
ENDIF ! IF (mype .EQ. 0) GPB0F401.292
*ENDIF GPB0F401.293
*ENDIF READFL1A.130
READFL1A.131
*IF -DEF,MPP GPB0F401.294
J=J+LOOKUP(LBLREC,K) READFL1A.132
*ELSE GPB0F401.295
J=J+local_len GPB0F401.296
IF ( LOOKUP(LBHEM,K) .EQ. 99 ) THEN ! This is LBC data APB1F402.243
GOTO 210 ! make sure loop over fields APB1F402.244
! ! stops after this LBC read in APB1F402.245
ENDIF APB1F402.246
*ENDIF GPB0F401.297
READFL1A.133
200 CONTINUE READFL1A.134
210 CONTINUE APB1F402.247
9999 CONTINUE APB1F402.181
READFL1A.135
c--set ICODE if we have found any non-constant polar rows GBCXF404.8
if(.not. global_p_const) icode=1501 GBCXF404.9
RETURN READFL1A.136
END READFL1A.137
*ENDIF READFL1A.138
*ENDIF AJC0F405.282