* * $Id: fziasc.F,v 1.3 1999/06/18 13:28:45 couet Exp $ * * $Log: fziasc.F,v $ * Revision 1.3 1999/06/18 13:28:45 couet * - qcardl.inc was empty: It is now removed and not used. * Comment END CDE removed. * * Revision 1.2 1996/04/18 16:10:24 mclareni * Incorporate changes from J.Zoll for version 3.77 * * Revision 1.1.1.1 1996/03/06 10:47:12 mclareni * Zebra * * #include "zebra/pilot.h" #if defined(CERNLIB_FZALFA) SUBROUTINE FZIASC (NRSKPP) C- Read one physical record from cards in ALFA mode, C- service routine to FZIN, called via FZIPHA C- Do not expand fast blocks if NRSKIP not zero C- The record is stored into words LQ(LBUFA) to LQ(LBUFE-1) C- It is a 'fast' record if JFAST .NE. 0 #include "zebra/zbcd.inc" #include "zebra/zkrakc.inc" #include "zebra/zstate.inc" #include "zebra/zunit.inc" #include "zebra/mqsysh.inc" #include "zebra/fzci.inc" * DIMENSION NRSKPP(9) DIMENSION INITV(6), NBV(6), ICHSUM(2,2) EQUIVALENCE (LUN,IQUEST(90)), (JSKIP,IQUEST(91)) EQUIVALENCE (MRSTA,IQUEST(92)), (MREND,IQUEST(93)) EQUIVALENCE (JTKC,IQUEST(96)), (JTKL,IQUEST(97)) +, (JTKE,IQUEST(98)) #if defined(CERNLIB_QMVDS) SAVE INITV #endif #if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M)) DIMENSION NAMESR(2) DATA NAMESR / 4HFZIA, 4HSC / #endif #if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M)) DATA NAMESR / 6HFZIASC / #endif #if !defined(CERNLIB_QTRHOLL) CHARACTER NAMESR*8 PARAMETER (NAMESR = 'FZIASC ') #endif DATA INITV / 0, 1, 2, 3, 0, 134217727 / C- = 7FFFFFF Hex #include "zebra/q_or.inc" #include "zebra/q_shiftl.inc" #include "zebra/q_jbyt.inc" #include "zebra/qtraceq.inc" LUN = LUNI LBUFA = L4STAI LBUFE = L4STAI + MAXREI NRSKIP = NRSKPP(1) LBUFC = LBUFA IFLREP = 0 JCHSUM = 0 ICHSUM(1,1) = 0 ICHSUM(2,1) = 0 C---- Read first line of next physical record IQUEST(1) = 0 JTKC = 81 JTKE = JTKC MRSTA = 0 MREND = 0 JSKIP = 7 CALL FZIALN IF (IQUEST(1).NE.0) GO TO 101 IF (MRSTA.GT.1) THEN JFAST = 0 LBUFC = LBUFC+4 ELSE JFAST = 7 IF (NRSKIP.NE.0) GO TO 999 IF (NFASTI.EQ.0) GO TO 999 ENDIF MRSTA = 0 JSKIP = 0 ITYPE = 0 C------- Do next word 31 IF (JTKC.GE.JTKL) THEN IF (MREND.NE.0) GO TO 911 CALL FZIALN IF (IQUEST(1).NE.0) GO TO 101 ENDIF C-- Handle running type, check termination IF (ITYPE.LE.0) GO TO 34 IF (IQKRAK(JTKC).LT.33) GO TO 41 GO TO 70 C-- Find type of next word 34 JTYPC = IQKRAK(JTKC) JTKC = JTKC + 1 #if defined(CERNLIB_QDEVZE) IF (LOGLVI.GE.6) WRITE (IQLOG,9834) JTYPC,IQLETT(JTYPC) 9834 FORMAT (' FZIASC- Next control code/char.=',I4,1X,A1) #endif IF (JTYPC.GE.42) GO TO 71 IF (JTYPC-26) 36, 912, 35 35 IWORD = JTYPC - 27 IF (IWORD.LT.10) GO TO 61 JTYPC = JTYPC - 11 36 JTYPC = JTYPC - 1 JTYPE = JTYPC / 5 JTYPS = JTYPC - 5*JTYPE JTYPE = JTYPE + 1 NBUSE = 6 - JTYPS IF (JTYPE.GE.5) NBUSE=NBUSE-1 INIT = ISHFTL (INITV(JTYPE), 5) C---- Compose next word C-- copy bytes and check validity 41 DO 42 J=1,NBUSE NBV(J) = IQKRAK(JTKC) - 1 IF (NBV(J).GE.32) GO TO 913 42 JTKC = JTKC + 1 IWORD = IOR (NBV(1),INIT) IF (JTYPE.LT.5) GO TO 51 C-- Compose NBUSE 5-bit bytes for JTYPE=5,6 GO TO ( 60, 44, 45, 46, 47, 48), NBUSE 44 IWORD = IOR (NBV(2), ISHFTL(IWORD,5)) GO TO 60 45 IWORD = IOR (NBV(2), ISHFTL(IWORD,5)) IWORD = IOR (NBV(3), ISHFTL(IWORD,5)) GO TO 60 46 IWORD = IOR (NBV(2), ISHFTL(IWORD,5)) IWORD = IOR (NBV(3), ISHFTL(IWORD,5)) IWORD = IOR (NBV(4), ISHFTL(IWORD,5)) GO TO 60 47 IWORD = IOR (NBV(2), ISHFTL(IWORD,5)) IWORD = IOR (NBV(3), ISHFTL(IWORD,5)) IWORD = IOR (NBV(4), ISHFTL(IWORD,5)) IWORD = IOR (NBV(5), ISHFTL(IWORD,5)) GO TO 60 48 IWORD = IOR (NBV(2), ISHFTL(IWORD,5)) IWORD = IOR (NBV(3), ISHFTL(IWORD,5)) IWORD = IOR (NBV(4), ISHFTL(IWORD,5)) IWORD = IOR (NBV(5), ISHFTL(IWORD,5)) IWORD = IOR (NBV(6), ISHFTL(IWORD,5)) GO TO 60 C-- Compose NBUSE 5-bit bytes for JTYPE=1,2,3,4 51 GO TO ( 60, 54, 55, 56, 57, 58), NBUSE 54 IWORD = IOR (NBV(2), ISHFTL(IWORD,5)) IWORD = ISHFTL (IWORD,20) GO TO 60 55 IWORD = IOR (NBV(2), ISHFTL(IWORD,5)) IWORD = IOR (NBV(3), ISHFTL(IWORD,5)) IWORD = ISHFTL (IWORD,15) GO TO 60 56 IWORD = IOR (NBV(2), ISHFTL(IWORD,5)) IWORD = IOR (NBV(3), ISHFTL(IWORD,5)) IWORD = IOR (NBV(4), ISHFTL(IWORD,5)) IWORD = ISHFTL (IWORD,10) GO TO 60 57 IWORD = IOR (NBV(2), ISHFTL(IWORD,5)) IWORD = IOR (NBV(3), ISHFTL(IWORD,5)) IWORD = IOR (NBV(4), ISHFTL(IWORD,5)) IWORD = IOR (NBV(5), ISHFTL(IWORD,5)) IWORD = ISHFTL (IWORD,5) GO TO 60 58 IWORD = IOR (NBV(2), ISHFTL(IWORD,5)) IWORD = IOR (NBV(3), ISHFTL(IWORD,5)) IWORD = IOR (NBV(4), ISHFTL(IWORD,5)) IWORD = IOR (NBV(5), ISHFTL(IWORD,5)) IWORD = IOR (NBV(6), ISHFTL(IWORD,5)) C-- Store composed word #if defined(CERNLIB_QDEVZE) 60 IF (LOGLVI.GE.6) WRITE (IQLOG,9860) IWORD,(NBV(J),J=1,NBUSE) 9860 FORMAT (' FZIASC- Composed word= ',Z8,6I3) GO TO 62 61 IF (LOGLVI.GE.6) WRITE (IQLOG,9861) IWORD 9861 FORMAT (' FZIASC- Integer word= ',I8) 62 CONTINUE #endif #if !defined(CERNLIB_QDEVZE) 60 CONTINUE 61 CONTINUE #endif IF (JCHSUM.NE.0) GO TO 82 ICHSUM(1,1) = ICHSUM(1,1) + JBYT (IWORD,17,16) ICHSUM(2,1) = ICHSUM(2,1) + JBYT (IWORD, 1,16) IF (IFLREP.NE.0) GO TO 63 IF (LBUFC.GE.LBUFE) GO TO 914 LQ(LBUFC) = IWORD LBUFC = LBUFC + 1 IF (ITYPE.GE.0) GO TO 31 ITYPE = JTYPE GO TO 31 C---- Repetition executed 63 N = IWORD + 1 LBUFN = LBUFC + N IF (LBUFN.GT.LBUFE) GO TO 915 IF (N.LE.0) GO TO 916 DO 64 L=LBUFC,LBUFN-1 64 LQ(L) = IWDREP LBUFC = LBUFN IFLREP = 0 GO TO 31 C---- Control symbols C-- = : repetition signalled 70 JTYPC = IQKRAK(JTKC) JTKC = JTKC + 1 71 IF (JTYPC-44) 912, 72, 74 72 IF (JCHSUM.EQ.1) GO TO 920 IWDREP = IWORD IFLREP = 7 ITYPE = 0 GO TO 31 C-- close sq bracket : stop running type 74 IF (JTYPC-54) 912, 75, 77 75 ITYPE = 0 GO TO 31 C-- open sq bracket : start running type 77 IF (JTYPC-58) 912, 78, 81 78 IF (ITYPE.LT.0) GO TO 917 ITYPE = -7 GO TO 31 C-- < : end of physical record 81 IF (JTYPC.NE.60) GO TO 912 IF (LBUFC.NE.LBUFE) GO TO 918 IF (JCHSUM.NE.0) GO TO 999 IF (IFLREP.NE.0) GO TO 920 ITYPE = 0 JCHSUM = 1 GO TO 31 C-- Check-sum reading 82 IF (IFLREP.NE.0) IWORD = IWDREP ICHSUM(JCHSUM,2) = IWORD JCHSUM = JCHSUM + 1 IF (JCHSUM.EQ.2) GO TO 31 IF (ICHSUM(1,1).NE.ICHSUM(1,2)) GO TO 919 IF (ICHSUM(2,1).NE.ICHSUM(2,2)) GO TO 919 #include "zebra/qtrace99.inc" IQUEST(92) = JFAST RETURN C------ Errors 101 IF (IQUEST(1).LT.0) GO TO 999 IF (IQUEST(1).EQ.7799) GO TO 910 C-- Read Error JRETCD = 7 JERROR = 309 NWERR = 1 IQUEST(14) = IQUEST(1) GO TO 999 C---- Record context errors C- JERROR = 310 Invalid character in column 1 910 JERROR = -1 C- JERROR = 311 Record shorter than expected 911 JERROR = JERROR - 1 C- JERROR = 312 Faulty type code 912 JERROR = JERROR - 1 C- JERROR = 313 Faulty numeric value, > 31 913 JERROR = JERROR - 1 C- JERROR = 314 Record longer than expected 914 JERROR = JERROR - 1 C- JERROR = 315 Repetition count overshoots record end 915 JERROR = JERROR - 1 C- JERROR = 316 Repetition count negative 916 JERROR = JERROR - 1 C- JERROR = 317 Double open square bracket 917 JERROR = JERROR - 1 C- JERROR = 318 Record shorter than expected 918 JERROR = JERROR - 1 C- JERROR = 319 Check-sum error 919 JERROR = JERROR - 1 C- JERROR = 320 Illegal combination =< or <= 920 JERROR = JERROR + 320 JRETCD = 5 NWERR = 0 IQUEST(1) = 7 GO TO 999 END #endif