MINICERN/packlib/zebra/mqs/mziocr.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.2  1996/04/18 16:13:05  mclareni
   6 * Incorporate changes from J.Zoll for version 3.77
   7 *
   8 * Revision 1.1.1.1  1996/03/06 10:47:22  mclareni
   9 * Zebra
  10 *
  11 *
  12 #include "zebra/pilot.h"
  13       SUBROUTINE MZIOCR (IOW)
  14
  15 C-    Crack I/O characteristic ready for use, system called
  16
  17 #include "zebra/quest.inc"
  18 #include "zebra/mzioc.inc"
  19 C--------------    END CDE                             --------------
  20       EQUIVALENCE (JIO,IQUEST(1))
  21       DIMENSION    IOW(9)
  22       DIMENSION    NBITVA(4), NBITVB(4), NBITVC(7)
  23 #if defined(CERNLIB_QMVDS)
  24       SAVE         NBITVA, NBITVB, NBITVC
  25 #endif
  26       DATA  NBITVA / 32,    16,   10,   8 /
  27       DATA  NBITVB / 29,    14,    9,   7 /
  28       DATA  NBITVC / 26,    11,    6,   4, 2, 1, 1 /
  29
  30 #include "zebra/q_jbit.inc"
  31 #include "zebra/q_jbyt.inc"
  32
  33
  34       NWFODN = 0
  35       JFOCUR = 0
  36
  37       JTYPR  = IOW(1)
  38       IOW1   = JBYT (JTYPR,17,16)
  39
  40 C--                IMMEDIATE CHARACTERISTIC
  41
  42       IF (IOW1.NE.0)               GO TO 21
  43       IF (JTYPR.GE.8)              GO TO 21
  44       MFO(1) = JTYPR
  45       MFO(2) = -1
  46       JFOEND = 2
  47       JFOREP = 2
  48       RETURN
  49
  50 C----              GENERAL
  51
  52    21 JFOEND = 0
  53       JFOREP = 0
  54       JIO    = 1
  55       JTYPR  = JBYT (IOW1,1,3)
  56       JFLAG  = JBIT (IOW1,4)
  57       JCLASS = JBYT (IOW1,14,3)
  58       JFL12  = 0
  59
  60       GO TO ( 101, 201, 301, 401, 501, 601, 991), JCLASS
  61
  62 C--                CLASS 0 : 'CT -T'
  63
  64       JFL12 = JFLAG + 1
  65       JTYP  = JBYT (IOW1,5,3)
  66       IF (JTYP.NE.0)  THEN
  67           MFO(1) = JTYP
  68           MFO(2) = JBYT (IOW1,8,6)
  69           JFOEND = 2
  70         ENDIF
  71
  72    24 IF (JTYPR.EQ.7)      GO TO 28
  73       MFO(JFOEND+1) = JTYPR
  74       MFO(JFOEND+2) = JFL12 - 2
  75       JFOEND = JFOEND + 2
  76       JFOREP = JFOEND
  77       RETURN
  78
  79    28 JFOREP = JFOEND
  80       MFO(JFOEND+1) = 7
  81       MFO(JFOEND+2) = 0
  82       JFOEND = JFOEND + 2
  83       RETURN
  84
  85 C--                CLASS 1 OR 2 : 'CT ... CT -T'  OR  'CT ... CT *CT'
  86
  87   101 CONTINUE
  88   201 JFL12 = JCLASS
  89       IF (JTYPR.NE.0)              GO TO 821
  90       JTYPR = JBYT (IOW1,5,3)
  91       JBT   = 8
  92       GO TO 831
  93
  94 C--                CLASS 3 : 'CT / *T'  OR  '/ CT *T'
  95
  96   301 JTYP = JBYT (IOW1,5,3)
  97       IF (JTYP.NE.0)  THEN
  98           MFO(1) = JTYP
  99           MFO(2) = JBYT (IOW1,8,6)
 100           JFOEND = 2
 101           IF (JFLAG.EQ.0)  JFOREP = 2
 102         ENDIF
 103
 104       MFO(JFOEND+1) = JTYPR
 105       MFO(JFOEND+2) = 0
 106       JFOEND = JFOEND + 2
 107       RETURN
 108
 109 C--                CLASS 4 :  'CT / CT CT CT' OR 'CT CT / CT CT'
 110
 111   401 JFOREP = 2*(JFLAG+1)
 112       JFLAG  = 0
 113
 114 C--                CLASS 5 : '/ CT ... CT'
 115
 116   501 IF (JTYPR.EQ.0)              GO TO 830
 117       MFO(1) = JTYPR
 118       JFOEND = 2
 119       GO TO 821
 120
 121 C--                CLASS 6 : 'CT ... CT / CT ... CT'
 122
 123   601 JFOREP = 2*JBYT(IOW1,1,4)
 124       JFLAG  = 1
 125
 126 C----              COMMON UNPACKING FOR CLASSES 1, 2, 4, 5, 6
 127
 128   821 JIO = 2
 129       DO  822  JBT=5,11,3
 130       JTYP = JBYT (IOW1,JBT,3)
 131       IF (JTYP.EQ.0)               GO TO 823
 132       MFO(JFOEND+1) = JTYP
 133   822 JFOEND = JFOEND + 2
 134   823 NGRU   = JFOEND/2
 135
 136 C--                UNPACK I/O WORD 2
 137
 138       IF (JFLAG.EQ.0)  THEN
 139           NBT = NBITVA(NGRU)
 140         ELSE
 141           NBT = NBITVB(NGRU)
 142         ENDIF
 143
 144       JFOEND = 0
 145       JBT    = 1
 146       IOWN   = IOW(2)
 147       DO  824  JL=1,NGRU
 148       MFO(JFOEND+2) = JBYT(IOWN,JBT,NBT)
 149       JFOEND = JFOEND + 2
 150   824 JBT    = JBT + NBT
 151       IF (JFLAG.EQ.0)              GO TO 839
 152
 153 C--                UNPACK I/O WORDS 3, 4, ...
 154
 155   825 NGRU = JBYT(IOWN,30,3)
 156       IF (NGRU.EQ.0)               GO TO 839
 157       JIO  = JIO + 1
 158       IF (JIO.EQ.17)               GO TO 991
 159       IOWN = IOW(JIO)
 160       JBTT = 1
 161       JBTC = 3*NGRU + 1
 162       NBT  = NBITVC(NGRU)
 163
 164       DO  826  JL=1,NGRU
 165       MFO(JFOEND+1) = JBYT (IOWN,JBTT,3)
 166       MFO(JFOEND+2) = JBYT (IOWN,JBTC,NBT)
 167       JBTT   = JBTT + 3
 168       JBTC   = JBTC + NBT
 169   826 JFOEND = JFOEND + 2
 170       GO TO 825
 171
 172 C----              SUB-CLASSES ZERO
 173
 174   830 JBT = 5
 175   831 DO  834  JL=JBT,11,3
 176       JTYP = JBYT (IOW1,JL,3)
 177       IF (JTYP.EQ.0)               GO TO 839
 178       MFO(JFOEND+1) = JTYP
 179       MFO(JFOEND+2) = 0
 180   834 JFOEND = JFOEND + 2
 181
 182   839 IF (JFL12.NE.0)              GO TO 24
 183       RETURN
 184
 185 C-------           TROUBLE
 186
 187   991 IQUEST(1) = -1
 188       MFO(1) = 0
 189       MFO(2) = -1
 190       JFOEND = 2
 191       RETURN
 192       END
 193 *      ==================================================
 194 #include "zebra/qcardl.inc"