MINICERN/packlib/zebra/tq/tzfree.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.2  1996/04/18 16:14:52  mclareni
   6 * Incorporate changes from J.Zoll for version 3.77
   7 *
   8 * Revision 1.1.1.1  1996/03/06 10:47:27  mclareni
   9 * Zebra
  10 *
  11 *
  12 #include "zebra/pilot.h"
  13       SUBROUTINE TZFREE
  14
  15 C--   Read 1 title bank in free field format for TZINIT
  16
  17 #include "zebra/zmach.inc"
  18 #include "zebra/zstate.inc"
  19 #include "zebra/zunit.inc"
  20 #include "zebra/mqsys.inc"
  21 #include "zebra/eqlqt.inc"
  22 #include "zebra/tzuc.inc"
  23 #include "zebra/tzc1.inc"
  24 C--------------    END CDE                             -----------------
  25       COMMON /SLATE/ NDSLAT,NESLAT,NFSLAT,NGSLAT,NUM(2),DUMMY(34)
  26       CHARACTER    COL(LGL)*1
  27       EQUIVALENCE (COL(1), LINE(1:1))
  28
  29       CHARACTER    CHTYP*(*), FAULT*20
  30       PARAMETER   (CHTYP = '#''":')
  31
  32
  33       IF (JCOLA.EQ.0)  JCOLA = 1
  34       IF (JCOLE.EQ.0)  JCOLE = LGL
  35       IF (NCHPW.EQ.0)  NCHPW = 4
  36       IPRHEA = IFLLOG
  37       NREADY = 7
  38       MULT   = 0
  39       LPUTX  = LPUTA
  40
  41 C--       Print delimitation, unless full line
  42
  43       IF (IFLPRI.EQ.0)             GO TO 21
  44       IF (JCOLE.EQ.LGL)  THEN
  45           IF (JCOLA.EQ.1)          GO TO 21
  46           WRITE (IQLOG,9016)  BLANK(1:JCOLA)
  47         ELSE
  48           NB = JCOLE-1 - JCOLA
  49           IF (NB.GE.3)  THEN
  50               WRITE (IQLOG,9016)  BLANK(1:JCOLA), BLANK(1:NB-2)
  51             ELSE
  52               WRITE (IQLOG,9017)  BLANK(1:JCOLA), BLANK(1:NB)
  53             ENDIF
  54         ENDIF
  55
  56  9016 FORMAT (5X,A,'<-',A,'->')
  57  9017 FORMAT (5X,A,'<',A,'>')
  58
  59 C----              Read line by line
  60
  61    21 CONTINUE
  62 #include "zebra/tzread1.inc"
  63
  64       IF (COL(1).EQ.'*')           RETURN
  65
  66       IF (IFLPRI.NE.0)  WRITE (IQLOG,9001) LINE(1:NCHORG)
  67  9001 FORMAT (6X,A)
  68
  69
  70 C------            Crack field by field
  71
  72       JSTATE = 0
  73       JTKEND = MIN (NCHORG,JCOLE)
  74       JTKE   = JCOLA - 1
  75    24 J  = ICNEXT (LINE,JTKE+1,JTKEND)
  76       IF (J.GT.JTKEND)  THEN
  77           IF (MULT.NE.0)           GO TO 82
  78           GO TO 21
  79         ENDIF
  80
  81       JTKA = J
  82       JTKE = NESLAT - 1
  83       NTK  = NDSLAT
  84
  85       JTYP = INDEX (CHTYP,COL(JTKA)) + 1
  86       GO TO (61, 31, 41, 41, 43), JTYP
  87 C-            1   2   3   4   5
  88 C-      numeric   #   '   "   :
  89
  90 C----              # item
  91
  92    31 IF (NTK.LT.2)                GO TO 81
  93       JIT = INDEX ('.ADNadnOo0Xx', COL(JTKA+1))
  94 C-                  123456789012
  95       IF (JIT.EQ.0)                GO TO 81
  96       IF (JIT.GE.8)                GO TO 61
  97       IF (JIT.GE.5)  JIT = JIT - 3
  98       IF (MULT.NE.0)               GO TO 82
  99
 100 C--       #. comment #
 101       IF (JIT.EQ.1)  THEN
 102           JTKE = ICFIND ('#', LINE,JTKA+2,JTKEND)
 103           GO TO 24
 104         ENDIF
 105
 106 C--       #AnCW  control item
 107       IF (JIT.EQ.2)  THEN
 108           CALL TZACW (LINE(JTKA+1:JTKE))
 109           IF (NCHPW.GE.0)          GO TO 24
 110           NCHPW = 4
 111           GO TO 81
 112         ENDIF
 113
 114 C--       #Double control item
 115       IF (JIT.EQ.3)  THEN
 116           IFLDBL = 1
 117           GO TO 24
 118         ENDIF
 119
 120 C--       #Normal control item
 121       IFLDBL = 0
 122       GO TO 24
 123
 124 C----              Handling Hollerith
 125
 126    41 JTKE = ICFIND (COL(JTKA), LINE,JTKA+1,JTKEND)
 127       IF (JTKE.GT.JTKEND)          GO TO 83
 128       NTK  = JTKE - JTKA
 129
 130    43 JTKA = JTKA + 1
 131       NTK  = NTK  - 1
 132
 133       NWDH = (NTK-1) / NCHPW + 1
 134       NWDS = NWDH + IFLHC + IFLHW
 135       NWDT = NWDS
 136       IF (MULT.NE.0)  NWDT = NWDT * MULT
 137       IF (LPUTX+NWDT.GT.LPUTE)     GO TO 84
 138
 139       JST = LPUTX
 140       IF (IFLHC.NE.0)  THEN
 141           LQ(JST) = NTK
 142           JST = JST + 1
 143         ENDIF
 144
 145       IF (IFLHW.NE.0)  THEN
 146           LQ(JST) = NWDH
 147           JST = JST + 1
 148         ENDIF
 149
 150       CALL UCTOH (LINE(JTKA:JTKE), LQ(JST),NCHPW, NTK)
 151
 152       JST   = LPUTX
 153       LPUTX = LPUTX + NWDT
 154       IF (MULT.EQ.0)               GO TO 24
 155
 156       MULT = MULT - 1
 157       CALL UCOCOP (LQ(JST),LQ(JST+NWDS),MULT,NWDS,0,NWDS)
 158       MULT = 0
 159       GO TO 24
 160
 161 C----              Handle numeric
 162
 163    61 CALL CKRACK (LINE,JTKA,JTKE,IFLDBL)
 164       IF (NFSLAT.LE.0)             GO TO 86
 165       IF (NGSLAT.NE.0)             GO TO 67
 166       NWDS = MAX (1, NFSLAT-2)
 167       NWDT = NWDS
 168       IF (MULT.NE.0)  NWDT = NWDT * MULT
 169       IF (LPUTX+NWDT.GT.LPUTE)     GO TO 84
 170
 171       JST   = LPUTX
 172       LPUTX = LPUTX + NWDT
 173       IF (MULT.NE.0)               GO TO 64
 174
 175       LQ(JST) = NUM(1)
 176       IF (NWDS.EQ.1)               GO TO 24
 177       LQ(JST+1) = NUM(2)
 178       GO TO 24
 179
 180    64 IF (NWDS.EQ.1)  THEN
 181           CALL VFILL (LQ(JST),MULT,NUM(1))
 182         ELSE
 183           CALL UCOCOP (NUM,LQ(JST),MULT,NWDS,0,NWDS)
 184         ENDIF
 185       MULT = 0
 186       GO TO 24
 187
 188 C--       handle repeat*
 189
 190    67 JE = NESLAT
 191       IF (COL(JE).NE.'*')          GO TO 86
 192       IF (NFSLAT.GE.3)             GO TO 81
 193       IF (MULT.NE.0)               GO TO 82
 194       IF (NUM(1).LE.1)             GO TO 85
 195       MULT = NUM(1)
 196       JTKE = JE
 197       GO TO 24
 198
 199 C----              EoF seen
 200
 201    78 NREADY = -7
 202       RETURN
 203
 204 C----              Error handling
 205
 206 C-        81 :  nothing special
 207 C-        82 :  pending repeat not allowed
 208 C-        83 :  missing terminator " or '
 209 C-        84 :  more data than expected
 210 C-        85 :  invalid repeat count
 211 C-        86 :  invalid numeric
 212
 213    86 JSTATE = 1
 214       JTKA = NESLAT
 215    85 JSTATE = JSTATE + 1
 216    84 JSTATE = JSTATE + 1
 217    83 JSTATE = JSTATE + 1
 218    82 JSTATE = JSTATE + 1
 219    81 JSTATE = JSTATE + 1
 220
 221       IF (IFLPRI.EQ.0)  THEN
 222           IF (IPRHEA.EQ.0)  THEN
 223               WRITE (IQLOG,9012) LHEAD(1:NHEAD)
 224               IPRHEA = 7
 225             ENDIF
 226           WRITE (IQLOG,9001) LINE(1:JTKEND)
 227         ENDIF
 228
 229       IF (JSTATE.EQ.1)  THEN
 230            FAULT = 'fault'
 231         ELSEIF (JSTATE.EQ.2)  THEN
 232            FAULT = 'pending repeat'
 233         ELSEIF (JSTATE.EQ.3)  THEN
 234            FAULT = 'missing terminator'
 235         ELSEIF (JSTATE.EQ.4)  THEN
 236            FAULT = 'too much data'
 237         ELSEIF (JSTATE.EQ.5)  THEN
 238            FAULT = 'invalid repeat count'
 239         ELSEIF (JSTATE.EQ.6)  THEN
 240            FAULT = 'invalid'
 241         ENDIF
 242
 243       WRITE (IQLOG,9091) BLANK(1:JTKA),FAULT
 244       NFAULT = NFAULT + 1
 245       MULT   = 0
 246       IF (JSTATE.NE.4)             GO TO 21
 247       NREADY = 0
 248       RETURN
 249
 250  9012 FORMAT (3X,' > ',A)
 251  9091 FORMAT ('  !!f',A,'^-> !!! ',A)
 252       END
 253 *      ==================================================
 254 #include "zebra/qcardl.inc"