MINICERN/packlib/zebra/fq/fzirec.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/03/06 10:47:11  mclareni
   6 * Zebra
   7 *
   8 *
   9 #include "zebra/pilot.h"
  10       SUBROUTINE FZIREC
  11
  12 C-    Logical record controls, exchange file format
  13 C-    service routine to FZIFFX of FZIN
  14
  15 C-    This routine is called with
  16 C-       IFLAGI > 0  from FZIFFX to initiate the next d/s making sure
  17 C-                   that the block containing its beginning is
  18 C-                   in the buffer, skipping if nec. trailing records
  19 C-                   of the previous d/s
  20 C-              = 0  from FZIFFX to copy the buffer control params.
  21 C-                   between the control-bank and /FZCI/ (for speed)
  22 C-              < 0  from FZITR to read continuation blocks (phR)
  23 C-                   into the buffer
  24
  25 #include "zebra/zunit.inc"
  26 #include "zebra/mqsys.inc"
  27 #include "zebra/eqlqf.inc"
  28 #include "zebra/fzci.inc"
  29 C--------------    End CDE                             --------------
  30 #include "fzntolds.inc"
  31 #if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
  32       DIMENSION    NAMESR(2)
  33       DATA  NAMESR / 4HFZIR, 4HEC   /
  34 #endif
  35 #if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
  36       DATA  NAMESR / 6HFZIREC /
  37 #endif
  38 #if !defined(CERNLIB_QTRHOLL)
  39       CHARACTER    NAMESR*8
  40       PARAMETER   (NAMESR = 'FZIREC  ')
  41 #endif
  42
  43
  44 #include "zebra/qtrace.inc"
  45
  46
  47 C-    buffer parameters :
  48 C-
  49 C-          -9         non-zero : last LR abended
  50 C-          -7         expected next Ph record number
  51 C-          -6         =0 if current block is steering
  52 C-                     =1 if current block is last in burst
  53 C-                     =2 if cur. block is last-but-one in burst, etc
  54 C-          -5         # of fast records still pending
  55 C-
  56 C-          -4 N4SKII, # of words to be skipped
  57 C-                                      before next transmission
  58 C-          -3 N4RESI, # of words in LR still to be done
  59 C-          -2 N4DONI, # of words already out of buffer
  60 C-          -1 N4ENDI, # of words in buffer before start of next LR
  61 C-                     if =0 :      buffer empty
  62 C-                     if =MAXREI : LR continues in next block
  63 C-   LBPARI +0         maximum size of buffer, words
  64 C-          +1         expected size of PhR, local machine words
  65 C-          +2 INCBUF  step to buffer
  66 C-          +3         off-set from start-of-buffer for reading
  67 C-                                  the packed record
  68 C-          +4         (off-set for output)
  69 C-          -1         space for left double-precision word saved
  70 C-   L4STAI +0         first word of normal buffer
  71
  72       IFLIN  = IFLAGI
  73       IFLAGI = 0
  74       LBPARI = LQFI + INCBPI
  75       IF   (IFLIN)                 61, 71, 21
  76
  77 C-----------------------------------------------------------
  78 C------            IFLAGI > 0 :  start new d/s
  79 C-----------------------------------------------------------
  80
  81    21 ICARRL = 0
  82       IFLRST = IQ(KQSP+LBPARI-9)
  83       INCBUF = IQ(KQSP+LBPARI+2)
  84       L4STAI = KQSP+8 + LBPARI + INCBUF
  85
  86       NLRPAD = 0
  87       JFAST  = IQ(KQSP+LBPARI-6)
  88       N4SKII = 0
  89       N4ENDI = IQ(KQSP+LBPARI-1)
  90 #if defined(CERNLIB_QDEBPRI)
  91       IF (LOGLVI.GE.3)
  92      +    WRITE (IQLOG,9022) IFLIN,IFLRST,JFAST,N4ENDI,MAXREI
  93  9022 FORMAT (1X/' FZIREC-  Going for next LR, Buffer Status :'
  94      F/10X,'IFLAGI, Restart?, Fast?, NWtoLR, NWbuf =',6I6)
  95 #endif
  96
  97 C--                Re-start LR after error
  98
  99       IF (IFLRST.NE.0)  THEN
 100           IQ(KQSP+LBPARI-9) = 0
 101           IF (N4ENDI.GT.0)  THEN
 102               IF (N4ENDI.LT.MAXREI-1)  GO TO 51
 103             ENDIF
 104           IFLAGI = -1
 105           GO TO 27
 106         ENDIF
 107
 108 C--                Start afresh
 109
 110       IF (N4ENDI.NE.0)             GO TO 31
 111       IFLAGI = -2
 112    27 CALL VZERO (IQ(KQSP+LBPARI-8),8)
 113       N4RESI = 0
 114       N4DONI = 0
 115       GO TO 46
 116
 117 C----              Normal continuation on current buffer
 118
 119    31 N4RESI = IQ(KQSP+LBPARI-3)
 120       N4DONI = IQ(KQSP+LBPARI-2)
 121 #if defined(CERNLIB_QDEBPRI)
 122       IF (LOGLVI.GE.3)  WRITE (IQLOG,9031) N4RESI,N4DONI,N4ENDI
 123  9031 FORMAT (10X,'Status of last LR : NWrest, NWdone, NWend ='
 124      F,3I5)
 125 #endif
 126
 127 C--                Skip trailing words of last LR
 128
 129       IF (N4RESI.EQ.0)             GO TO 41
 130    34 NWNEW  = MIN (N4ENDI-N4DONI, N4RESI)
 131       N4DONI = N4DONI + NWNEW
 132       N4RESI = N4RESI - NWNEW
 133       IF (N4RESI.EQ.0)             GO TO 41
 134       IF (N4ENDI.NE.MAXREI)        GO TO 821
 135       N4SKII = N4RESI
 136       NWFAST = IQ(KQSP+LBPARI-5) * MAXREI
 137       IF (NWFAST.LE.N4SKII)        GO TO 46
 138       N4SKII = NWFAST
 139       N4RESI = NWFAST
 140       IFLAGI = -2
 141       GO TO 46
 142
 143 C--                New Ph record if buffer exhausted
 144
 145    41 IF (N4DONI.NE.N4ENDI)        GO TO 822
 146       ICARRL = 0
 147       IF (N4ENDI.LT.MAXREI-1)      GO TO 51
 148       IF (N4ENDI.GT.MAXREI-1)      GO TO 46
 149       MCARRL = LQ(L4STAI+MAXREI-1)
 150       IF (MCARRL.EQ.0)             GO TO 46
 151       ICARRL = 1
 152       JRECNO = IQ(KQSP+LQFI+33)
 153       JDSADR = N4ENDI
 154       JFAST  = IQ(KQSP+LBPARI-6)
 155 #if defined(CERNLIB_QDEBPRI)
 156       IF (LOGLVI.GE.3)  WRITE (IQLOG,9043) MCARRL
 157  9043 FORMAT (' FZIREC-  Saved LR length',I6,' across to next PhR')
 158 #endif
 159
 160    46 IF (IFIFOI.LE.1)  THEN
 161           CALL FZIPHR
 162 #if defined(CERNLIB_FZDACC)
 163         ELSEIF (IFIFOI.EQ.2)  THEN
 164           CALL FZIPHD
 165 #endif
 166 #if defined(CERNLIB_FZMEMORY)
 167         ELSEIF (IFIFOI.EQ.3) THEN
 168           CALL FZIPHM
 169 #endif
 170 #if defined(CERNLIB_FZALFA)
 171         ELSEIF (IFIFOI.EQ.4)  THEN
 172           CALL FZIPHA
 173 #endif
 174         ENDIF
 175
 176 C--       read failure ?
 177       IF (IFLAGI.NE.0)  THEN
 178           IF (IFLIN.GT.0)  THEN
 179               IF (JRETCD.EQ.1)  JRETCD=-1
 180             ENDIF
 181           GO TO 999
 182         ENDIF
 183
 184 C--       LR length last word of previous block ?
 185       IF (ICARRL.NE.0)  THEN
 186           N4ENDI = N4DONI - 1
 187           LQ(L4STAI+N4ENDI) = MCARRL
 188         ENDIF
 189
 190 C--       still discarding previous d/s ?
 191       IF (IFLIN.GT.0)  THEN
 192           IF (N4RESI.GT.0)         GO TO 34
 193         ENDIF
 194
 195 C----              Start new logical record
 196
 197    51 N4DONI = N4ENDI
 198       N4SKII = 0
 199       IF (N4ENDI.EQ.MAXREI-1)      GO TO 41
 200       IF (ICARRL.EQ.0)  THEN
 201           JRECNO = IQ(KQSP+LQFI+33)
 202           JDSADR = N4DONI
 203           JFAST  = IQ(KQSP+LBPARI-6)
 204         ENDIF
 205       ICARRL = 0
 206       L4CURI = L4STAI + N4DONI + 2
 207       IDI(1) = LQ(L4CURI-2)
 208       IDI(2) = LQ(L4CURI-1)
 209       IF (IDI(1).EQ.0)  IDI(2)=5
 210 #if defined(CERNLIB_QDEBPRI)
 211       IF (LOGLVI.GE.3)  WRITE (IQLOG,9053) JFAST,N4DONI,IDI
 212  9053 FORMAT (' FZIREC-  Start LR : Fast?, NWdone, Length, Type='
 213      F,I5,I6,I8,I3)
 214 #endif
 215       N4RESI = IDI(1)
 216       IF (N4RESI.LT.0)             GO TO 826
 217       IF (N4RESI.GT.NTOLDS)        GO TO 826
 218       IF (IDI(2).GE.5)             GO TO 57
 219       IF (IDI(2).EQ.4)             GO TO 53
 220
 221 C--                LR type 1, 2, 3
 222
 223       IF (IDI(2).LE.0)             GO TO 825
 224       IF (IFLIN.LT.0)              GO TO 824
 225       IF (JFAST.NE.0)              GO TO 827
 226       IQ(KQSP+LQFI+31) = JRECNO
 227       IQ(KQSP+LQFI+32) = JDSADR
 228
 229    53 N4DONI = N4DONI + 2
 230       N4ENDI = MIN (MAXREI, N4DONI+N4RESI)
 231       L4ENDI = L4STAI + N4ENDI
 232       NRECAI = NRECAI + 1
 233       IF (IFLIN.GE.0)              GO TO 77
 234       N4SKII = NSKISV
 235       GO TO 77
 236
 237 C--                Skip padding records
 238
 239    57 IF (IDI(2).GE.7)             GO TO 825
 240       IF (N4RESI.GT.MAXREI)        GO TO 828
 241       NLRPAD = NLRPAD + 1
 242       IF (NLRPAD.GE.5)             GO TO 829
 243       N4DONI = N4DONI + 1
 244       N4ENDI = MIN (MAXREI, N4DONI+N4RESI)
 245
 246       NWNEW  = MIN (N4ENDI-N4DONI, N4RESI)
 247       N4DONI = N4DONI + NWNEW
 248       N4RESI = N4RESI - NWNEW
 249       GO TO 41
 250
 251 C-----------------------------------------------------------
 252 C------            IFLAGI = -1 : ready continuation Ph / L record
 253 C-----------------------------------------------------------
 254
 255    61 ICARRY = 0
 256       N4DONI = L4CURI - L4STAI
 257       NWNEW  = N4DONI - IQ(KQSP+LBPARI-2)
 258       N4RESI = N4RESI - NWNEW
 259
 260       IF (N4DONI.EQ.MAXREI+1)  THEN
 261           ICARRY = 1
 262           MCARRY = LQ(L4CURI-2)
 263           N4RESI = N4RESI + 1
 264         ENDIF
 265
 266 #if defined(CERNLIB_QDEBPRI)
 267       IF (LOGLVI.GE.3)  WRITE (IQLOG,9061) N4RESI,N4DONI,MAXREI,ICARRY
 268  9061 FORMAT (1X/' FZIREC-  Need continuation PhR/LR, Buffer Status :'
 269      F/10X,'Rest LR, NWdone, NWbuf, NWcarry =',3I7,I4)
 270 #endif
 271
 272 C--                Start continuation LR
 273
 274       IF (N4RESI.EQ.0)  THEN
 275           NLRPAD = 0
 276           NSKISV = N4SKII
 277           N4SKII = 0
 278           GO TO 41
 279         ENDIF
 280
 281 C--                Get continuation PhR
 282
 283       IF (IFIFOI.LE.1)  THEN
 284           CALL FZIPHR
 285 #if defined(CERNLIB_FZDACC)
 286         ELSEIF (IFIFOI.EQ.2)  THEN
 287           CALL FZIPHD
 288 #endif
 289 #if defined(CERNLIB_FZMEMORY)
 290         ELSEIF (IFIFOI.EQ.3) THEN
 291           CALL FZIPHM
 292 #endif
 293 #if defined(CERNLIB_FZALFA)
 294         ELSEIF (IFIFOI.EQ.4)  THEN
 295           CALL FZIPHA
 296 #endif
 297         ENDIF
 298       IF (IFLAGI.NE.0)             GO TO 999
 299
 300       L4CURI = L4STAI + N4DONI
 301       L4ENDI = L4STAI + N4ENDI
 302
 303       IF (ICARRY.NE.0)  THEN
 304           N4RESI = N4RESI + 1
 305           N4DONI = N4DONI - 1
 306           L4CURI = L4CURI - 1
 307           LQ(L4CURI) = MCARRY
 308         ENDIF
 309       GO TO 77
 310
 311 C-----------------------------------------------------------
 312 C------            IFLAGI = 0 :  set buffer parameters
 313 C-----------------------------------------------------------
 314
 315    71 IF (L4STAI.NE.0)             GO TO 74
 316
 317 C--                Copy parameters from control bank to COMMON
 318
 319       N4SKII = IQ(KQSP+LBPARI-4)
 320       N4RESI = IQ(KQSP+LBPARI-3)
 321       N4DONI = IQ(KQSP+LBPARI-2)
 322       N4ENDI = IQ(KQSP+LBPARI-1)
 323       INCBUF = IQ(KQSP+LBPARI+2)
 324       L4STAI = KQSP+8 + LBPARI + INCBUF
 325       L4CURI = L4STAI + N4DONI
 326       L4ENDI = L4STAI + N4ENDI
 327       GO TO 999
 328
 329 C--                Up-date parameters in control bank
 330
 331    74 N4DONI = L4CURI - L4STAI
 332       NWNEW  = N4DONI - IQ(KQSP+LBPARI-2)
 333       N4RESI = N4RESI - NWNEW
 334
 335    77 IQ(KQSP+LBPARI-4) = N4SKII
 336       IQ(KQSP+LBPARI-3) = N4RESI
 337       IQ(KQSP+LBPARI-2) = N4DONI
 338       IQ(KQSP+LBPARI-1) = N4ENDI
 339
 340 #include "zebra/qtrace99.inc"
 341       RETURN
 342
 343 C-----------------------------------------------------------
 344 C-                 ERROR CONDITIONS
 345 C-----------------------------------------------------------
 346
 347 C-    JERROR = 221  LR overshoots physical record control
 348   821 JERROR = 221
 349       IQUEST(14) = N4DONI
 350       IQUEST(15) = N4RESI
 351       NWERR = 2
 352       GO TO 871
 353
 354 C-    JERROR = 222  LR undershoots physical record control
 355   822 JERROR = 222
 356       IQUEST(14) = N4DONI
 357       IQUEST(15) = N4ENDI
 358       NWERR = 2
 359       GO TO 871
 360
 361 C-    JERROR = 223  LR expected to start at start of new PhR
 362 C!823 JERROR = 223
 363 C!    IQUEST(14) = N4ENDI
 364 C!    NWERR = 1
 365 C!    GO TO 871
 366
 367 C-    JERROR = 224  LR type 1,2,3 seen when 4 expected
 368   824 JERROR = 224
 369       IQUEST(14) = N4ENDI
 370       NWERR = 1
 371       GO TO 871
 372
 373
 374 C-    JERROR = 225  Faulty LR type
 375   825 JERROR = -1
 376
 377 C-    JERROR = 226  Faulty LR length
 378   826 JERROR = JERROR - 1
 379
 380 C-    JERROR = 227  LR of type 1,2,3 must start on steering block
 381   827 JERROR = JERROR - 1
 382
 383 C-    JERROR = 228  Padding record longer than one physical record
 384   828 JERROR = JERROR - 1
 385
 386 C-    JERROR = 229  More than 4 padding records in a row
 387   829 JERROR = 229 + JERROR
 388
 389       IQUEST(14) = N4DONI
 390       IQUEST(15) = N4RESI
 391       IQUEST(16) = IDI(2)
 392       NWERR  = 3
 393       N4ENDI = 0
 394
 395   871 IQ(KQSP+LBPARI-9) = -2
 396       IFLAGI = -2
 397       JRETCD = 6
 398       GO TO 77
 399       END
 400 *      ==================================================
 401 #include "zebra/qcardl.inc"