* * $Id: fzoasc.F,v 1.3 1999/06/18 13:29:28 couet Exp $ * * $Log: fzoasc.F,v $ * Revision 1.3 1999/06/18 13:29:28 couet * - qcardl.inc was empty: It is now removed and not used. * Comment END CDE removed. * * Revision 1.2 1996/04/18 16:10:45 mclareni * Incorporate changes from J.Zoll for version 3.77 * * Revision 1.1.1.1 1996/03/06 10:47:14 mclareni * Zebra * * #include "zebra/pilot.h" #if defined(CERNLIB_FZALFA) SUBROUTINE FZOASC (LUNP,LBUFAP,LBUFEP,JFAST,LWORKA,LWORKE) C- Dump one physical record to cards in ALFA mode, C- service routine to FZOUT. C- The record is stored in words LQ(LBUFA) to LQ(LBUFE-1) C- It is a 'fast' record if JFAST .NE. 0 C- The working space available to FZOASC C- is LQ(LWORKA) to LQ(LWORKE) if LWORKE .NE. 0 C- or LQ(LWORKA) to LQ(LBUFC) if LWORKE .EQ. 0 #include "zebra/zbcd.inc" #include "zebra/zkrakc.inc" #include "zebra/zstate.inc" #include "zebra/zunit.inc" #include "zebra/mqsysh.inc" * DIMENSION LUNP(9), LBUFAP(9), LBUFEP(9) DIMENSION MTYPTR(7), ICHSUM(2) EQUIVALENCE (LUN ,IQUEST(90)) EQUIVALENCE (JPUT,IQUEST(91)), (IFLEND,IQUEST(92)) EQUIVALENCE (LUPKA,IQUEST(93)), (LUPKE, IQUEST(94)) #if defined(CERNLIB_QMVDS) SAVE MTYPTR #endif #if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M)) DIMENSION NAMESR(2) DATA NAMESR / 4HFZOA, 4HSC / #endif #if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M)) DATA NAMESR / 6HFZOASC / #endif #if !defined(CERNLIB_QTRHOLL) CHARACTER NAMESR*8 PARAMETER (NAMESR = 'FZOASC ') #endif DATA MTYPTR / 0, 0, 5, 10, 15, 20, 36 / #include "zebra/q_jbyt.inc" #include "zebra/qtraceq.inc" LUN = LUNP(1) LBUFA = LBUFAP(1) LBUFE = LBUFEP(1) LWKA = LWORKA LWKE = LWORKE LUPKA = LWKA LUPKE = LWKE NWWKU = LWKE - LWKA IF (LUPKE.EQ.0) THEN LUPKE = LBUFA NWWKU = 0 ENDIF IQCETK(1) = IQGREA IQCETK(2) = 58 IF (JFAST.EQ.0) THEN IQCETK(3) = 27 LBUFC = LBUFA + 4 ELSE IQCETK(3) = 26 LBUFC = LBUFA ENDIF JPUT = 3 IFLEND = 0 ITYPE = 0 ITYPC = -1 ICHSUM(1) = 0 ICHSUM(2) = 0 GO TO 40 C-------- Do next word 31 IWORD = LQ(LBUFC) 32 JTYPE = LQ(LUPK) IF (JTYPE.LT.0) GO TO 61 #if defined(CERNLIB_QDEVZE) IF (NQDEVZ.GE.9) THEN WRITE (IQLOG,9832) LBUFC+1-LBUFA,IWORD,(LQ(LUPK+J),J=0,9) DO 33 J=0,7 IF (IABS(LQ(LUPK+J)).GT.99) WRITE (IQLOG,9833) LQ(LUPK+J) 33 CONTINUE ENDIF #endif #if (defined(CERNLIB_QDEVZE))&&(defined(CERNLIB_B32)) 9832 FORMAT (' DEVZE FZOASC, do word',I4,Z9,' Upk=',8I3,' Next',2I5) 9833 FORMAT (22X,Z9) #endif #if (defined(CERNLIB_QDEVZE))&&(!defined(CERNLIB_B32)) 9832 FORMAT (' DEVZE FZOASC, do word',I4,Z17,' Upk=',8I3,' Next',2I5) 9833 FORMAT (22X,Z17) #endif JTYPS = LQ(LUPK+1) JTYPC = MTYPTR(JTYPE+1) + JTYPS C-- same type running IF (JTYPC.EQ.ITYPC) GO TO 36 C-- M-type 0 : integers 0 -> 9 IF (JTYPE.NE.0) GO TO 41 IF (ITYPC.EQ.24) GO TO 36 JBA = 0 C------ Store next word C-- terminate running type by ']', if any 34 IF (ITYPE.NE.0) THEN JPUT = JPUT + 1 IQCETK(JPUT) = 53 ITYPE = 0 ITYPC = -1 ENDIF C-- place type-code 35 JPUT = JPUT + 1 IQCETK(JPUT) = JTYPC IF (JBA.EQ.0) GO TO 38 C-- place significant bytes 36 DO 37 J=JBA,JBE JPUT = JPUT + 1 37 IQCETK(JPUT) = LQ(LUPK+J) 38 LUPK = LUPK + 8 C-- put blank separator for tests #if defined(CERNLIB_FQABLANK) JPUT = JPUT + 1 IQCETK(JPUT) = 44 #endif C-- Cumulate check-sum ICHSUM(1) = ICHSUM(1) + JBYT (IWORD,17,16) ICHSUM(2) = ICHSUM(2) + JBYT (IWORD, 1,16) C-- Write line if full IF (JPUT.GE.80) CALL FZOALN C-- End-of-record ? LBUFC = LBUFC + 1 IF (LBUFC.EQ.LBUFE) GO TO 81 C-- Unpack the next lot, if necc. IF (LUPK.LT.LUPKE) GO TO 31 IF (NWWKU.NE.0) THEN IF (NWWKU.GE.LBUFC-LBUFA) THEN LUPKE = LWKE ELSE LUPKA = LBUFA LUPKE = LBUFC ENDIF ELSE LUPKE = LBUFC ENDIF 40 LUPKEL = LUPKE CALL FZOAPK (LBUFC,LBUFE) LUPK = LUPKA GO TO 31 C------ Type analysis C- come to here if the type of the current word C- is not the one of the running set, and if C- the current M-type is not zero 41 NTYPE = LQ(LUPK+8) NTYPS = LQ(LUPK+9) NTYPC = -2 IF (NTYPE.GE.0) NTYPC = MTYPTR(NTYPE+1) + NTYPS C-- Check next word after current has again ITYPC C- and ITYPC covers JTYPC with 1 or 2 zero bytes IF (JTYPE.NE.ITYPE) GO TO 51 IF (NTYPC.NE.ITYPC) GO TO 51 N = JTYPC - ITYPC IF (N.LT.0) GO TO 51 IF (N.LT.3) GO TO 36 C---- The running set is definitely not continued 51 IF (JTYPE.LT.5) THEN JBA = 2 JBE = 7 - JTYPS ELSE JBA = 3 + JTYPS JBE = 7 ENDIF C---- Start of a new set if this and the next C- two numbers are of the same type IF (NTYPC.NE.JTYPC) GO TO 34 IF (LUPK+16.GE.LUPKE) GO TO 34 IF (LQ(LUPK+16).NE.JTYPE) GO TO 34 IF (LQ(LUPK+17).NE.JTYPS) GO TO 34 ITYPE = JTYPE ITYPC = JTYPC JPUT = JPUT + 1 IQCETK(JPUT) = 57 GO TO 35 C------ Repeat last number N+1 times 61 CONTINUE #if defined(CERNLIB_QDEVZE) IF (JTYPE.NE.-43) CALL ZFATAM ('FZOASC - trouble.') #endif JPUT = JPUT + 1 IQCETK(JPUT) = 43 LUPK = LUPK + 1 IWORD = LQ(LUPK) LBUFC = LBUFC + IWORD #if defined(CERNLIB_QDEVZE) LUPKEL = LUPKEL - 4 LUPK = LUPKEL LQ(LUPK) = IWORD #endif LUPKE = LUPKEL CALL FZOAPK (LUPK,LUPK+1) 68 LUPK = LUPKA ITYPE = 0 ITYPC = -1 GO TO 32 C-------- End of record 81 IF (IFLEND.NE.0) GO TO 84 JPUT = JPUT + 1 IQCETK(JPUT) = 59 LST = LUPKA LUPKA = LUPKA + 2 LUPKE = LUPKEL LQ(LST) = ICHSUM(1) LQ(LST+1) = ICHSUM(2) CALL FZOAPK (LST,LST+2) IFLEND = -1 LBUFC = LBUFE - 1 IWORD = ICHSUM(1) GO TO 68 84 IF (IFLEND.NE.-1) GO TO 86 IFLEND = -2 LBUFC = LBUFE - 1 IWORD = LQ(LST+1) GO TO 32 86 IFLEND = 7 CALL FZOALN #include "zebra/qtrace99.inc" RETURN END #endif