SUBROUTINE RDBLK6(IWRK,LREC,IBLK,IUNPK,ISTAT) C This subroutine reads NCAR I.S. Data Base Tape formatted data C sets. See "The NCAR I.S. Data Base Tape Format" for a format C description. When called RDBLK6 returns a status flag and the C next logical record in the dataset; i.e. sequential access. C Alternate entries, OPNBLK, CLSBLK and REWBLK provide a mechanism C for establishing connection of a fortran unit to a file name, C severing the connection, and rewinding the dataset. It is C necessary to call OPNBLK prior to calling RDBLK6. Closing and C rewinding are at the users discretion. The status flag provides C an indication when there is nothing left to read (or sooner, C depending on how the NEOFS termination condition is specified). C INPUTS: C IWRK = Work array provided by the user. See entry OPNBLK for C dimension. C LREC = Although this will contain a logical record on return C the user must provide the array dimensioned to MXVALS. C MXVALS = 10000 is usually enough, but RDBLK6 will C complain if more space is needed. C IBLK = User provided work array, dimensioned to MXWDS. C MXWDS = MXVALS*16/LMWD, where LMWD = computer word size C in bits. (IBLK contains a tape block). C IUNPK = User provided work array, dimensioned to MXVALS. (IUNPK C contains an unpacked version of IBLK, with the length C prefix and checksum suffix removed). C RETURNS: C LREC = Logical record. See the "NCAR I.S. Database Tape Format" C for a complete description of the record layout. The C prologue (the first 16 values) will always contain C integers. If the prologue indicates that the logical C record is type "data", the rest of LREC is also integers. C If, however, LREC contains a "header" or "catalogue" C record, elements starting at position 41 each contain C two ASCII characters in the right most 16 bits. (Use C subroutine HDRPRT to print the contents of these LRECS). C ISTAT = Status of last block read. This value should be C interpreted differently, depending on how NEOFS was C specified (in the OPNBLK call). C = 0 => Normal. LREC contains the next logical record C from fortran unit IBUN (IBUN is defined in OPNBLK). C = 1 => EOF (end of file) encountered. C If NEOFS>0, then NEOFS files have been read from C IBUN (and presumably the user wishes to terminate). C If NEOFS=0, then another call to RDBLK6 is in order C as there may be more data to read in IBUN. C = 2 => Parity error. C If NEOFS>0, the user will not see this value as the C RDBLK6 will automatically print a warning and C proceed to read the next block block. C If NEOFS=0, then the user must call RDBLK6 again to C try to read the next block. C = 3 => EOD (end of data) encountered. Another call to C RDBLK6 will result in an error (unless IBUN is C repositioned at the beginning via entry REWBLK). C C Alternate entrys: C OPNBLK(IBUN,NAME,NEOFS,IOCKSM,MSGUN,LMWD,MXVALS,MXWDS,IWRK,LWRK) C OPNBLK must be called prior to calling RDBLK6 in order C to establish connection between IBUN and NAME as well C as some other houskeeping tasks. All arguments are C inputs: C IBUN = Fortran unit number to use for reading file NAME. C NAME = Character string containing the name of the C input dataset. C NEOFS = Number of EOFs to encounter, before RDBLK6 sends C a completion status message. There are two C ways to use this termination warning: C (1) NEOFS = 0. Control is returned to the user C for all conditions that ISTAT is not 0 and C LREC is not updated. This gives the user C the most control; e.g., this is useful when C desiring to examine the last LREC of each C file in NAME or it is useful when desiring to C count files in NAME. C (2) NEOFS > 0. When an EOF is encountered, the C first LREC of the next file returned. This C This continues until NEOFS files have been C read; at which point LREC is not updated and C ISTAT=1. If the EOD is encountered before C NEOFS files are read, ISTAT = 3. Note that C attempting to read more than is there will C result in an error, so the user should always C check ISTAT after a RDBLK6 call. C IOCKSM= Checksum option; on=1, off=0. If on, block C checksums will be verified. C MSGUN = Fortran unit to use for any diagnostic messages. C LMWD = Word size in bits; e.g., 32. C MXVALS= The dimension of arrays, LREC and IUNPK. C MXWDS = The dimension of array IBLK. C IWRK = Work array provided by the user. C LWRK = Length of IWRK array provided by the user. The C dimension of IWRK is a function of the machine C word size: C dimension = 37 + 2 * 512 * 64 / LMWD C C CLSBLK(IWRK) C CLSBLK may be called to break the connection between C IBUN and NAME. This is handy when desiring to use C IBUN for multiple purposes in the same program. C C REWBLK(IWRK) C REWBLK positions IBUN at the beginning of NAME, thus C providing a way to rewind NAME. C C HISTORY: C RDBLK6 is similar to RDBLK5 except that most parameters C passed to RDBLK6 are contained in an array called IWRK. C This makes RDBLK6 recallable using different Fortran units. C The same characteristics for RDBLK5 are true for RDBLK6: C There are more call arguments which allow LMWD and all C array sizes to set externally. Rather than using system C specific calls to print diagnostics in the log file during C batch execution these prints have been moved to unit MSGUN. C The alternate entries were added (Jan 90) to provide a more C portable interface with UNIX systems in mind. This version C was installed on a 32-bit UNIX machine using my version of rdtape C called cbfrd. Next it was installed back on a COS Cray, and C most recently, on UNICOS. The biggest UNICOS change, was to C add logic to set status to EOD encountered based apon reading C sequential EOF's. C C The following list of the parameters describes the IWRK array C elements used by RDBLK6. The variable names following the IWRK C element numbers are in some cases vestiges of RDBLK5; in those C instances a description is provided (as it is not available C elsewhere): C IWRK( 1) = IBUN C IWRK( 2) = NEOFS C IWRK( 3) = MSGUN C IWRK( 4) = LMWD C IWRK( 5) = MXVALS C IWRK( 6) = MXWDS C IWRK( 7) = FIRST = Switch (on=1, off=0) to initialize pointers C and counters in RDBLK6. C IWRK( 8) = IOCKSM C IWRK( 9) = POINTR = Pointer into IUNPK, indicating the begining C of the next lrec. C IWRK(10) = NVALS = The number of assigned values in IUNPK. C IWRK(11) = LPREC = The number of assigned values in IBLK (the C first 16 bit value in IBLK). C IWRK(12) = NPREC = The number of blocks read. C IWRK(13) = NWARN = Number of warning messages issued about C blocks containing zero filled 16-bit values C at the end of the block (before the checksum) C IWRK(14) = NLMSGS = The number of blocks which had non-zero C 16-bit values after the checksum. C IWRK(15) = NPERR = The number of blocks with parity errors. C IWRK(16) = EOFCNT = The number of EOFs encountered. C IWRK(17) = NLRECS = The number of logical records read. C IWRK(18) to IWRK(x) = Yet another work array that is used by C subroutine CBFRD (which does the actual C read). The additional space needed by CBFRD C depends on LMWD and may be calculated as C dim = 20 + 2 * 512 * 64 / LMWD. C So IWRK must be dimensioned to 17 + dim; C e.g., if LMWD=32, x=2085 or when C LMWD=16, x=4133. C C Declarations for formal arguments (call variables) DIMENSION LREC(*) , IUNPK(*) , IWRK(*) , IBLK(*) CHARACTER*(*) NAME C C Local declarations: PARAMETER (MXNPER=10) DIMENSION IDUMP(10) INTEGER REMANS,CKSUM,CKSMRD LOGICAL NEDMOR C C UNICOS version (curently UNICOS does not return EOD to IOWAIT C so this is a patch to keep count of the number of sequential C EOF's (no intervening data) for each possible fortran unit: SAVE NSEOF ! <- Cray UNICOS version DIMENSION NSEOF(100) ! <- Cray UNICOS version C C Skip alternate entry points code GO TO 5 C C Initialize arrays, pointers, etc. for reading: ENTRY OPNBLK(IBUN,NAME,NEOFS,IOCKSM,MSGUN,LMWD,MXVALS,MXWDS, + IWRK,LWRK) IWRK( 1) = IBUN IWRK( 2) = NEOFS IWRK( 3) = MSGUN IWRK( 4) = LMWD IWRK( 5) = MXVALS IWRK( 6) = MXWDS IWRK( 7) = 1 IWRK( 8) = IOCKSM ICK = MXVALS*16/LMWD IF(MXWDS .LT. ICK)GO TO 8100 CUNIX ICK = 37 + 65536 / LMWD ICK = 17 ! <- Cray UNICOS version IF(LWRK .LT. ICK)GO TO 8200 CUNIX LWK = LWRK - 17 CUNIX CALL CBFOPN(IBUN,NAME,MSGUN,LMWD,1,IWRK(18),LWK) OPEN (IBUN,FILE=NAME,FORM='UNFORMATTED') ! <- Cray UNICOS version RETURN C C Close IBUN ENTRY CLSBLK(IWRK) CUNIX CALL CBFCLS(IWRK(1),IWRK(18)) CLOSE (IWRK(1)) ! <- Cray UNICOS version RETURN C C Rewind IBUN ENTRY REWBLK(IWRK) IWRK(7) = 1 CUNIX CALL CBFREW(IWRK(1),IWRK(18)) REWIND IWRK(1) ! <- Cray UNICOS version RETURN C C If the FIRST switch is on, initialize and read a block 5 NEDMOR = .FALSE. IF(IWRK(7) .EQ. 1)THEN IWRK(7) = 0 DO 6 I=10,17 6 IWRK(I) = 0 NSEOF(IWRK(1)) = 0 ! <- Cray UNICOS version GO TO 100 ENDIF C C Determine the number of 16-bit values left in IUNPK: REMANS = IWRK(10) - IWRK(9) + 1 IF(REMANS .LT. 0)GO TO 8900 IF(REMANS .EQ. 0)GO TO 100 IF(REMANS .LE. 3)THEN C If the remaining values are 0's go get another block; else C assume they are the beginning of an lrec spanning a block DO 7 I=IWRK(9),IWRK(9)+REMANS-1 IF(IUNPK(I) .NE. 0)GO TO 8 7 CONTINUE IWRK(13) = IWRK(13) + 1 GO TO 100 8 CONTINUE ENDIF C If only a partial LREC remains in IUNPK then fill LREC C with the REMANS, determine how many more values are needed, C turn on the 'I-need more' flag and go get another block. IF(REMANS .LT. IUNPK(IWRK(9)))THEN DO 10 I=1,REMANS 10 LREC(I) = IUNPK(IWRK(9)+I-1) NNEDED = IUNPK(IWRK(9))-REMANS NEDMOR = .TRUE. GO TO 100 ENDIF C At least one full LREC exists in IUNPK. Therefore, assign C LREC from IUNPK, move POINTR to the beginning of the next C possible LREC and return. First, check for a reasonable C logical record length before using it. 20 IF(IUNPK(IWRK(9)) .LE. 0)GO TO 9600 DO 30 I=1,IUNPK(IWRK(9)) 30 LREC(I) = IUNPK(IWRK(9)+I-1) IWRK(9) = IWRK(9) + LREC(1) IWRK(17) = IWRK(17) + 1 RETURN C C Initialize block buffer and pointer 100 DO 110,I=1,IWRK(6) 110 IBLK(I) = 0 DO 120,I=1,IWRK(5) 120 IUNPK(I) = 0 IWRK(9) = 1 C Read a block (physical record) containing a variable number C of logical records: C UNIX VERSION: CBFRD replaces calls to RDTAPE and IOWAIT CUNIX CALL CBFRD(IWRK(1),IBLK,IWRK(6),LBLK,NUB,ISTAT,IWRK(18)) CALL RDTAPE (IWRK(1),1,0,IBLK,IWRK(6)) ! <- Cray UNICOS version CALL IOWAIT (IWRK(1),ISTAT,LBLK) ! <- Cray UNICOS version IF(ISTAT .EQ. 1 .AND. + NSEOF(IWRK(1)) .GT. 0) ISTAT = 3 ! <- Cray UNICOS version C RDTAPE reads an entire block from unit IWRK(1) into array IBLK C which has been dimensioned to IWRK(6); there is no formatting C and variable length blocks are allowed. C IOWAIT obtains the status of the previous RDTAPE record read C request. C The status of unit IBUN is returned as ISTAT, an integer flag, C and LBLK, the number of words read). C ISTAT = 0 => okay read of LBLK words into IBLK C = 1 => end of file encountered, nothing new in IBLK C = 2 => parity error encountered, nothing new in IBLK C = 3 => end of data encountered, nothing new in IBLK C C Normal and error condition branches from ISTAT values: IF(ISTAT .EQ. 1)THEN IWRK(16) = IWRK(16) + 1 IF(NEDMOR)GO TO 9100 NSEOF(IWRK(1)) = NSEOF(IWRK(1)) + 1 ! <- Cray UNICOS version IWRK(9) = IWRK(10) + 1 IF(IWRK(2) .LT. 1)RETURN C>>>> (patch to prt prol of last lrec in each file) C CALL LRPRT(IWRK(3),IWRK(3),IWRK(17),'PROL',LREC) C>>>> IF(IWRK(16) .LT. IWRK(2))GO TO 100 WRITE(IWRK(3),'('' RDBLK6: Done reading from unit'',I3, + ''; # EOFs read = '',I5)')IWRK(1),IWRK(16) RETURN ENDIF IF(ISTAT .EQ. 2)THEN IWRK(9) = IWRK(10) + 1 IWRK(12) = IWRK(12) + 1 NSEOF(IWRK(1)) = 0 ! <- Cray UNICOS version IF(IWRK(2) .LT. 1)RETURN GO TO 9700 ENDIF IF(ISTAT .EQ. 3)THEN IF(NEDMOR)GO TO 9200 WRITE(IWRK(3),'('' RDBLK6: EOD encountered on unit'',I3, + '' after reading'',I5,'' files.'')')IWRK(1),IWRK(16) RETURN ENDIF IF(ISTAT .LT. 0 .OR. ISTAT .GT. 3)STOP NSEOF(IWRK(1)) = 0 ! <- Cray UNICOS version IWRK(12) = IWRK(12) + 1 C C Good block read; now strip off 16-bit values into array IUNPK. C First, get LPREC and CKSMRD (CHECKSUM) and calculate NVALS C based upon LPREC and test LBLK VS. LPREC. Also if CKSMOP C is .TRUE. calculate and compare checksums. C IWRK(11) LPREC = # 16-bit values read as the first value in the C block. C IWRK(10) NVALS = # 16-bit values in the block minus the length C prefix and the checksum suffix. C LBLK = # computer words found in the block. C (UNIX VERSION: NUB = number of unused bits in IBLK(LBLK) C CKSMRD = The 16-bit XOR checksum for the block. C IUNPK does not contain the prefix, IWRK(11), or suffix, CKSMRD 500 IF(LBLK .GE. IWRK(6))GO TO 9000 C C Subroutine GBYTE moves bits (16 starting at offset 0) from C array IBLK into word LPREC. The 16 bits are right justified C in LPREC that it is a normal integer. Hence, GBYTE C unpacks an integer value from an array. CALL GBYTE(IBLK,IWRK(11),0,16) C C It is likely that there is a partial word remaining at the C end of a block, since the logical records use a word length C (16-bit) different than the computer being used. The amount C of extra bits left over is a function of the word size of the C computer creating the block and the word size of the computer C reading it (the only known word size is the read). It is good C practice to see if end of a block has a truncated LREC or is C merely zero filled. If non-zero values are found, then print C a message, otherwise continue processing. IDIFF is the max C number of 16-bit values left over at the end of the block. C UNIX VERSION relies on NUB IDIFF = (LBLK*IWRK(4) - IWRK(11)*16)/16 CUNIX IDIFF = (LBLK*IWRK(4) - NUB - IWRK(11)*16)/16 C>>>> Patch for reading padded blocks (fixed length zero fill) IMXOK = 3000 C>>>> IMXOK = MAX0 (4,2*IWRK(4)/16) IF (IDIFF .LT. 0 .OR. IDIFF .GT. IMXOK) GO TO 9300 IF (IDIFF .GT. 0) THEN NNE0 = 0 IOFF = 16*IWRK(11) DO 510 I=1,IDIFF ITEMP = 0 CALL GBYTE(IBLK,ITEMP,IOFF,16) IF (ITEMP .NE. 0) NNE0 = NNE0+1 510 IOFF = IOFF + 16 IF (NNE0 .GT. 0) THEN IWRK(14) = IWRK(14) + 1 IF (IWRK(14) .LT. 10) + WRITE(IWRK(3),'('' RDBLK6: Warning: Block'',I5,'' had'',I5, + '' 16-bit values after the cksum;'',I3,'' are not 0'')') + IWRK(12),IDIFF,NNE0 ENDIF ENDIF IWRK(10) = IWRK(11) - 2 C Subroutine GBYTES is the plural of GBYTE; it unpacks IWRK(10) C values from IBLK into IUNPK, 16 bits at a time starting with C an initial offset into IBLK of 16 with an iteration bit skip of 0. C This GBYTES call does the unpacking of all lrecs in the prec CALL GBYTES(IBLK,IUNPK,16,16,0,IWRK(10)) IF(IWRK(8) .EQ. 1)THEN C This call gets the 16-bit checksum at the end of the IBLK CALL GBYTE(IBLK,CKSMRD,16*(IWRK(11)-1),16) CKSUM=IWRK(11) DO 550 I=1,IWRK(10) 550 CKSUM=CKSUM .XOR. IUNPK(I) IF(CKSUM .NE. CKSMRD)GO TO 9400 ENDIF C C Convert any negatives (2's complement notation) examples: C ABSOLUTE VALUE MAPS TO C ---------------- -------- C 0 = 0 -> 0 C 1 = 2**0 -> 1 C 32767 = 2**15-1 -> 32767 max positive value C 32768 = 2**15 -> -32768 min negative value C 32769 = 2**15+1 -> -32767 C 65535 = 2**16-1 -> -1 Max absolute val before convert DO 600 N=1,IWRK(10) IF(IUNPK(N) .GE. 32768)IUNPK(N) = IUNPK(N) - 65536 600 CONTINUE C C If more values from this IBLK are needed to complete the LREC C then assign these values from IUNPK to LREC, turn off the C 'NEDMOR' switch, and set POINTR to the beginning of the next C LREC in IUNPK; if NEDMOR is false then go back to the normal C LREC assignment logic (the DO 20 loop). IF(NEDMOR)THEN DO 700 I=1,NNEDED 700 LREC(REMANS+I) = IUNPK(I) IWRK(9) = NNEDED + 1 NEDMOR = .FALSE. IWRK(17) = IWRK(17) + 1 RETURN ENDIF GO TO 20 C C Error trap messages: 8100 WRITE(MSGUN,'('' RDBLK6: MXVALS and MXWDS do not agree. MXWDS'', + '' is too small.'',/, + '' MXWDS >= MXVALS*16/LMWD. Yet MXWDS,MXVALS='',2I8)') + MXWDS,MXVALS 8200 WRITE(MSGUN,'('' RDBLK6: Insufficient work array size'', + '' specified. LWRK input ='',I8,/, + '' but LWRK must be at least ='',I8)')LWRK,ICK STOP 8900 WRITE(IWRK(3),8910) REMANS 8910 FORMAT(' RDBLK6: Logic error: REMANS are < 0. REMANS = ',I10) STOP 9000 WRITE(IWRK(3),9010)IWRK(12),IWRK(16)+1 9010 FORMAT(' RDBLK6: Block/file',I6,'/',I4,' might be larger than ', + 'presently dimensioned; increase IWRK(5)') STOP 9100 WRITE(IWRK(3),9110)IWRK(12),IWRK(16)+1,(LREC(I),I=1,LREC(1)) 9110 FORMAT(' RDBLK6: Found only a partial lrec at the end of block', + I5,' of file',I4,' when an EOF was read.',/, + ' Logical records are not allowed to span EOFs. This', + ' lrec contained:',/,(10I8)) STOP 9200 WRITE(IWRK(3),9210)IWRK(12),IWRK(16)+1,(LREC(I),I=1,LREC(1)) 9210 FORMAT(' RDBLK6: Found only a partial lrec at the end of block', + I5,' of file',I4,' when the EOD was read.',/, + ' This lrec contained:',/,(10I8)) STOP 9300 N16S = LBLK*IWRK(4)/16 WRITE(IWRK(3),9310)IWRK(12),IWRK(16)+1,IWRK(4),LBLK,IWRK(11) 9310 FORMAT(' RDBLK6: Bogus block length read in block',I8,' of file', +I4,/,' Number of computer (',I2,'-bit) words returned =', +I8,/,' Number of 16-bit words specified in the block =',I8,/, + ' The block contents as 16-bit integers:',44X,'Last Index') IOFF = 0 DO 9330 I=1,N16S,10 DO 9320 J=1,10 9320 IDUMP(J) = 0 N2G = MIN0(10,N16S-I-1) CALL GBYTES(IBLK,IDUMP,IOFF,16,0,N2G) WRITE(IWRK(3),'(10I8,'' >'',I5)') IDUMP , I+N2G-1 9330 IOFF = IOFF + N2G*16 STOP 9400 IB=IWRK(10)-39 IF(IB .LT. 0)IB=1 WRITE(IWRK(3),9410)IWRK(12),IWRK(16)+1,CKSMRD,CKSUM, + (IUNPK(I),I=IB,IWRK(10)) 9410 FORMAT(' RDBLK6: Check-sum read does not match that computed', + ' for block',I5,' of file',I4,/, + ' read = ',I8,/, + ' computed = ',I8,/, + ' The end of the block contained:',/,(10I8)) WRITE(IWRK(3),9420)IWRK(11),(IUNPK(I),I=1,IWRK(10)) 9420 FORMAT(' RDBLK6: First 16-bit value in the block = ',I8,/, + ' The rest of the block after unpacking:',/,(10I8)) STOP 9600 WRITE(IWRK(3),9610)IWRK(12),IWRK(16)+1,REMANS,IUNPK(IWRK(9)), +IWRK(9),(IUNPK(I),I=IWRK(9)+1,REMANS) 9610 FORMAT(' RDBLK6: Bogus logical record length encountered in', + ' block ',I5,' of file ',I4,/, + ' Number of values left in block = ',I8,/, + ' Value found = ',I8,/, + ' at block position = ',I8,/, + ' Block contents after this value:',/,(10I8)) STOP 9700 IWRK(15)=IWRK(15) + 1 WRITE(IWRK(3),9710)IWRK(12),IWRK(16)+1 9710 FORMAT(' RDBLK6: Parity error encountered in block',I5, + ' of file',I4) IF(IWRK(15) .LT. MXNPER)GO TO 100 STOP END