MINICERN/packlib/zebra/fq/fziasc.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.2  1996/04/18 16:10:24  mclareni
   6 * Incorporate changes from J.Zoll for version 3.77
   7 *
   8 * Revision 1.1.1.1  1996/03/06 10:47:12  mclareni
   9 * Zebra
  10 *
  11 *
  12 #include "zebra/pilot.h"
  13 #if defined(CERNLIB_FZALFA)
  14       SUBROUTINE FZIASC (NRSKPP)
  15
  16 C-    Read one physical record from cards in ALFA mode,
  17 C-    service routine to FZIN, called via FZIPHA
  18
  19 C-    Do not expand fast blocks if NRSKIP not zero
  20
  21 C-    The record is stored into words LQ(LBUFA) to LQ(LBUFE-1)
  22 C-    It is a 'fast' record if JFAST .NE. 0
  23
  24 #include "zebra/zbcd.inc"
  25 #include "zebra/zkrakc.inc"
  26 #include "zebra/zstate.inc"
  27 #include "zebra/zunit.inc"
  28 #include "zebra/mqsysh.inc"
  29 #include "zebra/fzci.inc"
  30 C--------------    End CDE                             --------------
  31       DIMENSION    NRSKPP(9)
  32       DIMENSION    INITV(6), NBV(6), ICHSUM(2,2)
  33
  34       EQUIVALENCE   (LUN,IQUEST(90)), (JSKIP,IQUEST(91))
  35       EQUIVALENCE (MRSTA,IQUEST(92)), (MREND,IQUEST(93))
  36       EQUIVALENCE  (JTKC,IQUEST(96)),  (JTKL,IQUEST(97))
  37      +,            (JTKE,IQUEST(98))
  38
  39 #if defined(CERNLIB_QMVDS)
  40       SAVE         INITV
  41 #endif
  42 #if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
  43       DIMENSION    NAMESR(2)
  44       DATA  NAMESR / 4HFZIA, 4HSC   /
  45 #endif
  46 #if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
  47       DATA  NAMESR / 6HFZIASC  /
  48 #endif
  49 #if !defined(CERNLIB_QTRHOLL)
  50       CHARACTER    NAMESR*8
  51       PARAMETER   (NAMESR = 'FZIASC  ')
  52 #endif
  53       DATA  INITV / 0, 1, 2, 3, 0, 134217727 /
  54 C-                                 = 7FFFFFF Hex
  55
  56 #include "zebra/q_or.inc"
  57 #include "zebra/q_shiftl.inc"
  58 #include "zebra/q_jbyt.inc"
  59
  60 #include "zebra/qtraceq.inc"
  61
  62       LUN    = LUNI
  63       LBUFA  = L4STAI
  64       LBUFE  = L4STAI + MAXREI
  65       NRSKIP = NRSKPP(1)
  66
  67       LBUFC  = LBUFA
  68       IFLREP = 0
  69       JCHSUM = 0
  70
  71       ICHSUM(1,1) = 0
  72       ICHSUM(2,1) = 0
  73
  74 C----              Read first line of next physical record
  75
  76       IQUEST(1) = 0
  77       JTKC  = 81
  78       JTKE  = JTKC
  79       MRSTA = 0
  80       MREND = 0
  81       JSKIP = 7
  82
  83       CALL FZIALN
  84       IF (IQUEST(1).NE.0)          GO TO 101
  85       IF (MRSTA.GT.1)  THEN
  86           JFAST = 0
  87           LBUFC = LBUFC+4
  88         ELSE
  89           JFAST = 7
  90           IF (NRSKIP.NE.0)         GO TO 999
  91           IF (NFASTI.EQ.0)         GO TO 999
  92         ENDIF
  93
  94       MRSTA = 0
  95       JSKIP = 0
  96       ITYPE = 0
  97
  98 C-------           Do next word
  99
 100    31 IF (JTKC.GE.JTKL)  THEN
 101           IF (MREND.NE.0)          GO TO 911
 102           CALL FZIALN
 103           IF (IQUEST(1).NE.0)      GO TO 101
 104         ENDIF
 105
 106 C--                Handle running type, check termination
 107
 108       IF (ITYPE.LE.0)              GO TO 34
 109       IF (IQKRAK(JTKC).LT.33)      GO TO 41
 110       GO TO 70
 111
 112 C--                Find type of next word
 113
 114    34 JTYPC = IQKRAK(JTKC)
 115       JTKC  = JTKC + 1
 116 #if defined(CERNLIB_QDEVZE)
 117       IF (LOGLVI.GE.6)  WRITE (IQLOG,9834) JTYPC,IQLETT(JTYPC)
 118  9834 FORMAT (' FZIASC-  Next control code/char.=',I4,1X,A1)
 119 #endif
 120       IF (JTYPC.GE.42)             GO TO 71
 121       IF   (JTYPC-26)        36, 912, 35
 122    35 IWORD = JTYPC - 27
 123       IF (IWORD.LT.10)             GO TO 61
 124       JTYPC = JTYPC - 11
 125    36 JTYPC = JTYPC - 1
 126       JTYPE = JTYPC / 5
 127       JTYPS = JTYPC - 5*JTYPE
 128       JTYPE = JTYPE + 1
 129
 130       NBUSE = 6 - JTYPS
 131       IF (JTYPE.GE.5)  NBUSE=NBUSE-1
 132
 133       INIT = ISHFTL (INITV(JTYPE), 5)
 134
 135 C----              Compose next word
 136
 137 C--                copy bytes and check validity
 138
 139    41 DO 42  J=1,NBUSE
 140       NBV(J) = IQKRAK(JTKC) - 1
 141       IF (NBV(J).GE.32)            GO TO 913
 142    42 JTKC = JTKC + 1
 143
 144       IWORD = IOR (NBV(1),INIT)
 145
 146       IF (JTYPE.LT.5)              GO TO 51
 147
 148 C--                Compose NBUSE 5-bit bytes for JTYPE=5,6
 149
 150       GO TO ( 60, 44, 45, 46, 47, 48), NBUSE
 151
 152    44 IWORD = IOR (NBV(2), ISHFTL(IWORD,5))
 153       GO TO 60
 154
 155    45 IWORD = IOR (NBV(2), ISHFTL(IWORD,5))
 156       IWORD = IOR (NBV(3), ISHFTL(IWORD,5))
 157       GO TO 60
 158
 159    46 IWORD = IOR (NBV(2), ISHFTL(IWORD,5))
 160       IWORD = IOR (NBV(3), ISHFTL(IWORD,5))
 161       IWORD = IOR (NBV(4), ISHFTL(IWORD,5))
 162       GO TO 60
 163
 164    47 IWORD = IOR (NBV(2), ISHFTL(IWORD,5))
 165       IWORD = IOR (NBV(3), ISHFTL(IWORD,5))
 166       IWORD = IOR (NBV(4), ISHFTL(IWORD,5))
 167       IWORD = IOR (NBV(5), ISHFTL(IWORD,5))
 168       GO TO 60
 169
 170    48 IWORD = IOR (NBV(2), ISHFTL(IWORD,5))
 171       IWORD = IOR (NBV(3), ISHFTL(IWORD,5))
 172       IWORD = IOR (NBV(4), ISHFTL(IWORD,5))
 173       IWORD = IOR (NBV(5), ISHFTL(IWORD,5))
 174       IWORD = IOR (NBV(6), ISHFTL(IWORD,5))
 175       GO TO 60
 176
 177 C--                Compose NBUSE 5-bit bytes for JTYPE=1,2,3,4
 178
 179    51 GO TO ( 60, 54, 55, 56, 57, 58), NBUSE
 180
 181    54 IWORD = IOR (NBV(2), ISHFTL(IWORD,5))
 182       IWORD = ISHFTL (IWORD,20)
 183       GO TO 60
 184
 185    55 IWORD = IOR (NBV(2), ISHFTL(IWORD,5))
 186       IWORD = IOR (NBV(3), ISHFTL(IWORD,5))
 187       IWORD = ISHFTL (IWORD,15)
 188       GO TO 60
 189
 190    56 IWORD = IOR (NBV(2), ISHFTL(IWORD,5))
 191       IWORD = IOR (NBV(3), ISHFTL(IWORD,5))
 192       IWORD = IOR (NBV(4), ISHFTL(IWORD,5))
 193       IWORD = ISHFTL (IWORD,10)
 194       GO TO 60
 195
 196    57 IWORD = IOR (NBV(2), ISHFTL(IWORD,5))
 197       IWORD = IOR (NBV(3), ISHFTL(IWORD,5))
 198       IWORD = IOR (NBV(4), ISHFTL(IWORD,5))
 199       IWORD = IOR (NBV(5), ISHFTL(IWORD,5))
 200       IWORD = ISHFTL (IWORD,5)
 201       GO TO 60
 202
 203    58 IWORD = IOR (NBV(2), ISHFTL(IWORD,5))
 204       IWORD = IOR (NBV(3), ISHFTL(IWORD,5))
 205       IWORD = IOR (NBV(4), ISHFTL(IWORD,5))
 206       IWORD = IOR (NBV(5), ISHFTL(IWORD,5))
 207       IWORD = IOR (NBV(6), ISHFTL(IWORD,5))
 208
 209 C--                Store composed word
 210
 211 #if defined(CERNLIB_QDEVZE)
 212    60 IF (LOGLVI.GE.6)  WRITE (IQLOG,9860) IWORD,(NBV(J),J=1,NBUSE)
 213  9860 FORMAT (' FZIASC-  Composed word= ',Z8,6I3)
 214       GO TO 62
 215    61 IF (LOGLVI.GE.6)  WRITE (IQLOG,9861) IWORD
 216  9861 FORMAT (' FZIASC-   Integer word= ',I8)
 217    62 CONTINUE
 218 #endif
 219 #if !defined(CERNLIB_QDEVZE)
 220    60 CONTINUE
 221    61 CONTINUE
 222 #endif
 223       IF (JCHSUM.NE.0)             GO TO 82
 224
 225       ICHSUM(1,1) = ICHSUM(1,1) + JBYT (IWORD,17,16)
 226       ICHSUM(2,1) = ICHSUM(2,1) + JBYT (IWORD, 1,16)
 227
 228       IF (IFLREP.NE.0)             GO TO 63
 229       IF (LBUFC.GE.LBUFE)          GO TO 914
 230       LQ(LBUFC) = IWORD
 231       LBUFC = LBUFC + 1
 232       IF (ITYPE.GE.0)              GO TO 31
 233       ITYPE = JTYPE
 234       GO TO 31
 235
 236 C----              Repetition executed
 237
 238    63 N     = IWORD + 1
 239       LBUFN = LBUFC + N
 240       IF (LBUFN.GT.LBUFE)          GO TO 915
 241       IF (N.LE.0)                  GO TO 916
 242
 243       DO 64  L=LBUFC,LBUFN-1
 244    64 LQ(L) = IWDREP
 245       LBUFC = LBUFN
 246
 247       IFLREP = 0
 248       GO TO 31
 249
 250 C----              Control symbols
 251
 252 C--                = : repetition signalled
 253
 254    70 JTYPC = IQKRAK(JTKC)
 255       JTKC  = JTKC + 1
 256    71 IF   (JTYPC-44)        912, 72, 74
 257    72 IF (JCHSUM.EQ.1)             GO TO 920
 258       IWDREP = IWORD
 259       IFLREP = 7
 260       ITYPE  = 0
 261       GO TO 31
 262
 263 C--                close sq bracket : stop running type
 264
 265    74 IF   (JTYPC-54)        912, 75, 77
 266    75 ITYPE = 0
 267       GO TO 31
 268
 269 C--                open sq bracket : start running type
 270
 271    77 IF   (JTYPC-58)        912, 78, 81
 272    78 IF (ITYPE.LT.0)              GO TO 917
 273       ITYPE = -7
 274       GO TO 31
 275
 276 C--                < : end of physical record
 277
 278    81 IF (JTYPC.NE.60)             GO TO 912
 279       IF (LBUFC.NE.LBUFE)          GO TO 918
 280       IF (JCHSUM.NE.0)             GO TO 999
 281       IF (IFLREP.NE.0)             GO TO 920
 282       ITYPE  = 0
 283       JCHSUM = 1
 284       GO TO 31
 285
 286 C--                Check-sum reading
 287
 288    82 IF (IFLREP.NE.0)  IWORD = IWDREP
 289       ICHSUM(JCHSUM,2) = IWORD
 290
 291       JCHSUM = JCHSUM + 1
 292       IF (JCHSUM.EQ.2)             GO TO 31
 293
 294       IF (ICHSUM(1,1).NE.ICHSUM(1,2))    GO TO 919
 295       IF (ICHSUM(2,1).NE.ICHSUM(2,2))    GO TO 919
 296
 297 #include "zebra/qtrace99.inc"
 298       IQUEST(92) = JFAST
 299       RETURN
 300
 301 C------            Errors
 302
 303   101 IF (IQUEST(1).LT.0)          GO TO 999
 304       IF (IQUEST(1).EQ.7799)       GO TO 910
 305
 306 C--                Read Error
 307
 308       JRETCD = 7
 309       JERROR = 309
 310       NWERR  = 1
 311       IQUEST(14) = IQUEST(1)
 312       GO TO 999
 313
 314 C----              Record context errors
 315
 316 C-    JERROR = 310  Invalid character in column 1
 317   910 JERROR = -1
 318
 319 C-    JERROR = 311  Record shorter than expected
 320   911 JERROR = JERROR - 1
 321
 322 C-    JERROR = 312  Faulty type code
 323   912 JERROR = JERROR - 1
 324
 325 C-    JERROR = 313  Faulty numeric value, > 31
 326   913 JERROR = JERROR - 1
 327
 328 C-    JERROR = 314  Record longer than expected
 329   914 JERROR = JERROR - 1
 330
 331 C-    JERROR = 315  Repetition count overshoots record end
 332   915 JERROR = JERROR - 1
 333
 334 C-    JERROR = 316  Repetition count negative
 335   916 JERROR = JERROR - 1
 336
 337 C-    JERROR = 317  Double open square bracket
 338   917 JERROR = JERROR - 1
 339
 340 C-    JERROR = 318  Record shorter than expected
 341   918 JERROR = JERROR - 1
 342
 343 C-    JERROR = 319  Check-sum error
 344   919 JERROR = JERROR - 1
 345
 346 C-    JERROR = 320  Illegal combination  =<  or  <=
 347   920 JERROR = JERROR + 320
 348       JRETCD = 5
 349       NWERR  = 0
 350       IQUEST(1) = 7
 351       GO TO 999
 352       END
 353 *      ==================================================
 354 #include "zebra/qcardl.inc"
 355 #endif