MINICERN/packlib/zebra/fq/fzin.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.2  1996/04/18 16:10:36  mclareni
   6 * Incorporate changes from J.Zoll for version 3.77
   7 *
   8 * Revision 1.1.1.1  1996/03/06 10:47:14  mclareni
   9 * Zebra
  10 *
  11 *
  12 #include "zebra/pilot.h"
  13       SUBROUTINE FZIN (LUNP,IXDIVP,LSUPP,JBIASP,CHOPT,NUHP,IUHEAD)
  14
  15 C-    MAIN SEQUENTIAL INPUT ROUTINE, USER CALLED
  16
  17 #include "zebra/zbcd.inc"
  18 #include "zebra/zmach.inc"
  19 #include "zebra/zunit.inc"
  20 #include "zebra/zvfaut.inc"
  21 #include "zebra/mqsys.inc"
  22 #include "zebra/eqlqf.inc"
  23 #include "zebra/mzcn.inc"
  24 #include "zebra/mzct.inc"
  25 #include "zebra/fzci.inc"
  26 #include "zebra/fzcseg.inc"
  27 #include "zebra/fzcocc.inc"
  28 C--------------    End CDE                             --------------
  29       DIMENSION    LUNP(9),IXDIVP(9),LSUPP(9),JBIASP(9)
  30       DIMENSION    NUHP(9),IUHEAD(99)
  31       DIMENSION    MOPTV(6)
  32       EQUIVALENCE (MOPTV(1),IOPTIE)
  33       EQUIVALENCE (LRTYP,IDI(2))
  34       CHARACTER    CHOPT*(*)
  35 #if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
  36       DIMENSION    NAMESR(2)
  37       DATA  NAMESR / 4HFZIN, 4H     /
  38 #endif
  39 #if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
  40       DATA  NAMESR / 6HFZIN   /
  41 #endif
  42 #if !defined(CERNLIB_QTRHOLL)
  43       CHARACTER    NAMESR*8
  44       PARAMETER   (NAMESR = 'FZIN    ')
  45 #endif
  46
  47
  48 #include "zebra/qtrace.inc"
  49
  50       LUNNI  = LUNP(1)
  51       IXDIVI = IXDIVP(1)
  52       CALL UOPTC (CHOPT,'ERSATDFGH234',IOPTIE)
  53       IOPTIF = IOPTIF + IOPTIG + IOPTIH
  54       IF (IOPTI2(1).NE.0)  IOPTIR = 2
  55       IF (IOPTI2(2).NE.0)  IOPTIR = 3
  56       IF (IOPTI2(3).NE.0)  IOPTIR = 4
  57
  58 C--                Set current input unit
  59
  60       IF (LUNNI.NE.LUNI)  CALL FZLOC (LUNNI,1)
  61 #if defined(CERNLIB_QDEBPRI)
  62       IF (LOGLVI.GE.2)   THEN
  63           IF (LOGLVI.GE.3)  WRITE (IQLOG,9110)
  64           WRITE (IQLOG,9111) LUNNI,NUHP(1),MOPTV
  65         ENDIF
  66  9110 FORMAT (1X)
  67  9111 FORMAT (' FZIN-    Entered for LUN=',I4,' NUH=',I5,
  68      F' E/R/S/A/T/D= ',6I1)
  69 #endif
  70
  71       NWRDAI = IQ(KQSP+LQFI+20)
  72       NRECAI = IQ(KQSP+LQFI+21)
  73       JRETCD = 0
  74       JERROR = 0
  75       NWERR  = 0
  76       NQOCC  = 0
  77       JOPT   = IOPTIT + IOPTIA + IOPTID
  78       IF (JOPT.EQ.0)               GO TO 141
  79
  80 C--                Re-entry for pending d/s
  81
  82       IF (IOPTIR.NE.0)             GO TO 714
  83       LRTYP  = IQ(KQSP+LQFI+27)
  84       NWTABI = IQ(KQSP+LQFI+41)
  85       NWBKI  = IQ(KQSP+LQFI+42)
  86       LENTRI = IQ(KQSP+LQFI+43)
  87       IF (JOPT.GE.2)               GO TO 711
  88       IF (LRTYP.GE.5)              GO TO 712
  89       IF (LRTYP.LE.1)              GO TO 712
  90       IF (IOPTIT.NE.0)             GO TO 121
  91       IEVFLI = 3 - LRTYP
  92       NWUMXI = 0
  93       IF (IOPTIA.NE.0)             GO TO 154
  94       GO TO 151
  95
  96 C----              Ready segment table for the user
  97
  98   121 LFISEG = LQFI + JAUSEG
  99       NQSEG  = IQ(KQSP+LFISEG) / 3
 100       IF (NQSEG.NE.0)  THEN
 101           N = 2*NQSEG
 102           CALL UCOPY (IQ(KQSP+LFISEG+1),IQSEGH,N)
 103           CALL VZERO (IQSEGD,NQSEG)
 104         ENDIF
 105       IQSGLU = LUNI
 106       IQUEST(1) = 0
 107       GO TO 999
 108
 109 C-----------------------------------------------------
 110 C-                 obtain and digest next pilot record
 111 C-----------------------------------------------------
 112
 113   141 IF (IACTVI.GE.6)             GO TO 701
 114 #if defined(CERNLIB_QDEBUG)
 115       IF (IQVSTA.NE.0)  THEN
 116           ISV = IQVID(2)
 117           CALL ZVAUTX
 118           IF (IQVID(2).NE.ISV)  THEN
 119               IQVREM(1,3) = IQVID(1)
 120               IQVREM(2,3) = IQVID(2)
 121             ENDIF
 122         ENDIF
 123 #endif
 124   142 NWUMXI = NUHP(1)
 125       NWUHI  = 0
 126
 127       JPENDG = IQ(KQSP+LQFI+30)
 128       IQ(KQSP+LQFI+30) = 0
 129       IF (JPENDG.EQ.1)             GO TO 301
 130       IF (JPENDG.EQ.2)             GO TO 311
 131
 132 #if defined(CERNLIB_FZFFNAT)
 133       IF (IFIFOI.EQ.0)  THEN
 134           CALL FZIFFN (1)
 135           GO TO 144
 136         ENDIF
 137 #endif
 138       CALL FZIFFX (1)
 139   144 IF (JRETCD.NE.0)             GO TO 391
 140
 141       IF (NWBKI.EQ.0)  IQ(KQSP+LQFI+17) = IQ(KQSP+LQFI+17) + 1
 142
 143 C--                check DAT record wanted / needed
 144
 145       IF (IOPTIF+IPILI(3).EQ.0)    GO TO 145
 146
 147       IF (IOPTIH.NE.0)  THEN
 148           IF (IPILI(3).NE.1)       GO TO 142
 149           GO TO 145
 150         ENDIF
 151
 152       IF (IPILI(3).NE.0)  THEN
 153           IF (IOPTIF.EQ.0)         GO TO 142
 154         ENDIF
 155
 156 C--                Copy header vector to user
 157
 158   145 IF (NWUMXI.LE.0)             GO TO 146
 159       NWUHI   = MIN (NWUHI, NWUMXI)
 160       NUHP(1) = NWUHI
 161       IF (NWUHI.GT.0)  CALL UCOPY (LQ(LUHEAI),IUHEAD,NWUHI)
 162
 163 C--                Return if selective call
 164
 165   146 IF (IOPTIS.EQ.0)             GO TO 154
 166       IQ(KQSP+LQFI+41) = NWTABI
 167       IQ(KQSP+LQFI+42) = NWBKI
 168       IQ(KQSP+LQFI+43) = LENTRI
 169 #if defined(CERNLIB_QDEBPRI)
 170       IF (LOGLVI.GE.3)  WRITE (IQLOG,9146)
 171  9146 FORMAT (' FZIN-    Exit for S option.')
 172 #endif
 173       GO TO 991
 174
 175 C-------------------------------------------------
 176 C-                 read table and d/s, relocate
 177 C-------------------------------------------------
 178
 179 C--                Re-entry with D-option
 180
 181   151 IF (IQSGLU.NE.LUNI)          GO TO 713
 182       GO TO 155
 183
 184 C--                Re-entry with A-option
 185
 186   154 NQSEG = 0
 187   155 IF (NWBKI.NE.0)              GO TO 157
 188
 189 C--                Empty d/s
 190
 191       LRTYP  = 0
 192       LENTRI = 0
 193       GO TO 189
 194
 195 C--                Get store / division
 196
 197   157 CALL MZSDIV (IXDIVI,7)
 198       IF (JQDIVI.EQ.0)  JQDIVI=2
 199       LQSYSR(KQT+1) = LSUPP(1)
 200
 201 #if defined(CERNLIB_QDEBPRI)
 202       IF (LOGLVI.GE.3)
 203      +  WRITE (IQLOG,9157) JQSTOR,JQDIVI,NWTABI,NWBKI
 204  9157 FORMAT (' FZIN-    accept d/s into STORE/def.DIV.=',2I4,
 205      F' need memory for NWTB/NWBK=',I5,I7)
 206 #endif
 207
 208 C--                Ready memory occupation table, reserve space
 209
 210       CALL FZIMTB
 211       IF (JRETCD.NE.0)             GO TO 390
 212
 213 C--                Early table
 214
 215       LFIEAR = LQFI + JAUEAR
 216       NTBE   = IQ(KQSP+LFIEAR)
 217       IF (NTBE.NE.0)  THEN
 218           LTBR  = LQTA + NWTABI
 219           CALL UCOPY (IQ(KQSP+LFIEAR+1),LQ(LTBR),NWTABI)
 220           GO TO 159
 221         ENDIF
 222
 223 C--                Read the long table
 224
 225       IF (NWTABI.EQ.0)             GO TO 159
 226 #if defined(CERNLIB_FZFFNAT)
 227       IF (IFIFOI.EQ.0)  THEN
 228           CALL FZIFFN (2)
 229           GO TO 158
 230         ENDIF
 231 #endif
 232       CALL FZIFFX (2)
 233   158 IF (JRETCD.NE.0)             GO TO 391
 234
 235 C--                Read the data
 236
 237   159 CONTINUE
 238 #if defined(CERNLIB_FZFFNAT)
 239       IF (IFIFOI.EQ.0)  THEN
 240           CALL FZIFFN (3)
 241           GO TO 160
 242         ENDIF
 243 #endif
 244       CALL FZIFFX (3)
 245   160 IF (JRETCD.NE.0)             GO TO 391
 246
 247 C--                Relocation
 248
 249       CALL FZIREL
 250       IF (JRETCD.NE.0)             GO TO 391
 251
 252 C-------------------------------------------------------------
 253 C-              done : link and return
 254 C-------------------------------------------------------------
 255
 256   181 JB = JBIASP(1)
 257       IF (JB.GE.2)  THEN
 258           LSUPP(1) = LENTRI
 259         ELSE
 260           LSUPP(1) = LQSYSR(KQT+1)
 261           CALL ZSHUNT (IXDIVI,LENTRI,LSUPP,JB,1)
 262         ENDIF
 263
 264       IQ(KQSP+LQFI+16) = IQ(KQSP+LQFI+16) + 1
 265
 266   189 LRTYP  = 8
 267 #if defined(CERNLIB_QDEBPRI)
 268       IF (LOGLVI.GE.3)  WRITE (IQLOG,9189) NWTABI,NWBKI,IEVFLI
 269  9189 FORMAT (' FZIN-    exit for d/s with NWTB,NWBK,IEVENT=',
 270      F 2I6,I9,I2)
 271 #endif
 272       GO TO 991
 273
 274 C-------------------------------------------------------------
 275 C-              Exit to exceptions
 276 C-------------------------------------------------------------
 277
 278 C--                Pending EoF
 279
 280   301 JRETCD = -1
 281       GO TO 781
 282
 283 C--                Pending start/end of run
 284
 285   311 LFIIOC = LQFI + JAUIOC
 286       NWUHI  = IQ(KQSP+LFIIOC)
 287       LUHEAI = LQWKFZ
 288       CALL UCOPY (IQ(KQSP+LFIIOC+1),LQ(LUHEAI),NWUHI)
 289       JRETCD = -2
 290       GO TO 421
 291
 292 C--                Side exceptions
 293
 294   390 IF (JRETCD.LT.0)             GO TO 155
 295   391 IF (JRETCD.NE.-2)            GO TO 781
 296
 297 C-------------------------------------------------
 298 C-                 end-of-file / end-of-run
 299 C-------------------------------------------------
 300
 301 C----              Normal S/E-OF-RUN
 302
 303   421 CALL FZIDIA
 304       IF (LQ(LUHEAI).GT.0)         GO TO 424
 305
 306 C--                End of run
 307
 308       IF (IOPTIR.EQ.1)             GO TO 142
 309       IF (IOPTIR.GE.IACTVI)        GO TO 142
 310       GO TO 427
 311
 312 C--                Start of run
 313
 314   424 IF (IOPTIR.GE.2)             GO TO 142
 315   427 IF (NWUMXI.LE.0)             GO TO 997
 316       NWUHI = MIN (NWUHI-1, NWUMXI)
 317       NUHP(1) = NWUHI
 318       IF (NWUHI.GT.0)  CALL UCOPY (LQ(LUHEAI+1),IUHEAD(1),NWUHI)
 319       GO TO 997
 320
 321 C-------------------------------------------------
 322 C-                 ERROR CONDITIONS
 323 C-------------------------------------------------
 324
 325 C--                Reading beyond end-of-data
 326
 327   701 IF (IACTVI.EQ.8)             GO TO 142
 328       IF (IACTVI.EQ.18)            GO TO 142
 329       JRETCD = -3
 330       GO TO 781
 331
 332 C----              User error
 333
 334 C-    JERROR = 14  options (R,2,3,4) not allowed with (T,A,D)
 335   714 JERROR = 1
 336
 337 C-    JERROR = 13  no segment table for entry with D option
 338   713 JERROR = JERROR + 1
 339
 340 C-    JERROR = 12  no pending d/s for entry with T A D options
 341   712 JERROR = JERROR + 1
 342
 343 C-    JERROR = 11  multiple options T A D not allowed
 344   711 JERROR = 11 + JERROR
 345       JRETCD = 4
 346
 347 C------            Print error message
 348
 349   781 CALL FZIDIA
 350
 351 C--                Abandon reserved space, if any
 352
 353       IF (NQOCC.EQ.0)              GO TO 997
 354       DO 784  J=1,NQOCC
 355       JDIV = IQOCDV(J)
 356       NW   = IQOCSP(J)
 357       IF (IQMODE(KQT+JDIV).EQ.0)  THEN
 358           LQEND(KQT+JDIV) = LQEND(KQT+JDIV) - NW
 359         ELSE
 360           LQSTA(KQT+JDIV) = LQSTA(KQT+JDIV) + NW
 361         ENDIF
 362   784 CONTINUE
 363       GO TO 997
 364
 365 C--                Common exit
 366
 367   991 IQUEST(1)  = 0
 368       IQUEST(5)  = IQ(KQSP+LQFI+31)
 369       IQUEST(6)  = IQ(KQSP+LQFI+32)
 370       IQUEST(11) = IEVFLI
 371       IQUEST(12) = IPILI(3)
 372       IQUEST(13) = LENTRI
 373       IQUEST(14) = NWBKI
 374       LFIIOC = LQFI + JAUIOC
 375       NWIOI  = IQ(KQSP+LFIIOC)
 376       CALL UCOPY (IQ(KQSP+LFIIOC),IQUEST(20),NWIOI+1)
 377
 378       IF (NWRDAI.GE.1000000)  THEN
 379           IQ(KQSP+LQFI+19) = IQ(KQSP+LQFI+19) + 1
 380           NWRDAI = NWRDAI - 1000000
 381         ENDIF
 382
 383   997 IQ(KQSP+LQFI+26) = IQUEST(1)
 384       IQ(KQSP+LQFI+27) = LRTYP
 385       IQ(KQSP+LQFI+2)  = IACTVI
 386       IQ(KQSP+LQFI+20) = NWRDAI
 387       IQ(KQSP+LQFI+21) = NRECAI
 388       IQUEST(2) = NRECAI
 389       IQUEST(3) = IQ(KQSP+LQFI+22)
 390       IQSGLU = 0
 391
 392 #include "zebra/qtrace99.inc"
 393       RETURN
 394       END
 395 *      ==================================================
 396 #include "zebra/qcardl.inc"