MINICERN/packlib/zebra/fq/fzoffx.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.3  1996/04/24 17:26:27  mclareni
   6 * Extend the include file cleanup to dzebra, rz and tq, and also add
   7 * dependencies in some cases.
   8 *
   9 * Revision 1.2  1996/04/18 16:10:48  mclareni
  10 * Incorporate changes from J.Zoll for version 3.77
  11 *
  12 * Revision 1.1.1.1  1996/03/06 10:47:14  mclareni
  13 * Zebra
  14 *
  15 *
  16 #include "zebra/pilot.h"
  17       SUBROUTINE FZOFFX (IUHEAD)
  18
  19 C-    Write to buffer operations for file format Exchange,
  20 C-    subsidiary to FZOUT
  21
  22 C-    Controlling parameter : IDX(2)
  23 C-
  24 C-    IDX(2)   = 1   write start/end-of-run
  25 C-             > 1   write pilot for d/s
  26 C-             = 0   write bank material for d/s
  27 C-             = -1  flush the buffer
  28 C-             = -2  End-of-File
  29 C-             = -3  End-of-Data
  30
  31 #include "zebra/zunit.inc"
  32 #include "zebra/mqsys.inc"
  33 #include "zebra/eqlqf.inc"
  34 #include "zebra/mzct.inc"
  35 #include "zebra/mzcn.inc"
  36 #include "zebra/mzioc.inc"
  37 #include "zebra/fzcx.inc"
  38 #include "zebra/fzcseg.inc"
  39 C--------------    End CDE                             --------------
  40       DIMENSION    IUHEAD(99)
  41 #if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
  42       DIMENSION    NAMESR(2)
  43       DATA  NAMESR / 4HFZOF, 4HFX   /
  44 #endif
  45 #if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
  46       DATA  NAMESR / 6HFZOFFX  /
  47 #endif
  48 #if !defined(CERNLIB_QTRHOLL)
  49       CHARACTER    NAMESR*8
  50       PARAMETER   (NAMESR = 'FZOFFX  ')
  51 #endif
  52 #if !defined(CERNLIB_FQXISN)
  53 #include "zebra/q_jbyt.inc"
  54 #endif
  55
  56 #include "zebra/qtraceq.inc"
  57
  58       IF   (IDX(2))          71, 41, 11
  59    11 IF (IDX(2).EQ.1)             GO TO 61
  60
  61 C-----------------------------------------------------------
  62 C------            WRITE PILOT INFORMATION, STARTING LR AND D/S
  63 C-----------------------------------------------------------
  64
  65       IDX(1) = 10 + NWUHCX + NWSEGX + NWTXX + NWTABX + NWBKX
  66 #if !defined(CERNLIB_FQXISN)
  67       IF (IDAFOX.EQ.0)             GO TO 31
  68
  69 C-----------------------------------------------------------
  70 C--                Pilot in exchange data format
  71 C-----------------------------------------------------------
  72
  73       MFO(1) = 3
  74       MFO(2) = 1
  75       MFO(3) = 1
  76       MFO(4) = -1
  77       JFOEND = 4
  78       CALL FZOTRX (IPILX, 10+NWIOX)
  79
  80 C--                User header
  81
  82       IF (NWUHCX.NE.0)  THEN
  83           CALL MZIOCR (IOCHX)
  84           CALL FZOTRX (IUHEAD, NWUHX)
  85         ENDIF
  86
  87 C--                Segment table
  88
  89       IF (NWSEGX.NE.0)  THEN
  90           MFO(1) = 5
  91           MFO(2) = -1
  92           JFOEND = 2
  93           CALL FZOTRX (IQSEGH, 2*NQSEG)
  94           MFO(1) = 1
  95           MFO(2) = -1
  96           CALL FZOTRX (IQSEGD, NQSEG)
  97         ENDIF
  98
  99 C--                Text vector
 100
 101       IF (NWTXX.NE.0)  THEN
 102           MFO(1) = 5
 103           MFO(2) = 0
 104           JFOEND = 2
 105           JFOREP = 0
 106           CALL FZOTRX (IQ(KQSP+LTEXTX+5), NWTXX)
 107         ENDIF
 108
 109 C--                Relocation table, only FZOUT, not FZCOPY
 110
 111       IF (ICOPYX.NE.0)             GO TO 39
 112       IF (NWTABX.NE.0)  THEN
 113           MFO(1) = 1
 114           MFO(2) = -1
 115           JFOEND = 2
 116           CALL FZOTRX (LQ(LQTA), NWTABX)
 117         ENDIF
 118       GO TO 39
 119 #endif
 120
 121 C-----------------------------------------------------------
 122 C--                Pilot in native data format
 123 C-----------------------------------------------------------
 124
 125    31 CALL FZOTRN (IPILX,10+NWIOX)
 126
 127 C--                User header
 128
 129       IF (NWUHCX.NE.0)  CALL FZOTRN (IUHEAD, NWUHX)
 130
 131 C--                Segment table
 132
 133       IF (NWSEGX.NE.0)  THEN
 134           CALL FZOTRN (IQSEGH, 2*NQSEG)
 135           CALL FZOTRN (IQSEGD,   NQSEG)
 136         ENDIF
 137
 138 C--                Text vector
 139
 140       IF (NWTXX.NE.0)  THEN
 141           CALL FZOTRN (IQ(KQSP+LTEXTX+5), NWTXX)
 142         ENDIF
 143
 144 C--                Relocation table, only FZOUT, not FZCOPY
 145
 146       IF (ICOPYX.NE.0)             GO TO 39
 147       IF (NWTABX.NE.0)  CALL FZOTRN (LQ(LQTA), NWTABX)
 148    39 IF (NWBKX.NE.0)              GO TO 999
 149       GO TO 991
 150
 151 C-----------------------------------------------------------
 152 C--                WRITE BANK MATERIAL
 153 C-----------------------------------------------------------
 154
 155    41 LTB    = LQTA
 156 #if !defined(CERNLIB_FQXISN)
 157       IF (IDAFOX.EQ.0)             GO TO 51
 158
 159 C-----------------------------------------------------------
 160 C--                Bank groups in exchange data format
 161 C-----------------------------------------------------------
 162
 163    42 L   = LQ(LTB)
 164       LE  = LQ(LTB+1)
 165
 166 C--                Next bank
 167
 168    44 IQLN = L
 169       IWD  = LQ(KQS+L)
 170       NST  = JBYT (IWD,1,16) - 12
 171       IF (NST.LT.0)                GO TO 48
 172
 173 C--                True bank
 174
 175       IQLS  = L + NST + 1
 176       IQNIO = JBYT (IQ(KQS+IQLS),19,4)
 177       IQNL  = IQ(KQS+IQLS-3)
 178       IQND  = IQ(KQS+IQLS-1)
 179       IQNX  = IQLS + IQND + 9
 180
 181 C-       first word, I/O words, links, next-link, up-link
 182       N = IQNIO + IQNL
 183       MFO(1) = 1
 184       MFO(2) = N + 3
 185
 186 C-       origin, numeric ID
 187       MFO(3) = 2
 188       MFO(4) = 2
 189
 190 C-       Hollerith ID
 191       MFO(5) = 5
 192       MFO(6) = 1
 193
 194 C-       NL, NS, ND, status
 195       MFO(7) = 1
 196       MFO(8) = -1
 197       JFOEND = 8
 198       CALL FZOTRX (LQ(KQS+L), N+10)
 199
 200 C-       data words
 201       IF (IQND.EQ.0)               GO TO 46
 202       CALL MZIOCR (LQ(KQS+IQLN))
 203       CALL FZOTRX (IQ(KQS+IQLS+1), IQND)
 204
 205    46 L = IQNX
 206       IF (L.LT.LE)                 GO TO 44
 207       LTB = LTB + 2
 208       IF (LTB.LT.LQTE)             GO TO 42
 209       GO TO 991
 210
 211 C--                Short dead region
 212
 213    48 NWD  = NST + 12
 214       IQNX = L + NWD
 215       MFO(1) = 1
 216       MFO(2) = -1
 217       JFOEND = 2
 218       CALL FZOTRX (LQ(KQS+L), NWD)
 219       GO TO 46
 220 #endif
 221
 222 C-----------------------------------------------------------
 223 C--                Bank-groups in native data format
 224 C-----------------------------------------------------------
 225
 226    51 L   = LQ(LTB)
 227       LE  = LQ(LTB+1)
 228       CALL FZOTRN (LQ(KQS+L), LE-L)
 229       LTB = LTB + 2
 230       IF (LTB.LT.LQTE)             GO TO 51
 231
 232   991 CALL FZOREC
 233 #include "zebra/qtrace99.inc"
 234       RETURN
 235
 236 C-----------------------------------------------------------
 237 C--                WRITE START/END-OF-RUN
 238 C-----------------------------------------------------------
 239
 240    61 JRUN  = IQUEST(11)
 241       NWUHU = IDX(1) - 1
 242 #if !defined(CERNLIB_FQXISN)
 243       IF (IDAFOX.EQ.0)             GO TO 64
 244       MFO(1) = 2
 245       MFO(2) = -1
 246       JFOEND = 2
 247       CALL FZOTRX (JRUN,1)
 248       IF (NWUHU.EQ.0)              GO TO 991
 249       CALL FZOTRX (IUHEAD,NWUHU)
 250       GO TO 991
 251 #endif
 252    64 CALL FZOTRN (JRUN,1)
 253       IF (NWUHU.NE.0)  CALL FZOTRN (IUHEAD,NWUHU)
 254       GO TO 991
 255
 256 C-----------------------------------------------------------
 257 C--                FLUSH BUFFER / ENDFILE
 258 C-----------------------------------------------------------
 259
 260    71 GO TO 991
 261       END
 262 *      ==================================================
 263 #include "zebra/qcardl.inc"