[u/mrichter/AliRoot.git] / MINICERN / packlib / zebra / qutil / zkrakn.F

*
* $Id$
*
* $Log$
* Revision 1.1.1.1  1996/03/06 10:47:15  mclareni
* Zebra
*
*
#include "zebra/pilot.h"
      SUBROUTINE ZKRAKN (MFLAGP,JLP,JRP,VALP)

#include "zebra/zbcd.inc"
#include "zebra/zkrakc.inc"
#include "zebra/zkrakqu.inc"
C--------------    END CDE                             --------------

      COMMON /SLATE/ NDIG, JNEXT, DUMMY(38)

      DIMENSION    MFLAGP(9), JLP(9), JRP(9), VALP(9)
      INTEGER      IVAL
      EQUIVALENCE (VAL,IVAL)


#include "zebra/q_jbit.inc"


      MFLAG  = MFLAGP(1)
      JLRAN  = JLP(1)
      JRRAN  = JRP(1)
      MODE   = 0
      NWORDS = 0
      MFMT   = 0
      MULT   = JBIT(MFLAG,10) - 1
      IFLBLT = JBIT(MFLAG,6)
   12 NSEP   = 0
      JR     = JRRAN
      JTERM  = JRRAN + 1
      JNXGO  = JTERM

C-    IZBCD VAL.             1 27 36 37 38 39 40 41 42 43 44 45 46 47
C-    CHARACTER              A  0  9  +  -  *  /  (  )  $  = BL  ,  .
C-    BIT J IN MFLAG IF SEPARATOR LEGAL,   J=  1  2  3  4  5  6  7
C-    J=10   MULTIPLIER LEGAL

C--                IGNORE LEADING BLANKS

      JDO = JLRAN - 1
   13 JDO = JDO + 1
      IF (JDO.GT.JRRAN)            GO TO 93
      IFIRST = IQCETK(JDO)
      IF (IFIRST.EQ.45)            GO TO 13

      IF (IFIRST.LT.27)            GO TO 91
      IF (IFIRST.LT.39)            GO TO 14
      IF (IFIRST.NE.47)            GO TO 92

C--                FIND BLANK TERMINATOR, IF SELECTED

   14 IF (IFLBLT.EQ.0)             GO TO 17
      JTERM = JDO
   15 JTERM = JTERM + 1
      IF (JTERM.GT.JRRAN)          GO TO 16
      IF (IQCETK(JTERM).NE.45)     GO TO 15
   16 JR    = JTERM - 1

C--                STEP OVER SIGN-BIT

   17 IF (IFIRST.EQ.37)            GO TO 18
      IF (IFIRST.NE.38)            GO TO 21
   18 JDO = JDO +1
      IF (JDO.EQ.JTERM)            GO TO 94

C--                READ INITIAL INTEGER

   21 NDALL = 0
      IVAL  = 0
      JDO   = JDO - 1
   22 JDO   = JDO + 1
      IF (JDO.EQ.JTERM)            GO TO 28
      J = IQCETK(JDO) - 27
      IF (J.LT.0)                  GO TO 24
      IF (J.EQ.18)                 GO TO 22
      IF (J.GE.10)                 GO TO 24
      IVAL  = IVAL*10 + J
      NDALL = NDALL + 1
      GO TO 22

   24 JEXP = 0
      JEXF = 0
      FRAC = 0.
      NSEP = IQCETK(JDO)
      IF   (NSEP-39)         41, 81, 26
   26 IF (NSEP.EQ.47)              GO TO 31

   28 IF (IFIRST.EQ.38)  IVAL=-IVAL
      MFMT = 1
      GO TO 71

