MINICERN/packlib/zebra/fq/fziphm.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.2  1996/04/18 16:10:40  mclareni
   6 * Incorporate changes from J.Zoll for version 3.77
   7 *
   8 * Revision 1.1.1.1  1996/03/06 10:47:11  mclareni
   9 * Zebra
  10 *
  11 *
  12 #include "zebra/pilot.h"
  13 #if defined(CERNLIB_FZMEMORY)
  14       SUBROUTINE FZIPHM
  15
  16 C-    Read next physical record from memory           .
  17 C-    Service routine to FZIN, called only via FZIREC
  18
  19 C-    Input :      IFLAGI = 0  normal read
  20 C-                         -1  recover to next steering block
  21
  22 C-                 N4SKII      is used for rapid skip of fast blocks
  23
  24 C-    Output :     IFLAGI = 0  all is well
  25 C-                             otherwise : ready for re-start
  26
  27 #include "zebra/zbcd.inc"
  28 #include "zebra/zmach.inc"
  29 #include "zebra/zunit.inc"
  30 #include "zebra/mqsys.inc"
  31 #include "zebra/eqlqf.inc"
  32 #include "zebra/fzci.inc"
  33 #include "fzhci.inc"
  34 C--------------    End CDE                             --------------
  35       EQUIVALENCE (LRTYP,IDI(2))
  36 *      Declaratives, DIMENSION etc.
  37 #include "fziphrd1.inc"
  38 * Ignoring t=pass
  39
  40 #include "fzstamp.inc"
  41 #if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
  42       DIMENSION    NAMESR(2)
  43       DATA  NAMESR / 4HFZIP, 4HHM   /
  44 #endif
  45 #if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
  46       DATA  NAMESR / 6HFZIPHM /
  47 #endif
  48 #if !defined(CERNLIB_QTRHOLL)
  49       CHARACTER    NAMESR*8
  50       PARAMETER   (NAMESR = 'FZIPHM  ')
  51 #endif
  52
  53 *      Declaratives, DATA
  54 #include "fziphrd2.inc"
  55
  56
  57 #include "zebra/qtrace.inc"
  58
  59 C----              Prepare to transfer next record
  60
  61       LBUF   = IQ(KQSP+LQFI+1)
  62       NWMREC = IQ(KQSP+LBPARI+1)
  63       NFASTI = IQ(KQSP+LBPARI-5)
  64       NRSKIP = 0
  65       NBLK   = IQ(KQSP+LQFI+22)
  66
  67 C--                Skip complete records
  68
  69       N4SKIP = MIN (N4SKII,N4RESI)
  70       IF (N4SKIP.LT.MAXREI)        GO TO 20
  71       IF (NFASTI.EQ.0)             GO TO 20
  72       NRSKIP = MIN (NFASTI, N4SKIP / MAXREI)
  73       NW4S   = NRSKIP * MAXREI
  74       NWMS   = NRSKIP * NWMREC
  75       LBUF   = LBUF   + NWMS
  76       N4SKII = N4SKII - NW4S
  77       N4RESI = N4RESI - NW4S
  78       NWRDAI = NWRDAI + NW4S
  79       NFASTI = NFASTI - NRSKIP
  80       NBLK   = NBLK   + NRSKIP
  81
  82    20 NW4IN  = MAXREI
  83       NWMIN  = NWMREC
  84
  85       IQ(KQSP+LBPARI-6) = NFASTI
  86
  87 C----              READ ONE PHYSICAL RECORD
  88
  89 #if defined(CERNLIB_QDEBPRI)
  90       IF (LOGLVI.GE.3)
  91      +      WRITE (IQLOG,9031) NBLK+1,NW4IN,NWMIN,NFASTI,NRSKIP
  92  9031 FORMAT (1X/' FZIPHM-  Reading Block',I7,
  93      F', NW32,NWmach,NRfast,NRskip=',4I6)
  94 #endif
  95
  96 C--                Copy, with unpacking or byte-swop if nec.
  97
  98 #if defined(CERNLIB_FQNEEDCV)
  99 #include "fziphm42.inc"
 100 #endif
 101    44 CALL UCOPY (LQ(LBUF),LQ(L4STAI),NW4IN)
 102    46 CONTINUE
 103
 104 C--                Short/full dump of record read
 105
 106 #if defined(CERNLIB_QDEBPRI)
 107       IF (LOGLVI.GE.3)  CALL FZIDUM (LQ(L4STAI),NW4IN)
 108 #endif
 109
 110 C-----------------------------------------------------------
 111 C----              FAST RECORD EXPECTED
 112 C-----------------------------------------------------------
 113
 114    51 IF (NFASTI.EQ.0)             GO TO 61
 115       NFASTI = NFASTI - 1
 116       N4DONI = 0
 117       N4ENDI = MIN (N4RESI,MAXREI)
 118
 119    58 NWRDAI = NWRDAI + MAXREI
 120       IQ(KQSP+LBPARI-5) = NFASTI
 121       IQ(KQSP+LQFI+22)  = NBLK + 1
 122       IQ(KQSP+LQFI+1)   = LBUF + NWMIN
 123       IFLAGI = 0
 124 #include "zebra/qtrace99.inc"
 125       RETURN
 126
 127 C-----------------------------------------------------------
 128 C----              STEERING RECORD EXPECTED
 129 C-----------------------------------------------------------
 130
 131    61 CALL FZICHH (0, LQ(L4STAI),0)
 132       IF (IQUEST(1).NE.0)          GO TO 64
 133
 134       N4DONI = 8
 135       N4ENDI = NTLRI
 136       IF (N4ENDI.EQ.0)  N4ENDI=MAXREI
 137       IQ(KQSP+LQFI+23) = IQ(KQSP+LQFI+23) + 1
 138       NFASTI = NFSTI
 139       GO TO 58
 140
 141 C----              Physical record length mis-match
 142 C--                Reset if possible
 143
 144    64 IF (IQUEST(1).NE.3)          GO TO 801
 145       IF (LBUF.NE.IQ(KQSP+LQFI+8))    GO TO 802
 146       CALL FZIPRL (0)
 147       IF (IQUEST(1).EQ.2)          GO TO 803
 148       IF (IQUEST(1).NE.0)          GO TO 802
 149       NWMREC = IQ(KQSP+LBPARI+1)
 150       GO TO 20
 151
 152
 153 C-----------------------------------------------------------
 154 C-                 ERROR CONDITIONS
 155 C-----------------------------------------------------------
 156
 157 C-    JERROR = 521  Block header faulty
 158   801 JERROR = 521
 159       GO TO 817
 160
 161 C-    JERROR = 522  Block size does not match expectation
 162   802 JERROR = -1
 163
 164 C-    JERROR = 523  Block size larger than buffer
 165   803 JERROR = JERROR + 523
 166       IQUEST(14) = MAXREI
 167       IQUEST(15) = NWRI
 168       NWERR = 2
 169
 170   817 IQ(KQSP+LBPARI-9) = -1
 171       IQ(KQSP+LBPARI-6) = 0
 172       IQ(KQSP+LBPARI-5) = 0
 173       IQ(KQSP+LBPARI-1) = 0
 174
 175       JRETCD = 6
 176       IFLAGI = 1
 177       GO TO 999
 178       END
 179 *      ==================================================
 180 #include "zebra/qcardl.inc"
 181 #endif