* * $Id: readwi.F,v 1.1.1.1 1996/02/15 17:47:37 mclareni Exp $ * * $Log: readwi.F,v $ * Revision 1.1.1.1 1996/02/15 17:47:37 mclareni * Kernlib * * #include "kernbit/pilot.h" SUBROUTINE READWI(LUN,ARRAY,MAXN,IERR,N,LERR) C C THIS SUBROUTINE WILL READ ONE W RECORD FROM A CDC FILE (7600 OR C NOS/BE FORMAT) WHICH HAS BEEN CREATED WITH W/I FORMAT. THE TAPE C OR DISK FILE SHOULD BE IBM U FORMAT, ONE RECORD/BLOCK. IT IS C ASSUMED THAT EACH BLOCK IS 512 60-BIT WORDS OR LESS, AND EXCESS C BITS WILL BE IGNORED. C EACH CDC 60-BIT WORD IS STORED RIGHT-JUSTIFIED IN A 64-BIT ELEMENT C OF THE REAL*8 ARRAY. THIS BUFFER CAN THEN BE PASSED TO C CONCDC TO CONVERT FROM CDC 60-BIT INTEGER OR FLOATING POINT C FORMAT TO IBM 32/64 BIT INTEGER OR FLOATING POINT FORMAT. C C THE SUBROUTINE CAN ONLY PROCESS A SINGLE LOGICAL UNIT UNLESS C ALL LOGICAL UNIT CHANGES OCCUR AT BLOCK BOUNDARIES. C EVEN THEN THERE WOULD BE SPURIOUS BLOCK NUMBER ERRORS. C C C LUN FORTRAN LOGICAL UNIT NUMBER OF FILE TO READ. C ARRAY REAL*8 ARRAY FOR THE RECORD OF C MAXN MAXIMUM 60/64 BIT WORDS. C IERR THE ERROR CODE. C 0 NORMAL RECORD C 1 END OF FILE, IOREAD ERROR 2 C 2 END OF PARTITION C 3 END OF SECTION C 4 END OF INFORMATION, IOREAD ERROR 4 C 5 PARITY ERROR OR SUCH, IOREAD ERROR 3 C 6 W CONTROL WORD ERROR C 7 IOREAD ERROR 1 - NO FILE OR BAD JCL/DCB I SUPPOSE C 8 BLOCK NUMBER ERROR (internal NOT returned) C 9 I CONTROL WORD ERROR C N NUMBER OF 64-BIT WORDS RETURNED (RECORD LENGTH). C LERR LOGICAL UNIT FOR ERROR REPORT AND SUMMARY. C -1 NO ERROR MESSAGES, NO SUMMARY. C 0 MESSAGES TO STANDARD OUTPUT (*). C L MESSAGES TO LOGICAL UNIT L. C C NO DATA IS RETURNED UNLESS IERR = 0. THE NEXT C CALL WILL CONTINUE PROCESSING DROPPING BAD DATA. C C E. MCINTOSH 16/6/86. C REAL * 8 ARRAY (*), REC (512) INTEGER IREC (1024) EQUIVALENCE (IREC(1),REC(1)) LOGICAL * 1 IBYTE (3840) C LOGICAL * 1 SKIP,SEVSIX C INTEGER * 4 NEXTW,NWORD,NBLOCK,IWORDS C C SAVE SKIP,NEXTW,NWORD,NBLOCK,REC,SEVSIX,IWORDS DATA SKIP /.FALSE./, SEVSIX /.FALSE./ DATA NEXTW /1/, NWORD /0/, NBLOCK /0/, IWORDS /0/ DATA M2/Z3/, M10/Z3FF/, M12/ZFFF/, M14/Z3FFF/, M18/Z3FFFF/ C C LIST OF VARIABLES C PARAMETERS : LUN, ARRAY, MAXN, IERR (VAR), N (VAR), LERR C NBLOCK : CURRENT BLOCK ORDINAL (MOD 4096) C IBLOCK : BLOCK ORDINAL FROM I CONTROL WORD C ITOFW : POINTER TO FIRST W CONTROL WORD IN BLOCK C IRECNO : RECORD ORDINAL (MOD 2**24) C NBYTE : NO OF BYTES RETURNED FROM IOPACK C NWORD : NO OF 60-BIT WORDS IN BLOCK C IBIT : FLAG FOR FIRST, MIDDLE, LAST, ONLY PIECE OF RECORD C ITYPE : FLAG FOR NORMAL, EOS, EOP, DELETED RECORD C IBEGIN : INDEX TO FIRST DATA ITEM C ICOUNT : NUMBER OF DATA ITEMS IN CURRENT W SEGMENT C SEVSIX : TRUE IF WE HAVE 7600 FORMAT WI (FALSE = NOS/BE) C IWORDS : TOTAL LENGTH OF A 7600 W RECORD C IBLOCK = -1 ITOFW = -1 IRECNO = -1 IBIT = -1 ITYPE = -1 IBEGIN = -1 ICOUNT = -1 IOERR = -1 NBYTE = -1 C N = 0 IERR = 0 C 10 IF (NEXTW.GT.NWORD) THEN C WE NEED A NEW BLOCK IF (NEXTW.NE.NWORD+1) THEN C SOMETHING WRONG EVEN IF SKIPPING IERR = 6 SKIP = .TRUE. CALL ERRLOG (LUN,REC(1),MAXN,IERR,N,LERR,NBYTE, 1 IOERR,NBLOCK,IBLOCK,ITOFW,IRECNO,NWORD, 2 ITYPE,IBIT,IBEGIN,ICOUNT,SKIP,NEXTW, 3 SEVSIX,IWORDS) NWORD = 0 NEXTW = 1 RETURN ENDIF C TRY AND READ A NEW BLOCK NBYTE = 3840 CALL IOGET (LUN,IBYTE(1),NBYTE,IOERR) C CALL IOREAD(LUN,IBYTE(1),NBYTE,IOERR) C C USED TO TEST PARITY ERROR HANDLING C IF ((NBLOCK/10)*10 .EQ. NBLOCK ) IOERR = 3 C IF (IOERR.NE.0) THEN IF (IOERR.EQ.1) THEN IERR = 7 ELSEIF (IOERR.EQ.2) THEN IERR = 1 ELSEIF (IOERR.EQ.3) THEN IERR = 5 ELSEIF (IOERR.EQ.4) THEN IERR = 4 ELSE IERR=7 ENDIF SKIP = .FALSE. IF (IERR.EQ.5) THEN SKIP = .TRUE. NBLOCK = NBLOCK+1 IF (NBLOCK.GE.4096) NBLOCK = NBLOCK - 4096 ENDIF ITEMP = (NBYTE+7)/8 CALL ERRLOG (LUN,IBYTE(1),MAXN,IERR,N,LERR,NBYTE, 1 IOERR,NBLOCK,IBLOCK,ITOFW,IRECNO,ITEMP, 2 ITYPE,IBIT,IBEGIN,ICOUNT,SKIP,NEXTW, 3 SEVSIX,IWORDS) NWORD = 0 NEXTW = 1 N = 0 RETURN ENDIF C GOT A NEW BLOCK NOW AT LAST C COUNT ONE MORE NBLOCK = NBLOCK + 1 IF (NBLOCK.GE.4096) NBLOCK = NBLOCK - 4096 C C REMEMBER SKIP MAY BE TRUE OR FALSE; SEE LATER C C NOW UNPACK 60 TO 64 BITS, IBYTE TO REC C CALL S$XTO4 (IBYTE,REC) C C COMPUTE THE NUMBER OF 60-BIT WORDS IN THE BLOCK C NWORD = (NBYTE*8) / 60 C C UNPACK THE I CONTROL WORD C IBLOCK BITS 53-42 THE BLOCK ORDINAL MOD 4096 C IRECNO BITS 41-18 THE RECORD ORDINAL MOD 2**24 C ITOFW BITS 17-0 WORD NO OF 1ST W CONTROL WORD C ITOFW IS ALWAYS 1 FOR NOS/BE FILES BUT MAY BE C ZERO (IF ENTIRE BLOCK IS PART OF A RECORD) OR C GT 1 (IF LAST PART OF A RECORD) C IF THE FILE IS A 7600 TAPE. C C IF (NWORD .EQ. 0) GO TO 10 ITOFW = IAND (IREC(2),M18) IRECNO = IAND ( ISHFT (IREC(2),-18),M14) 1 + ISHFT (IAND (IREC(1),M10),14) IBLOCK = IAND ( ISHFT (IREC(1),-10),M12) C CHECK THE BLOCK NUMBER IF (IBLOCK .NE. NBLOCK) THEN IERR = 8 CALL ERRLOG (LUN,REC(1),MAXN,IERR,N,LERR,NBYTE, 1 IOERR,NBLOCK,IBLOCK,ITOFW,IRECNO,NWORD, 2 ITYPE,IBIT,IBEGIN,ICOUNT,SKIP,NEXTW, 3 SEVSIX,IWORDS) IERR = 0 NBLOCK = IBLOCK ENDIF C CHECK ITOFW IS REASONABLE IF (ITOFW+1 .GT. NWORD) THEN IERR = 9 CALL ERRLOG (LUN,REC(1),MAXN,IERR,N,LERR,NBYTE, 1 IOERR,NBLOCK,IBLOCK,ITOFW,IRECNO,NWORD, 2 ITYPE,IBIT,IBEGIN,ICOUNT,SKIP,NEXTW, 3 SEVSIX,IWORDS) NWORD = 0 NEXTW = 1 N = 0 RETURN ENDIF C NOW SET UP NEXTW AND WSEG NOT FORGETTING THE 7600 C C WE MUST SET UP FROM W CONTROL WORD NOS/BE OR 7600 AS FOLLOWS: C IF THE POINTER TO THE 1ST W CONTROL WORD IS 0 WE ASSUME A C 7600 CONTINUATION RECORD, IF IS NOT 1 WE ASSUME A 7600 C CONTINUATION RECORD, LAST PIECE, OTHERWISE WE SET UP C ICOUNT = BITS 17-0 NUMBER OF WORDS IN THE SEGMENT C IBIT = BITS 43,42 AS 0 COMPLETE RECORD C 1 1ST PIECE C 2 MIDDLE PIECE C 3 LAST PIECE C ITYPE = BITS 58,57 AS 0 NORMAL RECORD C 1 DELETED RECORD C 2 END OF PARTITION C 3 END OF SECTION C BITS 23-18 UNUSED BIT COUNT ARE IGNORED C BITS 41-24 SIZE OF PREVIOUS + 1 FOR BACKSPACE ARE IGNORED C IBEGIN = ARRAY INDEX TO FIRST DATA ITEM C ICOUNT = THE NUMBER OF DATA ITEMS C IF (ITOFW .EQ. 0) THEN IF (.NOT.SEVSIX) GO TO 99 IWORDS = IWORDS - (NWORD-1) NEXTW = NWORD + 1 IF (IWORDS .EQ. 0) THEN IBIT = 3 ELSE IBIT = 2 ENDIF ITYPE = 0 ICOUNT = NWORD - 1 IBEGIN = 2 GO TO 20 ELSEIF (ITOFW .NE. 1) THEN IF (.NOT.SEVSIX) GO TO 99 IWORDS = IWORDS - (ITOFW-1) IF (IWORDS .NE. 0) GO TO 99 NEXTW = 1 + ITOFW IBIT = 3 ITYPE = 0 ICOUNT = ITOFW - 1 IBEGIN = 2 GO TO 20 ELSE C DECODE A NORMAL W CONTROL WORD NEXTW = 2 ENDIF C ENDIF C END OF NEED A NEW BLOCK; NOW WE HANDLE W AND DATA C C NOW WE DECODE A W CONTROL WORD IBEGIN = NEXTW + 1 INDEX = NEXTW * 2 ITYPE = IAND ( ISHFT (IREC(INDEX-1),-25),M2) IBIT = IAND ( ISHFT (IREC(INDEX-1),-10),M2) ICOUNT = IAND (IREC(INDEX),M18) NEXTW = NEXTW + ICOUNT + 1 20 CONTINUE C NOW WE HAVE DATA LET US VALIDATE ICOUNT C C USED TO TEST W CONTROL WORD ERRORS C IF ((NBLOCK/5)*5 .EQ. NBLOCK) ICOUNT = ICOUNT+10000 C IF (ICOUNT .NE. 0) THEN IF (IBEGIN+ICOUNT-1 .GT. NWORD) THEN C FOR THE MOMENT WE HAVE TO ASSUME A 7600 FORMAT FILE C THE WORD COUNT IS FOR THE COMPLETE RECORD EVEN IF THIS C PIECE IS ONLY THE FIRST SEGMENT. WE SET UP IBIT TO 1 C (1ST PIECE), IBEGIN IS OK, AND ITYPE IS 0 (NORMAL RECORD). C IWORDS IS USED TO CHECK CONSISTENCY WHEN WE GET THE REST. SEVSIX = .TRUE. IBIT = 1 IWORDS = ICOUNT ICOUNT = NWORD - IBEGIN + 1 IWORDS = IWORDS - ICOUNT NEXTW = NWORD + 1 ENDIF ENDIF C NEXT WE CHECK FOR SKIPPING TO START OF NEW RECORD IF (SKIP) THEN IF (ITYPE .EQ. 0 .AND. IBIT .GE. 2) GO TO 10 C I.E. IF NORMAL RECORD, MIDDLE OR LAST PIECE SKIP IT SKIP = .FALSE. ENDIF C NOW CHECK FOR TYPE OF RECORD IF (ITYPE .EQ. 1) GO TO 10 C SKIP A DELETED RECORD IF (ITYPE .NE. 0) THEN C WE HAVE EOS OR EOP IERR = ITYPE IF (N .NE. 0) GO TO 99 C INCOMPLETE RECORD INDICATES SOMETHING ROTTEN RETURN ENDIF C NEXT WE TRY AND TRANSFER TO USER IF (N + ICOUNT .GT. MAXN) THEN ICOUNT = MAXN - N IF (IBIT .EQ. 1 .OR. IBIT .EQ. 2) SKIP = .TRUE. ENDIF DO 40 I = 1,ICOUNT ARRAY (N+1) = REC (IBEGIN + I - 1) 40 N = N + 1 IF (SKIP .OR. IBIT .EQ. 0 .OR. IBIT .EQ. 3) RETURN C ARRAY IS FULL (SKIP) OR END OF RECORD COMPLETE OR LAST PIECE GO TO 10 99 IERR = 6 CALL ERRLOG (LUN,REC(1),MAXN,IERR,N,LERR,NBYTE, 1 IOERR,NBLOCK,IBLOCK,ITOFW,IRECNO,NWORD, 2 ITYPE,IBIT,IBEGIN,ICOUNT,SKIP,NEXTW, 3 SEVSIX,IWORDS) N=0 SKIP = .TRUE. NWORD = 0 NEXTW = 1 RETURN END