MINICERN/packlib/zebra/mqs/mzioch.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.2  1996/04/18 16:13:03  mclareni
   6 * Incorporate changes from J.Zoll for version 3.77
   7 *
   8 * Revision 1.1.1.1  1996/03/06 10:47:21  mclareni
   9 * Zebra
  10 *
  11 *
  12 #include "zebra/pilot.h"
  13       SUBROUTINE MZIOCH (IODVEC,NWIOMP,CHFORM)
  14
  15 C-    Analyse I/O descriptor, user called, also from MZFORM / MZIOBK
  16 C-    convert the descriptor CHFORM into the I/O characteristic
  17 C-    stored into IODVEC of length NWIOMX
  18
  19 #include "zebra/zkrakc.inc"
  20 #include "zebra/zstate.inc"
  21 #include "zebra/zunit.inc"
  22 #include "zebra/quest.inc"
  23 #include "zebra/mzca.inc"
  24 #include "zebra/zbcd.inc"
  25 C--------------    END CDE                             --------------
  26       DIMENSION    IODVEC(99), NWIOMP(9)
  27       CHARACTER    CHFORM*(*)
  28
  29       EQUIVALENCE (NGR,IQUEST(1)), (NGRU,IQUEST(2))
  30
  31       DIMENSION    MU(99),             MCE(99)
  32       EQUIVALENCE (MU(1),IQHOLK(1)),  (MCE(1),IQCETK(1))
  33
  34       DIMENSION    NBITVA(4), NBITVB(4), NBITVC(7)
  35       DIMENSION    MXVALA(4), MXVALB(4), MXVALC(7)
  36
  37       DIMENSION    ITAB(48), INV(10)
  38
  39 #if defined(CERNLIB_QMVDS)
  40       SAVE         NBITVA, NBITVB, NBITVC
  41       SAVE         MXVALA, MXVALB, MXVALC
  42       SAVE         ITAB, INV
  43 #endif
  44 #if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
  45       DIMENSION    NAMESR(2)
  46       DATA  NAMESR / 4HMZIO, 4HCH   /
  47 #endif
  48 #if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
  49       DATA  NAMESR / 6HMZIOCH /
  50 #endif
  51 #if !defined(CERNLIB_QTRHOLL)
  52       CHARACTER    NAMESR*8
  53       PARAMETER   (NAMESR = 'MZIOCH  ')
  54 #endif
  55
  56 C-                 A   B   C   D   E   F   G   H   I   J   K   L   M
  57 C-                 N   O   P   Q   R   S   T   U   V   W   X   Y   Z
  58 C-                 0   1   2   3   4   5   6   7   8   9   +   -   *
  59 C-                 /   (   )   $   =   b   ,   .
  60       DATA ITAB /       47
  61      +,           -1, 12, -1, 15, -1, 14, -1, 16, 13, -1, -1, -1, -1
  62      +,           -1, -1, -1, -1, -1, 18, -1, -1, -1, -1, -1, -1, -1
  63      +,            0,  1,  2,  3,  4,  5,  6,  7,  8,  9, -1, 11, 10
  64      +,           19, -1, -1, -1, -1, -2, -2, -2 /
  65
  66       DATA INV  / 39, 38,  2,  9,  6,  4,  8, 24, 19, 40 /
  67 C-                 *   -   B   I   F   D   H   X   S   /
  68
  69       DATA  NBITVA / 32,    16,   10,   8 /
  70       DATA  NBITVB / 29,    14,    9,   7 /
  71       DATA  NBITVC / 26,    11,    6,   4, 2, 1, 1 /
  72       DATA  MXVALA /  0, 65536, 1024, 256 /
  73       DATA  MXVALB /  0, 16384,  512, 128 /
  74       DATA  MXVALC /  0,  2048,   64,  16, 4, 2, 2 /
  75
  76 #include "zebra/q_sbit1.inc"
  77 #include "zebra/q_sbyt.inc"
  78
  79 #include "zebra/qtrace.inc"
  80
  81       NWIOMX = NWIOMP(1)
  82       NCH    = LEN (CHFORM)
  83       IF (NCH.GE.121)              GO TO 90
  84       CALL UCTOH1 (CHFORM,IQHOLK,NCH)
  85
  86       CALL IZBCDT (NCH,ITAB)
  87       NCH = IQUEST(1)
  88       IF (IQUEST(2).NE.0)          GO TO 91
  89       IF (IQUEST(1).EQ.0)          GO TO 91
  90
  91 C--------          SCAN CHARACTER BY CHARACTER
  92
  93 C-       NUMERIC   0 ... 9  10 11  12 13 14 15 16 17 18 19
  94 C-           FOR   0 ... 9   *  -   B  I  F  D  H     S  /
  95
  96       JPOSR  = -1
  97       JPOSIN = -1
  98       IVAL = 0
  99       JCH  = 0
 100       JU   = 0
 101    21 NVAL = 0
 102    22 JCH  = JCH + 1
 103       NUM  = MCE(JCH)
 104       IF (NUM.GE.10)               GO TO 24
 105
 106 C--                NUMERIC
 107
 108       NVAL = 10*NVAL + NUM
 109       IF (JCH.LT.NCH)              GO TO 22
 110       GO TO 92
 111
 112 C--                COUNT =  * OR -
 113
 114    24 IF (NUM.GE.12)               GO TO 26
 115       IF (NVAL.NE.0)               GO TO 92
 116       IF (NUM.EQ.11)  THEN
 117           NVAL   = -1
 118           JPOSIN = JU
 119           IF (JPOSR.GE.0)          GO TO 93
 120         ENDIF
 121       IF (JCH.EQ.NCH)              GO TO 92
 122       JCH = JCH + 1
 123       NUM = MCE(JCH)
 124       IF (NUM.LT.12)               GO TO 92
 125       IF (NUM.GE.19)               GO TO 92
 126       GO TO 27
 127
 128 C--                TYPE LETTER
 129
 130    26 IF (NUM.EQ.19)               GO TO 29
 131       IF (NUM.EQ.18)               GO TO 92
 132       IF (NVAL.EQ.0)               GO TO 92
 133       IF (NUM.EQ.15)  THEN
 134           IF (NVAL.NE.2*(NVAL/2))    GO TO 92
 135         ENDIF
 136       IVAL = 7
 137    27 MU(JU+1) = NUM - 11
 138       MU(JU+2) = NVAL
 139       JU = JU + 2
 140       IF (JCH.EQ.NCH)              GO TO 31
 141       IF (JPOSIN.LT.0)             GO TO 21
 142       GO TO 94
 143
 144 C--                REPEAT MARK
 145
 146    29 IF (NVAL.NE.0)               GO TO 92
 147       IF (JPOSR.GE.0)              GO TO 95
 148       IF (JCH.EQ.NCH)              GO TO 92
 149       JPOSR = JU
 150       GO TO 21
 151
 152 C--------          NO TRAILING REGIONS
 153
 154    31 NU    = JU
 155       NSECA = NU/2
 156       JU    = 2
 157       IOWD  = 65
 158       NWIO  = 0
 159       JFL12 = 1
 160       IF (JPOSR.GE.0)  THEN
 161           IF (JPOSR+2.NE.NU)       GO TO 41
 162           IF (MU(NU-1).NE.7)       GO TO 41
 163 C-        continue if  'CT ... CT / *S'
 164         ELSE
 165           IF (MU(NU).EQ.0)  JFL12=2
 166         ENDIF
 167
 168 C--        FORMATS TO BE HANDLED IN CLASSES 1 AND 2 (OR 0)
 169 C-    JFL12 = 2 :  '... *T'
 170 C-            1 :  '... -T'
 171 C-                 '... NT'    AS  '... -T'
 172 C-                 '... / *S'  AS  '... -S'
 173 C-                 '/ NT'      AS  '-T'
 174
 175    32 NSECA = NSECA - 1
 176
 177 C----              CLASS 0 : '-T'   OR   '*T'
 178
 179       IQUEST(12) = MU(NU-1)
 180       IF   (NSECA.EQ.0)   THEN
 181           IF (JFL12.EQ.1)          GO TO 82
 182           IQUEST(12) = MSBIT1 (IQUEST(12),4)
 183           GO TO 82
 184         ENDIF
 185
 186 C----              CLASS 0 : 'CT -T'   OR   'CT *T'
 187
 188       IF (NSECA.GE.2)              GO TO 33
 189       IF (MU(2).GE.64)             GO TO 34
 190       IF (JFL12.EQ.2)  IQUEST(12)= MSBIT1(IQUEST(12),4)
 191       IQUEST(12) = MSBYT (MU(1),IQUEST(12),5,3)
 192       IQUEST(12) = MSBYT (MU(2),IQUEST(12),8,6)
 193       GO TO 82
 194
 195 C----              CLASS 1 : 'CT CT CT -T'
 196 C-                 CLASS 2 : 'CT CT CT *T'
 197
 198    33 IF (IVAL+NSECA.EQ.2)         GO TO 38
 199    34 IQUEST(12) = MSBYT (JFL12,IQUEST(12),14,2)
 200       IQUEST(12) = MSBYT (MU(1),IQUEST(12),5,3)
 201       IQUEST(13) = MU(2)
 202       JBTF  = 8
 203       IF (NSECA.GE.4)              GO TO 36
 204       IOWD  = 2177
 205       NWIO  = 1
 206       IF (NSECA.EQ.1)              GO TO 82
 207
 208       NGR = NSECA
 209       CALL MZIOCF (0,MXVALA)
 210       IF (NGR.NE.NGRU)             GO TO 36
 211       NBT   = NBITVA(NGRU)
 212       GO TO 71
 213
 214 C----              CLASS 1 : 'CT ... CT -T'
 215 C-                 CLASS 2 : 'CT ... CT *T'
 216
 217    36 IQUEST(12) = MSBIT1 (IQUEST(12),4)
 218       NGR = MIN (NSECA,3)
 219       CALL MZIOCF (0,MXVALB)
 220       NBT   = NBITVB(NGRU)
 221       GO TO 70
 222
 223 C----              CLASS 1 : '*T *T -T'
 224 C-                 CLASS 2 : '*T *T *T'
 225
 226    38 IQUEST(12) = 16*IQUEST(12)
 227       IQUEST(12) = MSBYT (MU(1),IQUEST(12), 8,3)
 228       IQUEST(12) = MSBYT (MU(3),IQUEST(12),11,3)
 229       IQUEST(12) = MSBYT (JFL12,IQUEST(12),14,2)
 230       GO TO 82
 231
 232 C--------          WITH TRAILING REGIONS
 233
 234    41 NSECL = JPOSR/2
 235       IF (NSECA.GE.3)              GO TO 44
 236
 237 C----              CLASS 3 : '/ *T'
 238
 239       IQUEST(12) = MU(NU-1)
 240       IQUEST(12) = MSBYT (3,IQUEST(12),14,2)
 241       IF (NSECA.EQ.2)              GO TO 42
 242       IF (MU(2).EQ.0)              GO TO 82
 243       GO TO 32
 244
 245 C----              CLASS 3 : 'CT / *T'   OR   '/ CT *T'
 246
 247    42 IF (MU(4).NE.0)              GO TO 44
 248       IF (MU(2).GE.64)             GO TO 44
 249       IQUEST(12) = MSBYT (MU(1),IQUEST(12),5,3)
 250       IQUEST(12) = MSBYT (MU(2),IQUEST(12),8,6)
 251       IF (NSECL.EQ.1)              GO TO 82
 252       IQUEST(12) = MSBIT1 (IQUEST(12),4)
 253       GO TO 82
 254
 255 C----              CLASS 4 :  'CT / CT CT CT'  OR  'CT CT / CT CT'
 256
 257    44 IF (NSECL.EQ.0)              GO TO 51
 258       IF (NSECL.GE.3)              GO TO 61
 259       IF (NSECA.GE.5)              GO TO 61
 260       IF (IVAL+NSECA.EQ.3)         GO TO 48
 261
 262       NGR = NSECA
 263       CALL MZIOCF (0,MXVALA)
 264       IF (NGR.NE.NGRU)             GO TO 61
 265
 266       IQUEST(12) = MU(1)
 267       IQUEST(13) = MU(2)
 268       IF (NSECL.EQ.2)  IQUEST(12)=IQUEST(12)+8
 269       IQUEST(12) = MSBIT1 (IQUEST(12),16)
 270
 271       JBTF  = 5
 272       NBT   = NBITVA(NGRU)
 273       IOWD  = 2177
 274       NWIO  = 1
 275       GO TO 71
 276
 277 C----              CLASS 4 :  '*T / *T *T'   OR   '*T *T / *T'
 278
 279    48 IQUEST(12) = 8*(2*MU(1)+NSECL-1)
 280       IQUEST(12) = MSBYT (MU(3),IQUEST(12), 8,3)
 281       IQUEST(12) = MSBYT (MU(5),IQUEST(12),11,3)
 282       IQUEST(12) = MSBIT1 (IQUEST(12),16)
 283       GO TO 82
 284
 285 C--------          NO LEADING REGIONS
 286
 287 C----              CLASS 5 : '/ CT CT CT CT'
 288
 289    51 IF (IVAL+NSECA.EQ.3)         GO TO 58
 290       IQUEST(12) = MU(1)
 291       IQUEST(13) = MU(2)
 292       IQUEST(12) = MSBYT (5,IQUEST(12),14,3)
 293       JBTF  = 5
 294       IF (NSECA.GE.5)              GO TO 55
 295
 296       NGR = NSECA
 297       CALL MZIOCF (0,MXVALA)
 298       IF (NGR.NE.NGRU)             GO TO 55
 299       NBT   = NBITVA(NGRU)
 300       IOWD  = 2177
 301       NWIO  = 1
 302       GO TO 71
 303
 304 C----              CLASS 5 : '/ CT ... CT'
 305
 306    55 IQUEST(12) = MSBIT1 (IQUEST(12),4)
 307       NGR = MIN (NSECA,4)
 308       CALL MZIOCF (0,MXVALB)
 309       NBT  = NBITVB(NGRU)
 310       GO TO 70
 311
 312 C----              CLASS 5 : '/ *T *T *T'
 313
 314    58 IQUEST(12) = 16*MU(1)
 315       IQUEST(12) = MSBYT (MU(3),IQUEST(12), 8,3)
 316       IQUEST(12) = MSBYT (MU(5),IQUEST(12),11,3)
 317       IQUEST(12) = MSBYT     (5,IQUEST(12),14,3)
 318       GO TO 82
 319
 320 C--------          CLASS 6 : 'CT ... CT / CT ... CT'
 321
 322    61 IQUEST(12) = NSECL
 323       IQUEST(13) = MU(2)
 324       IF (NSECL.GE.16)             GO TO 96
 325       IQUEST(12) = MSBYT (MU(1),IQUEST(12),5,3)
 326       IQUEST(12) = MSBYT (6,IQUEST(12),14,3)
 327
 328       JBTF  = 8
 329       NGR   = 3
 330       CALL MZIOCF (0,MXVALB)
 331       NBT   = NBITVB(NGRU)
 332
 333 C------            LONG PACKING
 334
 335 C--                PACK FIRST I/O WORD
 336
 337    70 IF (NGRU.EQ.1)               GO TO 73
 338
 339    71 JBTC = 1
 340       DO  72  JL=2,NGRU
 341       IQUEST(12) = MSBYT (MU(JU+1),IQUEST(12),JBTF,3)
 342       JBTF  = JBTF + 3
 343       JBTC  = JBTC + NBT
 344       IQUEST(13) = MSBYT (MU(JU+2),IQUEST(13),JBTC,NBT)
 345    72 JU = JU + 2
 346
 347       IF (NGRU.EQ.NSECA)           GO TO 82
 348    73 NSECD = NGRU
 349       JWIO  = 13
 350
 351 C----              PACK NEXT I/O WORD
 352
 353    74 JWIO = JWIO + 1
 354       IQUEST(JWIO) = MU(JU+1)
 355       JBT  = 4
 356       NGRU = 1
 357       NGR  = MIN (7,NSECA-NSECD)
 358       IF (NGR.EQ.1)                GO TO 77
 359
 360       CALL MZIOCF (JU,MXVALC)
 361       IF (NGRU.EQ.1)               GO TO 77
 362       JUST = JU
 363       DO  76  JL=2,NGRU
 364       JU  = JU + 2
 365       IQUEST(JWIO) = MSBYT (MU(JU+1),IQUEST(JWIO),JBT,3)
 366    76 JBT = JBT + 3
 367       JU  = JUST
 368
 369    77 IQUEST(JWIO-1) = MSBYT (NGRU,IQUEST(JWIO-1),30,3)
 370       NBT  = NBITVC(NGRU)
 371
 372       DO  79  JL=1,NGRU
 373       IQUEST(JWIO) = MSBYT (MU(JU+2),IQUEST(JWIO),JBT,NBT)
 374       JBT  = JBT + NBT
 375    79 JU  = JU  + 2
 376
 377       NSECD = NSECD + NGRU
 378       IF (NSECD.LT.NSECA)          GO TO 74
 379       NWIO = JWIO - 12
 380
 381       IF (NWIO.GE.NWIOMX)          GO TO 97
 382       IF (NWIO.GE.16)              GO TO 97
 383       IOWD  = 64*(32*NWIO+NWIO+1) + 1
 384
 385    82 IOWD = MSBYT (IQUEST(12),IOWD,17,16)
 386       IQUEST(12) = IOWD
 387       IQUEST(1)  = NWIO
 388
 389       CALL UCOPY (IQUEST(12),IODVEC,NWIO+1)
 390       IQCETK(121) = IQBLAN
 391 #if defined(CERNLIB_QDEBPRI)
 392       IF (NQLOGM.GE.1)  WRITE (IQLOG,9088) NWIO,CHFORM
 393  9088 FORMAT (' MZIOCH-',I5,' extra I/O words for Format ',A)
 394 #endif
 395 #include "zebra/qtrace99.inc"
 396       RETURN
 397
 398 C------            ERROR CONDITIONS
 399
 400 C--                CHARACTER STRING TOO LONG
 401    90 NQFATA = 2
 402       IQUEST(12) = NCH
 403       GO TO 99
 404
 405 C--                STRING INVALID
 406    91 NQCASE = 1
 407       NQFATA = 3
 408       IQUEST(12) = IQUEST(1)
 409       IQUEST(13) = IQUEST(2)
 410       IF (IQUEST(1).EQ.0)          GO TO 99
 411       GO TO 98
 412
 413 C--                I/O DESCRIPTOR TOO LONG
 414    97 NQCASE = 7
 415       IQUEST(12) = NWIOMX
 416       IQUEST(13) = NWIO + 1
 417       GO TO 98
 418
 419 C--                TOO MANY SECTORS
 420    96 NQCASE = 6
 421       IQUEST(12) = NSECA
 422       IQUEST(13) = NSECL
 423       GO TO 98
 424
 425 C--                / OCCURS TWICE
 426    95 NQCASE = 1
 427
 428 C--                -T NOT LAST SECTOR IN THE STRING
 429    94 NQCASE = NQCASE + 1
 430
 431 C--                -T NOT ALLOWED IN REPEAT
 432    93 NQCASE = NQCASE + 1
 433
 434 C--                BAD SYNTAX
 435    92 NQCASE = NQCASE + 2
 436       IQUEST(12) = JCH
 437       IQUEST(13) = 0
 438
 439    98 DO  88  JCH=1,NCH
 440       JCET = MCE(JCH)
 441       IF (JCET.LT.10) THEN
 442           MCE(JCH)=IQNUM(JCET+1)
 443         ELSE
 444           JCET = INV(JCET-9)
 445           MCE(JCH) = IQLETT(JCET)
 446         ENDIF
 447    88 CONTINUE
 448       CALL UTRANS (MCE,IQUEST(14),NCH,1,4)
 449       NQFATA = (NCH-1)/4 + 4
 450
 451    99 IQUEST(11) = IQCETK(121)
 452 #include "zebra/qtofatal.inc"
 453       END
 454 *      ==================================================
 455 #include "zebra/qcardl.inc"