C--                READ FRACTION

   31 JEXW = 0
   32 JDO  = JDO + 1
      IF (JDO.EQ.JTERM)            GO TO 50

      NSEP = IQCETK(JDO)
      IF (NSEP-27)           41, 33, 34
   33 NDALL = NDALL + 1
      JEXW  = JEXW  + 1
      GO TO 32

   34 IF (NSEP.GE.37)              GO TO 38
   35 IF (JEXW.EQ.0)               GO TO 36
      JEXW  = JEXW  - 1
      JEXF  = JEXF  - 1
      FRAC  = FRAC * 10.
      GO TO 35

   36 NDALL = NDALL + 1
      JEXF  = JEXF  - 1
      FRAC  = FRAC*10. + REAL(NSEP-27)
      GO TO 32

   38 IF (NSEP.EQ.45)              GO TO 32
      IF (NSEP-39)           44, 94, 51

C--                READ EXPONENT

   41 IF (NSEP.NE.5)               GO TO 44
   42 JDO = JDO + 1
      IF (JDO.EQ.JTERM)            GO TO 50
      NSEP = IQCETK(JDO)
      IF (NSEP.EQ.45)              GO TO 42
      IF (NSEP-39)           44, 94, 51

   44 IF (NSEP.LT.27)              GO TO 94
      IF (NSEP.LT.37)              GO TO 46
      JDO = JDO + 1
      IF (JDO.EQ.JTERM)            GO TO 94

   46 JEXP = IUFORW (IQHOLK,JDO,JR)
      IF (JEXP.EQ.0)               GO TO 47
      IF (NSEP.EQ.38)  JEXP=-JEXP
      JEXF = JEXF + JEXP
   47 JDO  = JNEXT
      IF (JDO.EQ.JTERM)            GO TO 50
      NSEP = IQCETK(JDO)
      IF (NSEP.GE.40)              GO TO 51
      GO TO 94

C--                SET FLOATING RESULT

   50 NSEP = 0
   51 VAL  = REAL (IVAL)
      IF (VAL.EQ.0.)               GO TO 61
      IF   (JEXP)            58, 61, 52
   52 IF (JEXP.GE.9)               GO TO 58
      DO 54  J=1,JEXP
   54 VAL = VAL * 10.
      GO TO 61

   58 VAL = VAL * 10.**JEXP

C--                SET FLOATING RESULT, FRACTIONAL PART

   61 IF (FRAC.EQ.0.)              GO TO 66
      IF   (JEXF)            64, 65, 62
   62 IF (JEXF.GE.9)               GO TO 64
      DO 63  J=1,JEXF
   63 FRAC = FRAC * 10.
      GO TO 65

   64 FRAC = FRAC * 10.**JEXF

   65 VAL = VAL + FRAC
   66 IF (IFIRST.NE.38)            GO TO 71
      VAL = -VAL

C--                STORE RESULT

   71 IF (NDALL.EQ.0)              GO TO 94
      IF (NSEP.EQ.0)               GO TO 72
      NSEP = MIN  (NSEP,47)
      IF (JBIT(MFLAG,NSEP-39).EQ.0)  GO TO 94
      IF (NSEP.EQ.43)              GO TO 72
      JDO    = JDO + 1

   72 JNXGO  = JDO
   73 IF (JNXGO.GT.JRRAN)          GO TO 75
      IF (IQCETK(JNXGO).NE.45)     GO TO 75
      JNXGO  = JNXGO + 1
      GO TO 73

   75 MODE   = 2
      NWORDS = 1
      VALP(1) = VAL
      GO TO 94

C----              MULTIPLIER

   81 IF (IVAL.LE.0)               GO TO 94
      IF (MULT.NE.0)               GO TO 94
      MULT  = IVAL
      JLRAN = JDO + 1
      GO TO 12

C----              NON-NUMERIC

   91 MFMT = -1
   92 MFMT = MFMT - 1
      NSEP = IFIRST
      GO TO 94

   93 MODE = 1
   94 MULT = MAX (0,MULT-1)
      RETURN
      END
*      ==================================================
#include "zebra/qcardl.inc"
Commit	Line	Data
fe4da5cc	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"