MINICERN/packlib/zebra/fq/fzialn.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 #if defined(CERNLIB_FZALFA)
  11       SUBROUTINE FZIALN
  12
  13 C-    Read 80 characters to the card buffer;
  14 C-    service routine to FZIASC.
  15
  16 #include "zebra/zbcd.inc"
  17 #include "zebra/zkrakcc.inc"
  18 #include "zebra/zstate.inc"
  19 #include "zebra/zunit.inc"
  20 #include "zebra/mqsysh.inc"
  21 #include "zebra/fzci.inc"
  22 C--------------    End CDE                             --------------
  23       CHARACTER    LINER*80
  24       EQUIVALENCE (LINER,CQHOLK)
  25
  26       EQUIVALENCE   (LUN,IQUEST(90)), (JSKIP,IQUEST(91))
  27       EQUIVALENCE (MRSTA,IQUEST(92)), (MREND,IQUEST(93))
  28       EQUIVALENCE  (JTKC,IQUEST(96)),  (JTKL,IQUEST(97))
  29      +,            (JTKE,IQUEST(98))
  30
  31
  32 C--                Save trailing card buffer not yet analysed
  33
  34       JTKE  = JTKE - 1
  35       NSV   = JTKE - JTKC
  36       IWDSV = IQKRAK(JTKE)
  37
  38       IF (NSV.GT.0)  THEN
  39 #if defined(CERNLIB_FQABLANK)
  40           NSH = 160 - JTKE
  41           CALL UCOPY2 (IQKRAK(JTKC),IQKRAK(JTKC+NSH),NSV)
  42           JTKC = JTKC + NSH
  43           JTKE = 160
  44 #endif
  45           DO 18  J=JTKC,JTKE-1
  46    18     IQKRAK(J-79) = IQKRAK(J)
  47         ENDIF
  48
  49 C--                Read next line
  50
  51    21 CONTINUE
  52  8000 FORMAT (A)
  53 #if defined(CERNLIB_QERREND)
  54       READ (LUN,8000,END=81,ERR=82) LINER
  55 #endif
  56 #if !defined(CERNLIB_QERREND)
  57       READ (LUN,8000,IOSTAT=JSTAT) LINER
  58       IF (JSTAT.NE.0)              GO TO 81
  59 #endif
  60 #if defined(CERNLIB_QDEVZE)
  61       IF (LOGLVI.GE.3)  WRITE (IQLOG,9821) LINER
  62  9821 FORMAT (' FZIALN-  Read line=',A)
  63 #endif
  64
  65       CALL IZCHAV (80)
  66
  67       JSTA = 2
  68       NOFF = 6
  69
  70 C--                Check special conditions
  71
  72       IF (IQCETK(1).NE.45)         GO TO 41
  73       IF (JSKIP.NE.0)              GO TO 51
  74
  75 C--                Ready start/end pointers
  76
  77    26 IF (NSV.GE.0)  THEN
  78           JTKC = 81 - NSV
  79           IQCETK(1) = IWDSV
  80         ELSE
  81           JTKC = 80 + JSTA
  82         ENDIF
  83       JTKE = 161
  84
  85 C--                Purge blanks from line, if FQABLANK
  86
  87 #if defined(CERNLIB_FQABLANK)
  88       JTKE = 80 + JSTA
  89       DO 34  J=JSTA,80
  90       IF (IQCETK(J).EQ.45)         GO TO 34
  91       IQKRAK(JTKE) = IQCETK(J)
  92       JTKE = JTKE + 1
  93    34 CONTINUE
  94 #endif
  95       JTKL = JTKE - NOFF
  96       RETURN
  97
  98 C----              Control-line read
  99
 100 C--       End of physical record
 101
 102    41 IF (IQCETK(2).EQ.59)         GO TO 45
 103       IF (IQCETK(1).NE.60)         GO TO 91
 104       IF (JSKIP.NE.0)              GO TO 21
 105       MREND = 1
 106       NOFF  = 0
 107       GO TO 26
 108
 109 C--       Start of physical record
 110
 111    45 NSV   = -1
 112       MRSTA = 1
 113       IF (IQCETK(3).NE.27)  MRSTA=2
 114
 115       JSTA = 4
 116       IF (IQCETK(1).EQ.59)         GO TO 26
 117       IF (IQCETK(1).NE.60)         GO TO 91
 118       MREND = 1
 119       NOFF  = 0
 120       GO TO 26
 121
 122 C----              Fast skip of trailing record
 123
 124    51 CONTINUE
 125 #if defined(CERNLIB_QERREND)
 126       READ (LUN,8000,END=81,ERR=82) LINER(1:1)
 127 #endif
 128 #if !defined(CERNLIB_QERREND)
 129       READ (LUN,8000,IOSTAT=JSTAT) LINER(1:1)
 130       IF (JSTAT.NE.0)              GO TO 81
 131 #endif
 132 #if defined(CERNLIB_QDEVZE)
 133       IF (LOGLVI.GE.4)  WRITE (IQLOG,9852)
 134  9852 FORMAT (' FZIALN-  Skip line')
 135 #endif
 136
 137       IF (LINER(1:1).EQ.' ')       GO TO 51
 138       GO TO 21
 139
 140 C------            End-of-File, Read Error
 141
 142 #if defined(CERNLIB_QERREND)
 143    81 IQUEST(1) = -2
 144    82 IQUEST(1) = IQUEST(1) + 1
 145 #endif
 146 #if !defined(CERNLIB_QERREND)
 147    81 IQUEST(1) = JSTAT
 148 #endif
 149       RETURN
 150
 151 C----              Context error
 152
 153    91 IQUEST(1) = 7799
 154       RETURN
 155       END
 156 *      ==================================================
 157 #include "zebra/qcardl.inc"
 158 #endif