MINICERN/packlib/zebra/fq/fzoasc.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.2  1996/04/18 16:10:45  mclareni
   6 * Incorporate changes from J.Zoll for version 3.77
   7 *
   8 * Revision 1.1.1.1  1996/03/06 10:47:14  mclareni
   9 * Zebra
  10 *
  11 *
  12 #include "zebra/pilot.h"
  13 #if defined(CERNLIB_FZALFA)
  14       SUBROUTINE FZOASC (LUNP,LBUFAP,LBUFEP,JFAST,LWORKA,LWORKE)
  15
  16 C-    Dump one physical record to cards in ALFA mode,
  17 C-    service routine to FZOUT.
  18
  19 C-    The record is stored in words LQ(LBUFA) to LQ(LBUFE-1)
  20 C-    It is a 'fast' record if JFAST .NE. 0
  21 C-    The working space available to FZOASC
  22 C-       is  LQ(LWORKA) to LQ(LWORKE)  if LWORKE .NE. 0
  23 C-       or  LQ(LWORKA) to LQ(LBUFC)   if LWORKE .EQ. 0
  24
  25 #include "zebra/zbcd.inc"
  26 #include "zebra/zkrakc.inc"
  27 #include "zebra/zstate.inc"
  28 #include "zebra/zunit.inc"
  29 #include "zebra/mqsysh.inc"
  30 C--------------    End CDE                             --------------
  31       DIMENSION    LUNP(9), LBUFAP(9), LBUFEP(9)
  32
  33       DIMENSION MTYPTR(7), ICHSUM(2)
  34       EQUIVALENCE  (LUN ,IQUEST(90))
  35       EQUIVALENCE  (JPUT,IQUEST(91)), (IFLEND,IQUEST(92))
  36       EQUIVALENCE (LUPKA,IQUEST(93)), (LUPKE, IQUEST(94))
  37
  38 #if defined(CERNLIB_QMVDS)
  39       SAVE         MTYPTR
  40 #endif
  41 #if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
  42       DIMENSION    NAMESR(2)
  43       DATA  NAMESR / 4HFZOA, 4HSC   /
  44 #endif
  45 #if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
  46       DATA  NAMESR / 6HFZOASC  /
  47 #endif
  48 #if !defined(CERNLIB_QTRHOLL)
  49       CHARACTER    NAMESR*8
  50       PARAMETER   (NAMESR = 'FZOASC  ')
  51 #endif
  52       DATA  MTYPTR / 0, 0, 5, 10, 15, 20, 36 /
  53
  54 #include "zebra/q_jbyt.inc"
  55
  56 #include "zebra/qtraceq.inc"
  57
  58       LUN   = LUNP(1)
  59       LBUFA = LBUFAP(1)
  60       LBUFE = LBUFEP(1)
  61       LWKA  = LWORKA
  62       LWKE  = LWORKE
  63
  64       LUPKA = LWKA
  65       LUPKE = LWKE
  66       NWWKU = LWKE - LWKA
  67       IF (LUPKE.EQ.0)  THEN
  68           LUPKE = LBUFA
  69           NWWKU = 0
  70         ENDIF
  71
  72       IQCETK(1) = IQGREA
  73       IQCETK(2) = 58
  74       IF (JFAST.EQ.0)  THEN
  75           IQCETK(3) = 27
  76           LBUFC = LBUFA + 4
  77         ELSE
  78           IQCETK(3) = 26
  79           LBUFC = LBUFA
  80         ENDIF
  81       JPUT   = 3
  82       IFLEND = 0
  83       ITYPE  = 0
  84       ITYPC  = -1
  85
  86       ICHSUM(1) = 0
  87       ICHSUM(2) = 0
  88       GO TO 40
  89
  90 C--------          Do next word
  91
  92    31 IWORD = LQ(LBUFC)
  93    32 JTYPE = LQ(LUPK)
  94       IF (JTYPE.LT.0)              GO TO 61
  95 #if defined(CERNLIB_QDEVZE)
  96       IF (NQDEVZ.GE.9)  THEN
  97           WRITE (IQLOG,9832) LBUFC+1-LBUFA,IWORD,(LQ(LUPK+J),J=0,9)
  98           DO  33  J=0,7
  99           IF (IABS(LQ(LUPK+J)).GT.99)  WRITE (IQLOG,9833) LQ(LUPK+J)
 100    33     CONTINUE
 101         ENDIF
 102
 103 #endif
 104 #if (defined(CERNLIB_QDEVZE))&&(defined(CERNLIB_B32))
 105  9832 FORMAT (' DEVZE FZOASC, do word',I4,Z9,' Upk=',8I3,' Next',2I5)
 106  9833 FORMAT (22X,Z9)
 107 #endif
 108 #if (defined(CERNLIB_QDEVZE))&&(!defined(CERNLIB_B32))
 109  9832 FORMAT (' DEVZE FZOASC, do word',I4,Z17,' Upk=',8I3,' Next',2I5)
 110  9833 FORMAT (22X,Z17)
 111
 112 #endif
 113       JTYPS = LQ(LUPK+1)
 114       JTYPC = MTYPTR(JTYPE+1) + JTYPS
 115
 116 C--       same type running
 117       IF (JTYPC.EQ.ITYPC)          GO TO 36
 118
 119 C--                M-type 0 : integers 0 -> 9
 120
 121       IF (JTYPE.NE.0)              GO TO 41
 122       IF (ITYPC.EQ.24)             GO TO 36
 123       JBA = 0
 124
 125 C------            Store next word
 126
 127 C--       terminate running type by ']', if any
 128    34 IF (ITYPE.NE.0) THEN
 129           JPUT = JPUT + 1
 130           IQCETK(JPUT) = 53
 131           ITYPE = 0
 132           ITYPC = -1
 133         ENDIF
 134
 135 C--       place type-code
 136    35 JPUT = JPUT + 1
 137       IQCETK(JPUT) = JTYPC
 138       IF (JBA.EQ.0)                GO TO 38
 139
 140 C--       place significant bytes
 141    36 DO 37  J=JBA,JBE
 142       JPUT = JPUT + 1
 143    37 IQCETK(JPUT) = LQ(LUPK+J)
 144    38 LUPK = LUPK + 8
 145
 146 C--       put blank separator for tests
 147 #if defined(CERNLIB_FQABLANK)
 148       JPUT = JPUT + 1
 149       IQCETK(JPUT) = 44
 150 #endif
 151
 152 C--                Cumulate check-sum
 153
 154       ICHSUM(1) = ICHSUM(1) + JBYT (IWORD,17,16)
 155       ICHSUM(2) = ICHSUM(2) + JBYT (IWORD, 1,16)
 156
 157 C--                Write line if full
 158
 159       IF (JPUT.GE.80)   CALL FZOALN
 160
 161 C--                End-of-record ?
 162
 163       LBUFC = LBUFC + 1
 164       IF (LBUFC.EQ.LBUFE)          GO TO 81
 165
 166 C--                Unpack the next lot, if necc.
 167
 168       IF (LUPK.LT.LUPKE)           GO TO 31
 169
 170       IF (NWWKU.NE.0)  THEN
 171           IF (NWWKU.GE.LBUFC-LBUFA) THEN
 172               LUPKE = LWKE
 173             ELSE
 174               LUPKA = LBUFA
 175               LUPKE = LBUFC
 176             ENDIF
 177         ELSE
 178           LUPKE = LBUFC
 179         ENDIF
 180
 181    40 LUPKEL = LUPKE
 182       CALL FZOAPK (LBUFC,LBUFE)
 183       LUPK = LUPKA
 184       GO TO 31
 185
 186 C------            Type analysis
 187 C-                 come to here if the type of the current word
 188 C-                 is not the one of the running set, and if
 189 C-                 the current M-type is not zero
 190
 191
 192    41 NTYPE = LQ(LUPK+8)
 193       NTYPS = LQ(LUPK+9)
 194       NTYPC = -2
 195       IF (NTYPE.GE.0)  NTYPC = MTYPTR(NTYPE+1) + NTYPS
 196
 197 C--                Check next word after current has again ITYPC
 198 C-                 and ITYPC covers JTYPC with 1 or 2 zero bytes
 199
 200       IF (JTYPE.NE.ITYPE)          GO TO 51
 201       IF (NTYPC.NE.ITYPC)          GO TO 51
 202       N = JTYPC - ITYPC
 203       IF (N.LT.0)                  GO TO 51
 204       IF (N.LT.3)                  GO TO 36
 205
 206 C----              The running set is definitely not continued
 207
 208    51 IF (JTYPE.LT.5)  THEN
 209           JBA = 2
 210           JBE = 7 - JTYPS
 211         ELSE
 212           JBA = 3 + JTYPS
 213           JBE = 7
 214         ENDIF
 215
 216 C----              Start of a new set if this and the next
 217 C-                 two numbers are of the same type
 218
 219       IF (NTYPC.NE.JTYPC)          GO TO 34
 220       IF (LUPK+16.GE.LUPKE)        GO TO 34
 221       IF (LQ(LUPK+16).NE.JTYPE)    GO TO 34
 222       IF (LQ(LUPK+17).NE.JTYPS)    GO TO 34
 223
 224       ITYPE = JTYPE
 225       ITYPC = JTYPC
 226       JPUT  = JPUT + 1
 227       IQCETK(JPUT) = 57
 228       GO TO 35
 229
 230 C------            Repeat last number N+1 times
 231
 232    61 CONTINUE
 233 #if defined(CERNLIB_QDEVZE)
 234       IF (JTYPE.NE.-43)  CALL ZFATAM ('FZOASC - trouble.')
 235 #endif
 236       JPUT = JPUT + 1
 237       IQCETK(JPUT) = 43
 238
 239       LUPK  = LUPK + 1
 240       IWORD = LQ(LUPK)
 241       LBUFC = LBUFC + IWORD
 242 #if defined(CERNLIB_QDEVZE)
 243       LUPKEL = LUPKEL - 4
 244       LUPK   = LUPKEL
 245       LQ(LUPK) = IWORD
 246 #endif
 247
 248       LUPKE = LUPKEL
 249       CALL FZOAPK (LUPK,LUPK+1)
 250    68 LUPK  = LUPKA
 251       ITYPE = 0
 252       ITYPC = -1
 253       GO TO 32
 254
 255 C--------          End of record
 256
 257    81 IF (IFLEND.NE.0)             GO TO 84
 258       JPUT = JPUT + 1
 259       IQCETK(JPUT) = 59
 260       LST   = LUPKA
 261       LUPKA = LUPKA + 2
 262       LUPKE = LUPKEL
 263
 264       LQ(LST)   = ICHSUM(1)
 265       LQ(LST+1) = ICHSUM(2)
 266       CALL FZOAPK (LST,LST+2)
 267
 268       IFLEND = -1
 269       LBUFC  = LBUFE - 1
 270       IWORD  = ICHSUM(1)
 271       GO TO 68
 272
 273    84 IF (IFLEND.NE.-1)            GO TO 86
 274       IFLEND = -2
 275       LBUFC  = LBUFE - 1
 276       IWORD  = LQ(LST+1)
 277       GO TO 32
 278
 279    86 IFLEND = 7
 280       CALL FZOALN
 281
 282 #include "zebra/qtrace99.inc"
 283       RETURN
 284       END
 285 *      ==================================================
 286 #include "zebra/qcardl.inc"
 287 #endif