MINICERN/packlib/zebra/fq/fziffn.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.2  1996/04/18 16:10:31  mclareni
   6 * Incorporate changes from J.Zoll for version 3.77
   7 *
   8 * Revision 1.1.1.1  1996/03/06 10:47:13  mclareni
   9 * Zebra
  10 *
  11 *
  12 #include "zebra/pilot.h"
  13 #if defined(CERNLIB_FZFFNAT)
  14       SUBROUTINE FZIFFN (JSTAGE)
  15
  16 C-    Read operations for file format native
  17 C-    subsidiary to FZIN
  18
  19 C-    Controlling parameter : JSTAGE
  20 C-
  21 C-    JSTAGE =  1 :  read the first pilot record
  22 C-              2 :  read the tables into memory
  23 C-              3 :  read the bank material
  24
  25 #include "zebra/zbcd.inc"
  26 #include "zebra/zmach.inc"
  27 #include "zebra/zunit.inc"
  28 #include "zebra/mqsys.inc"
  29 #include "zebra/eqlqf.inc"
  30 #include "zebra/mzcn.inc"
  31 #include "zebra/mzct.inc"
  32 #include "zebra/mzcwk.inc"
  33 #include "zebra/fzci.inc"
  34 #include "zebra/fzcseg.inc"
  35 #include "zebra/fzcocc.inc"
  36 C--------------    End CDE                             --------------
  37       DIMENSION    MPILOT(10)
  38       REAL         CHDATA
  39 #if defined(CERNLIB_QMVDS)
  40       SAVE         CHDATA
  41 #endif
  42       EQUIVALENCE (MPILOT(1),IPILI(1))
  43       EQUIVALENCE (LRTYP,IDI(2)), (ICHDAT,CHDATA)
  44 #if defined(CERNLIB_QREADFULL)
  45       COMMON /SLATE/ NRSLAT, DUMMY(39)
  46 #endif
  47 #if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
  48       DIMENSION    NAMESR(2)
  49       DATA  NAMESR / 4HFZIF, 4HFN   /
  50 #endif
  51 #if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
  52       DATA  NAMESR / 6HFZIFFN /
  53 #endif
  54 #if !defined(CERNLIB_QTRHOLL)
  55       CHARACTER    NAMESR*8
  56       PARAMETER   (NAMESR = 'FZIFFN  ')
  57 #endif
  58       DATA  CHDATA / 12345.0 /
  59
  60 #include "zebra/q_jbyt.inc"
  61
  62 #include "zebra/qtrace.inc"
  63
  64       GO TO (101,201,301), JSTAGE
  65
  66 C-----------------------------------------------------
  67 C-                 obtain and digest next pilot record
  68 C-----------------------------------------------------
  69
  70   101 LIN  = LQWKFZ
  71
  72   102 NWR = NQWKTT
  73       CALL XINBS (LUNI,LRTYP,1,LQ(LIN),NWR)
  74 #if defined(CERNLIB_QDEBPRI)
  75       IF (LOGLVI.GE.3)  WRITE (IQLOG,9102) NRECAI+1,NWR,LRTYP
  76  9102 FORMAT (' FZIFFN-  hunt for pilot, seen LR #',I7,
  77      F' with NWRL/LRTYP=',I7,I3)
  78 #endif
  79       IF (NWR.EQ.0)                GO TO 412
  80       IF (NWR.LT.0)                GO TO 751
  81       NRECAI   = NRECAI + 1
  82       NWRDAI   = NWRDAI + NWR + 3
  83       IF (LRTYP.LE.0)              GO TO 741
  84       IF (LRTYP.GT.9)              GO TO 741
  85       IF (LRTYP.GE.4)              GO TO 102
  86       IF (LRTYP.EQ.1)              GO TO 427
  87
  88       IACTVI = 2
  89       IEVFLI = 3 - LRTYP
  90       IQ(KQSP+LQFI+15) = IQ(KQSP+LQFI+15) + 1
  91       IF (IOPTIR.NE.0)             GO TO 102
  92       IF (IEVFLI.LT.IOPTIE)        GO TO 102
  93
  94       CALL UCOPY (LQ(LIN),IPILI,26)
  95 #if defined(CERNLIB_QDEBPRI)
  96       IF (LOGLVI.GE.3)  WRITE (IQLOG,9107,ERR=107) MPILOT,MPILOT
  97   107 CONTINUE
  98  9107 FORMAT (10X,'the 10 pilot control words : ',
  99 #endif
 100 #if (defined(CERNLIB_QDEBPRI))&&(!defined(CERNLIB_HEX))
 101      F/1X,4O23/1X,4O23/1X,2O23
 102      F/1H0,9X,F13.1,3(9X,I14)/1X,4(9X,I14)/1X,2(9X,I14))
 103 #endif
 104 #if (defined(CERNLIB_QDEBPRI))&&(defined(CERNLIB_HEX))
 105      F/10X,4Z17/10X,4Z17/10X,2Z17
 106      F/1H0,9X,F17.1,3I17/10X,4I17/10X,2I17)
 107 #endif
 108       IF (IPILI(1).NE.ICHDAT)      GO TO 742
 109
 110 C--                Copy user header
 111
 112       NWDONE = NWUHCI + 10
 113       NWIOI  = 0
 114       NWUHI  = 0
 115       LFIIOC = LQFI + JAUIOC
 116       IQ(KQSP+LFIIOC) = 0
 117       IF (NWUMXI.LE.0)             GO TO 121
 118
 119       IF (NWUHCI.EQ.0)   THEN
 120           NWUHI = 0
 121           GO TO 121
 122         ENDIF
 123
 124       NWIOI = JBYT (IOCHI(1),7,5)
 125       IF (NWIOI.EQ.0)   THEN
 126           NWIOI = 1
 127           IF (IOCHI(1).GE.8)       GO TO 743
 128           IF (IOCHI(1).LT.0)       GO TO 743
 129           IF (IOCHI(1).EQ.0)  IOCHI(1)=1
 130         ELSE
 131           J = JBYT (IOCHI(1),12,5)
 132           IF (J+1.NE.NWIOI)        GO TO 743
 133         ENDIF
 134       IQ(KQSP+LFIIOC) = NWIOI
 135       CALL UCOPY (IOCHI,IQ(KQSP+LFIIOC+1),NWIOI)
 136
 137       NWUHI  = NWUHCI - NWIOI
 138       LUHEAI = LIN + 10 + NWIOI
 139 #if defined(CERNLIB_QDEBPRI)
 140       IF (LOGLVI.GE.3)  THEN
 141           N = MIN (8,NWUHI)
 142           IF (LOGLVI.GE.4)  THEN
 143               WRITE (IQLOG,9113) NWIOI
 144               WRITE (IQLOG,9115) (IOCHI(J),J=1,NWIOI)
 145               N = NWUHI
 146             ENDIF
 147           WRITE (IQLOG,9114) NWUHI,N
 148           WRITE (IQLOG,9115) (LQ(LUHEAI+J),J=0,N-1)
 149         ENDIF
 150  9113 FORMAT (10X,I2,' words I/O characteristic for UHV =')
 151  9114 FORMAT (10X,I4,' words of User Header accepted, dump the first'
 152      F,I5)
 153 #endif
 154 #if (defined(CERNLIB_QDEBPRI))&&(!defined(CERNLIB_HEX))
 155  9115 FORMAT (1X,4O23)
 156 #endif
 157 #if (defined(CERNLIB_QDEBPRI))&&(defined(CERNLIB_HEX))
 158  9115 FORMAT (10X,4Z17)
 159 #endif
 160
 161 C----              Save the segment table
 162
 163   121 LFISEG = LQFI + JAUSEG
 164       IF (NWSEGI.EQ.0)             GO TO 124
 165       IF (NWSEGI.GE.61)            GO TO 744
 166       IF (NWSEGI.LT.0)             GO TO 744
 167       IF (NWTABI.EQ.0)  THEN
 168           NWDONE = NWDONE + NWSEGI
 169           NWSEGI = 0
 170         ELSE
 171           CALL UCOPY (LQ(LIN+NWDONE),IQ(KQSP+LFISEG+1),NWSEGI)
 172           NWDONE = NWDONE + NWSEGI
 173         ENDIF
 174   124 IQ(KQSP+LFISEG) = NWSEGI
 175
 176 C----              Save the text vector
 177
 178       LTEXT = LQ(KQSP+LQFI-2)
 179       IF (LTEXT.NE.0)  IQ(KQSP+LTEXT+1)=0
 180       IF (NWTXI.EQ.0)              GO TO 141
 181
 182 C--                Increase the size of the text buffer if necessary
 183
 184       IF (LTEXT.EQ.0)              GO TO 131
 185       NINC = NWTXI + 4 - IQ(KQSP+LTEXT-1)
 186       IF (NINC.LE.0)               GO TO 131
 187
 188       NQWKTB = NQWKTT
 189       CALL MZPUSH (JQPDVS,LTEXT,0,NINC,'.')
 190
 191 C--                Read the text vector
 192
 193   131 IF (NWDONE.LT.NWR)           GO TO 136
 194   132 LIN = LQWKTB
 195       NWR = NQWKTT
 196       CALL XINBS (LUNI,MRTYP,1,LQ(LIN),NWR)
 197 #if defined(CERNLIB_QDEBPRI)
 198       IF (LOGLVI.GE.3)  WRITE (IQLOG,9132) NRECAI+1,NWR,MRTYP
 199  9132 FORMAT (10X,'expect pilot continuation, seen LR #',I7,
 200      F' with NWRL/LRTYP=',I7,I3)
 201 #endif
 202       IF (NWR.EQ.0)                GO TO 411
 203       IF (NWR.LT.0)                GO TO 751
 204       NRECAI   = NRECAI + 1
 205       NWRDAI   = NWRDAI + NWR + 3
 206
 207       IF (MRTYP-4)           134, 135, 133
 208   133 IF (MRTYP.LT.7)              GO TO 132
 209   134 LRTYP = MRTYP
 210       IF (LRTYP.EQ.1)              GO TO 424
 211       GO TO 731
 212
 213   135 NWDONE = 0
 214
 215 C--                Store into the text buffer
 216
 217   136 IF (NWR-NWDONE.LT.NWTXI)     GO TO 745
 218       IF (LTEXT.NE.0)  THEN
 219           IQ(KQSP+LTEXT+1) = NWTXI
 220           CALL UCOPY (LQ(LIN+NWDONE),IQ(KQSP+LTEXT+5),NWTXI)
 221         ENDIF
 222       NWDONE = NWDONE + NWTXI
 223
 224 C----              Save early table words
 225
 226   141 NTBE   = NWR - NWDONE
 227       LFIEAR = LQFI + JAUEAR
 228       IQ(KQSP+LFIEAR) = NTBE
 229
 230       IF (NTBE.NE.0)  THEN
 231           IF (NTBE.NE.NWTABI)      GO TO 746
 232           IF (NTBE.GE.41)          GO TO 746
 233           CALL UCOPY (LQ(LIN+NWDONE),IQ(KQSP+LFIEAR+1),NTBE)
 234         ENDIF
 235       GO TO 999
 236
 237 C-------------------------------------------------
 238 C-                 read table
 239 C-------------------------------------------------
 240
 241   201 LIN = LQTA + NWTABI
 242   204 NWR = LQTE - LIN
 243       CALL XINBS (LUNI,LRTYP,1,LQ(LIN),NWR)
 244 #if defined(CERNLIB_QDEBPRI)
 245       IF (LOGLVI.GE.3)  WRITE (IQLOG,9204) NRECAI+1,NWR,LRTYP
 246  9204 FORMAT (' FZIFFN-  expect table, seen LR #',I7,
 247      F' with NWRL/LRTYP=',I7,I3)
 248 #endif
 249       IF (NWR.EQ.0)                GO TO 411
 250       IF (NWR.LT.0)                GO TO 751
 251       NRECAI   = NRECAI + 1
 252       NWRDAI   = NWRDAI + NWR + 3
 253       IF (LRTYP.EQ.1)              GO TO 424
 254       IF (LRTYP.LT.4)              GO TO 732
 255       IF (LRTYP.GE.7)              GO TO 732
 256       IF (LRTYP.GE.5)              GO TO 204
 257       LIN = LIN + NWR
 258       IF   (LIN-LQTE)        204, 999, 747
 259
 260 C-------------------------------------------------
 261 C-                 read the data
 262 C-------------------------------------------------
 263
 264   301 LMT  = LQMTA
 265   302 IF (LQ(LMT+1).NE.0)          GO TO 311
 266
 267 C--                Skip segment to be ignored
 268
 269       NWSK = LQ(LMT+3)
 270       LIN  = LQWKFZ
 271 #if defined(CERNLIB_QREADFULL)
 272   304 NWR  = NQWKTT
 273       CALL XINBS (LUNI,LRTYP,1,LQ(LIN+2),NWR)
 274       IDI(1) = NWR
 275       NWRU   = NWR
 276 #endif
 277 #if !defined(CERNLIB_QREADFULL)
 278   304 NWR  = 3
 279       CALL XINBF (LUNI,LQ(LIN),NWR)
 280       IDI(1) = LQ(LIN)
 281       IDI(2) = LQ(LIN+1)
 282       NWRU   = 1
 283 #endif
 284 #if defined(CERNLIB_QDEBPRI)
 285       IF (LOGLVI.GE.3)  WRITE (IQLOG,9314) NRECAI+1,IDI
 286 #endif
 287       IF (NWR.EQ.0)                GO TO 411
 288       IF (NWR.LT.0)                GO TO 751
 289       NRECAI   = NRECAI + 1
 290       NWRDAI   = NWRDAI + IDI(1) + 3
 291       IF (LRTYP.EQ.1)              GO TO 421
 292       IF (LRTYP.LT.5)              GO TO 733
 293       IF (LRTYP.LT.7)              GO TO 304
 294       IF (LRTYP.GE.9)              GO TO 733
 295       NWSK = NWSK + IDI(1)
 296       IF (NWSK.GE.0)               GO TO 307
 297       IF (LRTYP.EQ.7)              GO TO 304
 298       GO TO 734
 299
 300   307 IF (NWSK.EQ.0)               GO TO 318
 301       GO TO 734
 302
 303 C--                Read segment to accept
 304
 305   311 LSTA = LQ(LMT+3)
 306       LEND = LQ(LMT+4)
 307
 308       LIN = LSTA
 309   314 NWR = LEND - LIN
 310       CALL XINBS (LUNI,LRTYP,1,LQ(KQS+LIN),NWR)
 311 #if defined(CERNLIB_QDEBPRI)
 312       IF (LOGLVI.GE.3)  WRITE (IQLOG,9314) NRECAI+1,NWR,LRTYP
 313  9314 FORMAT (' FZIFFN-  expect bank material, seen LR #',I7,
 314      F' with NWRL/LRTYP=',I7,I3)
 315 #endif
 316       IF (NWR.EQ.0)                GO TO 411
 317       IF (NWR.LT.0)                GO TO 751
 318       NRECAI   = NRECAI + 1
 319       NWRDAI   = NWRDAI + NWR + 3
 320       IF (LRTYP.EQ.1)              GO TO 424
 321       IF (LRTYP.LT.5)              GO TO 733
 322       IF (LRTYP.LT.7)              GO TO 314
 323       IF (LRTYP.GE.9)              GO TO 733
 324       LIN = LIN + NWR
 325       IF (LIN.GE.LEND)             GO TO 317
 326       IF (LRTYP.EQ.7)              GO TO 314
 327       GO TO 735
 328
 329   317 IF (LIN.GT.LEND)             GO TO 735
 330   318 LMT = LMT + 8
 331       IF (LMT.LT.LQMTE)            GO TO 302
 332       IF (LRTYP.NE.8)              GO TO 736
 333       GO TO 999
 334
 335 C-------------------------------------------------
 336 C-                 end-of-file / end-of-run
 337 C-------------------------------------------------
 338
 339 C--                Unexpected end-of-file
 340
 341   411 JRETCD = 1
 342       GO TO 999
 343
 344 C--                Normal EOF
 345
 346   412 JRETCD = -1
 347       GO TO 999
 348
 349 C------            Unexpected start/end of run
 350
 351   421 LIN  = LIN  + 2
 352       NWR  = NWRU - 2
 353
 354   424 JRETCD = 2
 355       NWRU   = MIN (78, NWR)
 356       LFIIOC = LQFI + JAUIOC
 357       IQ(KQSP+LFIIOC) = NWRU
 358       CALL UCOPY (LQ(LIN),IQ(KQSP+LFIIOC+1),NWRU)
 359       GO TO 999
 360
 361 C----              Normal S/E-OF-RUN
 362
 363   427 JRETCD = -2
 364       NWUHI  = NWR
 365       LUHEAI = LIN
 366       GO TO 999
 367
 368 C-------------------------------------------------
 369 C-                 ERROR CONDITIONS
 370 C-------------------------------------------------
 371
 372 C--                BAD DATA
 373
 374 C-    JERROR = 137  emergency stop record seen
 375   737 JERROR = 137
 376       JRETCD = 8
 377       GO TO 780
 378
 379 C-    JERROR = 136  last bank material record needed is not type 8
 380   736 JERROR = 136
 381       GO TO 739
 382
 383 C-    JERROR = 135  end of segm read does not coincide with LR
 384   735 JERROR = 135
 385       IQUEST(14)= (LMT-LQMTA)/8 + 1
 386       IQUEST(15)= LEND - LSTA
 387       IQUEST(16)= LIN - LEND
 388       NWERR  = 3
 389       GO TO 739
 390
 391 C-    JERROR = 134  end of segm skipped does not coincide with LR
 392   734 JERROR = 134
 393       IQUEST(14)= (LMT-LQMTA)/8 + 1
 394       IQUEST(15)= -LQ(LMT+3)
 395       IQUEST(16)= NWSK
 396       NWERR  = 3
 397       GO TO 739
 398
 399 C-                  record of unexpected record type read
 400 C-    JERROR = 133  expect bank material
 401   733 JERROR = 1
 402
 403 C-    JERROR = 132  expect pilot continuation for table
 404   732 JERROR = JERROR + 1
 405
 406 C-    JERROR = 131  expect pilot continuation for text vector
 407   731 JERROR = 131 + JERROR
 408       IF (LRTYP.EQ.9)              GO TO 737
 409
 410   739 JRETCD = 5
 411       GO TO 780
 412
 413 C--                BAD CONSTRUCTION
 414
 415 C-    JERROR = 147  table end does not coincide with LR
 416   747 JERROR = 147
 417       IQUEST(14)= NWTABI
 418       IQUEST(15)= LIN - LQTE
 419       NWERR  = 2
 420       GO TO 749
 421
 422 C-    JERROR = 146  number of early table words wrong
 423   746 JERROR = 146
 424       IQUEST(14)= NWTABI
 425       IQUEST(15)= NTBE
 426       NWERR  = 2
 427       GO TO 749
 428
 429 C-    JERROR = 145  text vector NWTXI words longer than its record
 430   745 JERROR = 145
 431       IQUEST(14)= NWTXI
 432       IQUEST(15)= NWR - NWDONE
 433       IQUEST(16)= NWDONE
 434       NWERR  = 3
 435       GO TO 749
 436
 437 C-    JERROR = 144  NWSEGI wrong
 438   744 JERROR = 144
 439       IQUEST(14)= NWSEGI
 440       NWERR  = 1
 441       GO TO 749
 442
 443 C-    JERROR = 143  control wd of I/O char. for user header invalid
 444   743 JERROR = 143
 445       IQUEST(14)= NWUHCI
 446       IQUEST(15)= 0
 447       IQUEST(16)= IOCHI(1)
 448       NWERR  = 3
 449       GO TO 749
 450
 451 C-    JERROR = 142  check-word which should be 12345.0 is wrong
 452   742 JERROR = 142
 453       IQUEST(14)= 0
 454       IQUEST(15)= 0
 455       IQUEST(16)= IPILI(1)
 456       IQUEST(17)= ICHDAT
 457       NWERR  = 4
 458       GO TO 749
 459
 460 C-    JERROR = 141  LRTYP invalid when hunting for pilot
 461   741 JERROR = 141
 462
 463   749 JRETCD = 6
 464       GO TO 780
 465
 466 C--                READ ERROR
 467
 468   751 JERROR = 151
 469       IQUEST(14) = -NWR
 470       NWERR  = 1
 471       JRETCD = 7
 472
 473   780 CONTINUE
 474 #include "zebra/qtrace99.inc"
 475       RETURN
 476       END
 477 *      ==================================================
 478 #include "zebra/qcardl.inc"
 479 #endif