MINICERN/packlib/zebra/qutil/zkrakn.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/03/06 10:47:15  mclareni
   6 * Zebra
   7 *
   8 *
   9 #include "zebra/pilot.h"
  10       SUBROUTINE ZKRAKN (MFLAGP,JLP,JRP,VALP)
  11
  12 #include "zebra/zbcd.inc"
  13 #include "zebra/zkrakc.inc"
  14 #include "zebra/zkrakqu.inc"
  15 C--------------    END CDE                             --------------
  16
  17       COMMON /SLATE/ NDIG, JNEXT, DUMMY(38)
  18
  19       DIMENSION    MFLAGP(9), JLP(9), JRP(9), VALP(9)
  20       INTEGER      IVAL
  21       EQUIVALENCE (VAL,IVAL)
  22
  23
  24 #include "zebra/q_jbit.inc"
  25
  26
  27       MFLAG  = MFLAGP(1)
  28       JLRAN  = JLP(1)
  29       JRRAN  = JRP(1)
  30       MODE   = 0
  31       NWORDS = 0
  32       MFMT   = 0
  33       MULT   = JBIT(MFLAG,10) - 1
  34       IFLBLT = JBIT(MFLAG,6)
  35    12 NSEP   = 0
  36       JR     = JRRAN
  37       JTERM  = JRRAN + 1
  38       JNXGO  = JTERM
  39
  40 C-    IZBCD VAL.             1 27 36 37 38 39 40 41 42 43 44 45 46 47
  41 C-    CHARACTER              A  0  9  +  -  *  /  (  )  $  = BL  ,  .
  42 C-    BIT J IN MFLAG IF SEPARATOR LEGAL,   J=  1  2  3  4  5  6  7
  43 C-    J=10   MULTIPLIER LEGAL
  44
  45 C--                IGNORE LEADING BLANKS
  46
  47       JDO = JLRAN - 1
  48    13 JDO = JDO + 1
  49       IF (JDO.GT.JRRAN)            GO TO 93
  50       IFIRST = IQCETK(JDO)
  51       IF (IFIRST.EQ.45)            GO TO 13
  52
  53       IF (IFIRST.LT.27)            GO TO 91
  54       IF (IFIRST.LT.39)            GO TO 14
  55       IF (IFIRST.NE.47)            GO TO 92
  56
  57 C--                FIND BLANK TERMINATOR, IF SELECTED
  58
  59    14 IF (IFLBLT.EQ.0)             GO TO 17
  60       JTERM = JDO
  61    15 JTERM = JTERM + 1
  62       IF (JTERM.GT.JRRAN)          GO TO 16
  63       IF (IQCETK(JTERM).NE.45)     GO TO 15
  64    16 JR    = JTERM - 1
  65
  66 C--                STEP OVER SIGN-BIT
  67
  68    17 IF (IFIRST.EQ.37)            GO TO 18
  69       IF (IFIRST.NE.38)            GO TO 21
  70    18 JDO = JDO +1
  71       IF (JDO.EQ.JTERM)            GO TO 94
  72
  73 C--                READ INITIAL INTEGER
  74
  75    21 NDALL = 0
  76       IVAL  = 0
  77       JDO   = JDO - 1
  78    22 JDO   = JDO + 1
  79       IF (JDO.EQ.JTERM)            GO TO 28
  80       J = IQCETK(JDO) - 27
  81       IF (J.LT.0)                  GO TO 24
  82       IF (J.EQ.18)                 GO TO 22
  83       IF (J.GE.10)                 GO TO 24
  84       IVAL  = IVAL*10 + J
  85       NDALL = NDALL + 1
  86       GO TO 22
  87
  88    24 JEXP = 0
  89       JEXF = 0
  90       FRAC = 0.
  91       NSEP = IQCETK(JDO)
  92       IF   (NSEP-39)         41, 81, 26
  93    26 IF (NSEP.EQ.47)              GO TO 31
  94
  95    28 IF (IFIRST.EQ.38)  IVAL=-IVAL
  96       MFMT = 1
  97       GO TO 71
  98
  99 C--                READ FRACTION
 100
 101    31 JEXW = 0
 102    32 JDO  = JDO + 1
 103       IF (JDO.EQ.JTERM)            GO TO 50
 104
 105       NSEP = IQCETK(JDO)
 106       IF (NSEP-27)           41, 33, 34
 107    33 NDALL = NDALL + 1
 108       JEXW  = JEXW  + 1
 109       GO TO 32
 110
 111    34 IF (NSEP.GE.37)              GO TO 38
 112    35 IF (JEXW.EQ.0)               GO TO 36
 113       JEXW  = JEXW  - 1
 114       JEXF  = JEXF  - 1
 115       FRAC  = FRAC * 10.
 116       GO TO 35
 117
 118    36 NDALL = NDALL + 1
 119       JEXF  = JEXF  - 1
 120       FRAC  = FRAC*10. + REAL(NSEP-27)
 121       GO TO 32
 122
 123    38 IF (NSEP.EQ.45)              GO TO 32
 124       IF (NSEP-39)           44, 94, 51
 125
 126 C--                READ EXPONENT
 127
 128    41 IF (NSEP.NE.5)               GO TO 44
 129    42 JDO = JDO + 1
 130       IF (JDO.EQ.JTERM)            GO TO 50
 131       NSEP = IQCETK(JDO)
 132       IF (NSEP.EQ.45)              GO TO 42
 133       IF (NSEP-39)           44, 94, 51
 134
 135    44 IF (NSEP.LT.27)              GO TO 94
 136       IF (NSEP.LT.37)              GO TO 46
 137       JDO = JDO + 1
 138       IF (JDO.EQ.JTERM)            GO TO 94
 139
 140    46 JEXP = IUFORW (IQHOLK,JDO,JR)
 141       IF (JEXP.EQ.0)               GO TO 47
 142       IF (NSEP.EQ.38)  JEXP=-JEXP
 143       JEXF = JEXF + JEXP
 144    47 JDO  = JNEXT
 145       IF (JDO.EQ.JTERM)            GO TO 50
 146       NSEP = IQCETK(JDO)
 147       IF (NSEP.GE.40)              GO TO 51
 148       GO TO 94
 149
 150 C--                SET FLOATING RESULT
 151
 152    50 NSEP = 0
 153    51 VAL  = REAL (IVAL)
 154       IF (VAL.EQ.0.)               GO TO 61
 155       IF   (JEXP)            58, 61, 52
 156    52 IF (JEXP.GE.9)               GO TO 58
 157       DO 54  J=1,JEXP
 158    54 VAL = VAL * 10.
 159       GO TO 61
 160
 161    58 VAL = VAL * 10.**JEXP
 162
 163 C--                SET FLOATING RESULT, FRACTIONAL PART
 164
 165    61 IF (FRAC.EQ.0.)              GO TO 66
 166       IF   (JEXF)            64, 65, 62
 167    62 IF (JEXF.GE.9)               GO TO 64
 168       DO 63  J=1,JEXF
 169    63 FRAC = FRAC * 10.
 170       GO TO 65
 171
 172    64 FRAC = FRAC * 10.**JEXF
 173
 174    65 VAL = VAL + FRAC
 175    66 IF (IFIRST.NE.38)            GO TO 71
 176       VAL = -VAL
 177
 178 C--                STORE RESULT
 179
 180    71 IF (NDALL.EQ.0)              GO TO 94
 181       IF (NSEP.EQ.0)               GO TO 72
 182       NSEP = MIN  (NSEP,47)
 183       IF (JBIT(MFLAG,NSEP-39).EQ.0)  GO TO 94
 184       IF (NSEP.EQ.43)              GO TO 72
 185       JDO    = JDO + 1
 186
 187    72 JNXGO  = JDO
 188    73 IF (JNXGO.GT.JRRAN)          GO TO 75
 189       IF (IQCETK(JNXGO).NE.45)     GO TO 75
 190       JNXGO  = JNXGO + 1
 191       GO TO 73
 192
 193    75 MODE   = 2
 194       NWORDS = 1
 195       VALP(1) = VAL
 196       GO TO 94
 197
 198 C----              MULTIPLIER
 199
 200    81 IF (IVAL.LE.0)               GO TO 94
 201       IF (MULT.NE.0)               GO TO 94
 202       MULT  = IVAL
 203       JLRAN = JDO + 1
 204       GO TO 12
 205
 206 C----              NON-NUMERIC
 207
 208    91 MFMT = -1
 209    92 MFMT = MFMT - 1
 210       NSEP = IFIRST
 211       GO TO 94
 212
 213    93 MODE = 1
 214    94 MULT = MAX (0,MULT-1)
 215       RETURN
 216       END
 217 *      ==================================================
 218 #include "zebra/qcardl.inc"