MINICERN/packlib/zebra/fq/fzoffn.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.2  1996/04/18 16:10:47  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_FZFFNAT)
  14       SUBROUTINE FZOFFN (IUHEAD)
  15
  16 C-    Write operations for file format native,
  17 C-    subsidiary to FZOUT
  18
  19 C-    Controlling parameter : IDX(2)
  20 C-
  21 C-    IDX(2)   = 1   write start/end-of-run
  22 C-             > 1   write pilot for d/s
  23 C-             = 0   write bank material for d/s
  24 C-            (= -1  flush the buffer in exchange mode)
  25 C-             = -2  End-of-File
  26 C-             = -3  End-of-Data
  27
  28 #include "zebra/zunit.inc"
  29 #include "zebra/mqsys.inc"
  30 #include "zebra/eqlqf.inc"
  31 #include "zebra/mzct.inc"
  32 #include "zebra/mzcwk.inc"
  33 #include "zebra/fzcx.inc"
  34 #include "zebra/fzcseg.inc"
  35 C--------------    End CDE                             --------------
  36       DIMENSION    IUHEAD(99)
  37       DIMENSION    LV(6), NV(6)
  38       EQUIVALENCE (L1,LV(1)), (L2,LV(2)), (L3,LV(3))
  39      +,           (L4,LV(4)), (L5,LV(5)), (L6,LV(6))
  40 #if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
  41       DIMENSION    NAMESR(2)
  42       DATA  NAMESR / 4HFZOF, 4HFN   /
  43 #endif
  44 #if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
  45       DATA  NAMESR / 6HFZOFFN /
  46 #endif
  47 #if !defined(CERNLIB_QTRHOLL)
  48       CHARACTER    NAMESR*8
  49       PARAMETER   (NAMESR = 'FZOFFN  ')
  50 #endif
  51
  52
  53 #include "zebra/qtrace.inc"
  54
  55       IF   (IDX(2))          401, 201, 101
  56   101 IF (IDX(2).EQ.1)             GO TO 301
  57
  58 C-----------------------------------------------------------
  59 C------            WRITE PILOT INFORMATION, STARTING LR AND D/S
  60 C-----------------------------------------------------------
  61
  62       NWMAX  = MIN (MAXREX,1020)
  63       NWPILA = 10 + NWIOX
  64       NW     = NWPILA
  65       JSEND  = 0
  66       JDONE  = -1
  67
  68 C--                Do user header
  69
  70       NW  = NW + NWUHX
  71
  72 C--                Do segment table
  73
  74       IF (NWSEGX.NE.0)  THEN
  75           NW    = NW + NWSEGX
  76           JSEND = 2
  77           LV(1) = LOCF (IQSEGH(1,1)) - LQASTO
  78           LV(2) = LV(1) + 40
  79           NV(1) = 2*NQSEG
  80           NV(2) =   NQSEG
  81         ENDIF
  82
  83 C--                Do text vector
  84
  85       IF (NWTXX.NE.0)  THEN
  86           LTX   = LTEXTX
  87           NW    = NW + NWTXX
  88           IF (NW.GT.NWMAX)         GO TO 127
  89           JSEND = JSEND + 1
  90           LV(JSEND) = KQSP+8 + LTX + 5
  91           NV(JSEND) = NWTXX
  92         ENDIF
  93       JDONE = 0
  94
  95 C--                Do early table
  96
  97       IF (NWTABX.GE.41)            GO TO 127
  98       NW = NW + NWTABX
  99       IF (NW.GT.NWMAX)             GO TO 127
 100
 101       IF (NWTABX.NE.0)  THEN
 102           JSEND = JSEND + 1
 103           LV(JSEND) = LQTA
 104           NV(JSEND) = NWTABX
 105         ENDIF
 106       JDONE = 1
 107
 108 C--                Transmit pilot record
 109
 110   127 N  = NWPILA
 111       NU = NWUHX
 112       JSEND = JSEND + 1
 113       IF (NU.NE.0)  GO TO ( 140, 141, 142, 143, 144), JSEND
 114                     GO TO ( 130, 131, 132, 133, 134), JSEND
 115
 116   130 CALL FZON1 (IPILX,N)
 117       GO TO 149
 118
 119   131 CALL FZON2 (IPILX,N,LQ(L1),NV(1))
 120       GO TO 149
 121
 122   132 CALL FZON3 (IPILX,N,LQ(L1),NV(1),LQ(L2),NV(2))
 123       GO TO 149
 124
 125   133 CALL FZON4 (IPILX,N,LQ(L1),NV(1),LQ(L2),NV(2),LQ(L3),NV(3))
 126       GO TO 149
 127
 128   134 CALL FZON5 (IPILX,N,LQ(L1),NV(1),LQ(L2),NV(2),LQ(L3),NV(3)
 129      +,                   LQ(L4),NV(4))
 130       GO TO 149
 131
 132   140 CALL FZON2 (IPILX,N,IUHEAD,NU)
 133       GO TO 149
 134
 135   141 CALL FZON3 (IPILX,N,IUHEAD,NU,LQ(L1),NV(1))
 136       GO TO 149
 137
 138   142 CALL FZON4 (IPILX,N,IUHEAD,NU,LQ(L1),NV(1),LQ(L2),NV(2))
 139       GO TO 149
 140
 141   143 CALL FZON5 (IPILX,N,IUHEAD,NU,LQ(L1),NV(1),LQ(L2),NV(2)
 142      +,                   LQ(L3),NV(3))
 143       GO TO 149
 144
 145   144 CALL FZON6 (IPILX,N,IUHEAD,NU,LQ(L1),NV(1),LQ(L2),NV(2)
 146      +,                   LQ(L3),NV(3),LQ(L4),NV(4))
 147
 148   149 IDX(2) = 4
 149       IQUEST(7) = JDONE
 150       IF   (JDONE)           171, 181, 999
 151
 152 C----              Pilot continuation: text/table
 153
 154   171 IF (NWTABX.GE.41)            GO TO 174
 155       IF (NWTABX.EQ.0)             GO TO 174
 156       IF (NWTXX+NWTABX.GT.MAXREX)  GO TO 174
 157       CALL FZON2 (IQ(KQSP+LTX+5),NWTXX,LQ(LQTA),NWTABX)
 158       IQUEST(7) = 1
 159       GO TO 999
 160
 161   174 CALL FZON1 (IQ(KQSP+LTX+5),NWTXX)
 162
 163 C--                Pilot continuation: table only  (only FZOUT)
 164
 165   181 IF (NWTABX.EQ.0)             GO TO 999
 166       IF (ICOPYX.NE.0)             GO TO 999
 167       NT = NWTABX
 168       L  = LQTA
 169   182 N  = MIN (NT,MAXREX)
 170       CALL FZON1 (LQ(L),N)
 171       L  = L  + N
 172       NT = NT - N
 173       IF (NT.NE.0)                 GO TO 182
 174
 175 #include "zebra/qtrace99.inc"
 176       RETURN
 177
 178 C-----------------------------------------------------------
 179 C--                WRITE BANK MATERIAL
 180 C-----------------------------------------------------------
 181
 182   201 MINREC = MAXREX/2
 183       LTEMPX = 0
 184       LTB    = LQTA
 185       JSEG   = 0
 186       NDOSG  = 0
 187       IF (NQSEG.EQ.0)  NDOSG=NWBKX
 188       IDX(2) = 7
 189 #if defined(CERNLIB_QDEVZE)
 190       IF (LOGLVX.GE.5)  WRITE (IQLOG,9801)
 191  9801 FORMAT (' FZOFFN-  Entered for bank material.')
 192 #endif
 193
 194   242 JSEND = 0
 195       NWS   = 0
 196
 197 C--                Load next sector
 198
 199   243 L     = LQ(LTB)
 200       LE    = LQ(LTB+1)
 201       N     = LE - L
 202       JSEND = JSEND + 1
 203       LV(JSEND) = L
 204       NV(JSEND) = N
 205
 206       NWS = NWS + N
 207       NOV = NWS - MAXREX
 208       LTB = LTB + 2
 209
 210 C--                Next segment ?
 211
 212       IF (NDOSG.EQ.0)  THEN
 213           JSEG  = JSEG + 1
 214           NDOSG = IQSEGD(JSEG)
 215         ENDIF
 216       NDOSG = NDOSG - N
 217
 218 C--                Send ?
 219
 220       IF (NOV.GT.0)                GO TO 261
 221       IF (LTB.EQ.LQTE)             GO TO 268
 222       IF (NDOSG.EQ.0)              GO TO 270
 223       IF (NOV.GE.-10)              GO TO 270
 224       IF (JSEND.LT.6)              GO TO 243
 225       IF (NWS.GE.MINREC)           GO TO 270
 226
 227 C--                6 sectors have less than MINREC words
 228 C--                Compact to TEMP buffer
 229
 230       IF (LTEMPX.EQ.0)  LTEMPX = LQWKFZ - KQS
 231
 232       LOV = LTEMPX
 233       NOV = 0
 234       JGO = 1
 235       IF (LV(1).EQ.LTEMPX)  THEN
 236           NOV = NV(1)
 237           JGO = 2
 238         ENDIF
 239
 240       DO 256  J=JGO,6
 241       L = LV(J)
 242       N = NV(J)
 243       CALL UCOPY (LQ(KQS+L),LQ(KQS+LOV+NOV),N)
 244   256 NOV = NOV + N
 245       LV(1) = LOV
 246       NV(1) = NOV
 247
 248   257 JSEND = 1
 249       NWS   = NV(1)
 250       GO TO 243
 251
 252 C--                Last sector overflows MAXREX words
 253
 254   261 N   = N - NOV
 255       LOV = L + N
 256       NV(JSEND) = N
 257       GO TO 270
 258
 259 C--                End of material, with overflow on last sector
 260
 261   267 JSEND = 1
 262
 263 C--                End of material reached, send last record
 264
 265   268 IDX(2) = 8
 266
 267 C------            Write 1 record
 268
 269   270 GO TO ( 271, 272, 273, 274, 275, 276), JSEND
 270
 271   271 CALL FZON1 (LQ(KQS+L1),NV(1))
 272       GO TO 279
 273   272 CALL FZON2 (LQ(KQS+L1),NV(1),LQ(KQS+L2),NV(2))
 274       GO TO 279
 275   273 CALL FZON3 (LQ(KQS+L1),NV(1),LQ(KQS+L2),NV(2),LQ(KQS+L3),NV(3))
 276       GO TO 279
 277   274 CALL FZON4 (LQ(KQS+L1),NV(1),LQ(KQS+L2),NV(2),LQ(KQS+L3),NV(3),
 278      +            LQ(KQS+L4),NV(4))
 279       GO TO 279
 280   275 CALL FZON5 (LQ(KQS+L1),NV(1),LQ(KQS+L2),NV(2),LQ(KQS+L3),NV(3),
 281      +            LQ(KQS+L4),NV(4),LQ(KQS+L5),NV(5))
 282       GO TO 279
 283   276 CALL FZON6 (LQ(KQS+L1),NV(1),LQ(KQS+L2),NV(2),LQ(KQS+L3),NV(3),
 284      +            LQ(KQS+L4),NV(4),LQ(KQS+L5),NV(5),LQ(KQS+L6),NV(6))
 285
 286 C----              Overflow material pending ?
 287
 288   279 IF (IDX(2).EQ.8)             GO TO 999
 289       IF (NOV.LE.0)                GO TO 242
 290       LV(1) = LOV
 291       NV(1) = NOV
 292       NOV   = NOV - MAXREX
 293       IF (NOV.GT.0)                GO TO 282
 294
 295 C--                End of all material ?
 296
 297       IF (LTB.EQ.LQTE)             GO TO 267
 298       IF (NOV.EQ.0)                GO TO 271
 299
 300 C--                End of segment ?
 301
 302       IF (NDOSG.NE.0)              GO TO 257
 303       GO TO 271
 304
 305 C--                Overflow on overflow
 306
 307   282 NV(1) = MAXREX
 308       LOV   = LOV + MAXREX
 309       GO TO 271
 310
 311 C-----------------------------------------------------------
 312 C--                WRITE START/END-OF-RUN
 313 C-----------------------------------------------------------
 314
 315   301 JRUN   = IQUEST(11)
 316       NWUHU  = IDX(1) - 1
 317       IF (NWUHU.NE.0)  THEN
 318           CALL FZON2 (JRUN,1,IUHEAD,NWUHU)
 319         ELSE
 320           CALL FZON1 (JRUN,1)
 321         ENDIF
 322       GO TO 999
 323
 324 C-----------------------------------------------------------
 325 C--                ENDFILE
 326 C-----------------------------------------------------------
 327
 328 C-        NEOF = 1  EoF 1 only       IDX(1) = -2  EoF
 329 C-               2  EOF 2 only                -3  EoD
 330 C-               3  EOF 1 + 2
 331
 332   401 NEOFU = IQUEST(11)
 333       NEOF  = IQUEST(12)
 334       IQUEST(11) = NEOFU
 335       NEOF = NEOFU
 336   412 ENDFILE LUNX
 337       NEOF = NEOF - 1
 338       IF (NEOF.GT.0)               GO TO 412
 339 #if defined(CERNLIB_QPRINT)
 340       IF (LOGLVX.GE.0)   WRITE (IQLOG,9414) LUNX,IQUEST(11)
 341  9414 FORMAT (' FZOFFN.  LUN=',I4,' Write',I2,' System EOF')
 342 #endif
 343       GO TO 999
 344       END
 345 *      ==================================================
 346 #include "zebra/qcardl.inc"
 347 #endif