MINICERN/packlib/zebra/fq/fzichh.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.2  1996/04/18 16:10:28  mclareni
   6 * Incorporate changes from J.Zoll for version 3.77
   7 *
   8 * Revision 1.1.1.1  1996/03/06 10:47:10  mclareni
   9 * Zebra
  10 *
  11 *
  12 #include "zebra/pilot.h"
  13       SUBROUTINE FZICHH (IOMODE,MREC,IHOW)
  14
  15 C-    Check physical block header in MREC
  16
  17 C-     in :  IHOW = 1  fast block expected
  18 C-                  0  steering block expected
  19 C-                 -1  scanning for next steering block
  20 C-                 -2  steering block expected when starting
  21
  22 C-    out :  IRETN in IQUEST(1)
  23 C-           IRETN = 0  as expected
  24 C-                   1  trouble
  25 C-                   3  steering block ok, but with wrong length
  26 C-                   4  end-of-file reached (only IBM just now)
  27
  28
  29 #include "zebra/zunit.inc"
  30 #include "zebra/quest.inc"
  31 #include "zebra/fzcx.inc"
  32 #include "zebra/fzci.inc"
  33 #include "fzhci.inc"
  34 C--------------    End CDE                             --------------
  35       DIMENSION    MREC(8)
  36 #include "fzstamp.inc"
  37 #include "fzntolds.inc"
  38 #if defined(CERNLIB_QMIBM)||defined(CERNLIB_QMIBMD)
  39 C     PARAMETER   (MASK   = Z FF000000)
  40       PARAMETER   (MASK   =  -16777216)
  41 #endif
  42
  43 #include "zebra/q_jbyt.inc"
  44
  45
  46       IRETN = 0
  47       CALL UCOPY (MREC,MPHRI,8)
  48       JMODI = JBYT(MPHRI(5),30,3)
  49       NWRI  = JBYT(MPHRI(5),1,28)
  50       IF (MPHRI(1) .NE. MCCW1)     GO TO 71
  51       IF (MPHRI(2) .NE. MCCW2)     GO TO 71
  52       IF (MPHRI(3) .NE. MCCW3)     GO TO 71
  53       IF (MPHRI(4) .NE. MCCW4)     GO TO 71
  54       IF (JMODI.GE.5)              GO TO 71
  55       IF (JMODI.EQ.3)              GO TO 71
  56       IF (NWRI.GE.NTOLDS)          GO TO 71
  57
  58       IF (JRECI.LT.0)              GO TO 71
  59       IF (NTLRI.LT.0)              GO TO 71
  60       IF (NTLRI.GT.NWRI)           GO TO 71
  61       IF (NFSTI.LT.0)              GO TO 71
  62       IF (NFSTI.GE.16384)          GO TO 71
  63       IF (IOMODE.NE.0)             GO TO 26
  64       IF (NFSTI*MAXREI.GT.NTOLDS)  GO TO 71
  65       IF (NWRI.NE.MAXREI)          GO TO 61
  66
  67    26 IF (IHOW.GT.0)               GO TO 41
  68    27 IQUEST(1) = IRETN
  69       RETURN
  70
  71 C----              Unexpected steering block
  72
  73    41 IRETN = 1
  74       GO TO 27
  75
  76 C----              Steering block of unexpected length
  77
  78    61 IF (IHOW.LE.0)  IRETN = 3
  79       GO TO 27
  80
  81 C----              Not a steering block
  82
  83    71 IF (IHOW.GT.0)               GO TO 27
  84 #if defined(CERNLIB_QMIBM)||defined(CERNLIB_QMIBMD)
  85
  86 C----     IBM :  detect end-of-file on direct-access file if :
  87 C--                1) file-format D
  88 C--                2) just after Zebra EoF
  89 C--                3) record starts with FF000000, rest zero
  90
  91       IF (IOMODE.NE.0)             GO TO 74
  92       IF (IFIFOI.NE.2)             GO TO 74
  93       IF (IACTVI.NE.4)             GO TO 74
  94       IF (MPHRI(1).NE.MASK)        GO TO 74
  95       DO 73  J=2,8
  96       IF (MREC(J).NE.0)            GO TO 74
  97    73 CONTINUE
  98       IRETN = 4
  99       GO TO 27
 100
 101 #endif
 102    74 IRETN = 1
 103 #if defined(CERNLIB_QPRINT)
 104       IF (IHOW.EQ.-1)              GO TO 27
 105       IF (LOGLVI.LT.-1)            GO TO 27
 106       LUN = LUNI
 107       IF (IOMODE.NE.0)  LUN = LUNX
 108       IQUEST(1) = MCCW1
 109       IQUEST(2) = MCCW2
 110       IQUEST(3) = MCCW3
 111       IQUEST(4) = MCCW4
 112       CALL UCOPY (MPHRI,  IQUEST(5), 8)
 113       IQUEST(13) = NWRI
 114       CALL UCOPY (JRECI,  IQUEST(14),3)
 115       WRITE (IQLOG,9801) LUN,(IQUEST(J),J=1,16)
 116  9801 FORMAT (1X/' FZIPHx.  LUN=',I4,', Error 201, dump Block Header :'
 117 #endif
 118 #if (defined(CERNLIB_QPRINT))&&(!defined(CERNLIB_HEX))&&(defined(CERNLIB_B60M))
 119      F/4X,'Must be:',4O23
 120      F/4X,'Oct 1-4:',4O23/8X,'5-8:',4O23/4X,'Dec 5-8:',4I23)
 121 #endif
 122 #if (defined(CERNLIB_QPRINT))&&(!defined(CERNLIB_HEX))&&(!defined(CERNLIB_B60M))
 123      F/4X,'Must be:',4O17
 124      F/4X,'Oct 1-4:',4O17/8X,'5-8:',4O17/4X,'Dec 5-8:',4I17)
 125 #endif
 126 #if (defined(CERNLIB_QPRINT))&&(defined(CERNLIB_HEX))
 127      F/4X,'Must be:',4Z17
 128      F/4X,'Hex 1-4:',4Z17/8X,'5-8:',4Z17/4X,'Dec 5-8:',4I17)
 129 #endif
 130       GO TO 27
 131       END