MINICERN/packlib/zebra/fq/fzout.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.2  1996/04/18 16:10:51  mclareni
   6 * Incorporate changes from J.Zoll for version 3.77
   7 *
   8 * Revision 1.1.1.1  1996/03/06 10:47:13  mclareni
   9 * Zebra
  10 *
  11 *
  12 #include "zebra/pilot.h"
  13       SUBROUTINE FZOUT (LUNP,IXDIVP,LENTP,IEVP,CHOPT,NIOP,NUHP,IUHEAD)
  14
  15 C-    MAIN SEQUENTIAL OUTPUT ROUTINE, USER CALLED
  16
  17 #include "zebra/zstate.inc"
  18 #include "zebra/zunit.inc"
  19 #include "zebra/zvfaut.inc"
  20 #include "zebra/mqsys.inc"
  21 #include "zebra/eqlqf.inc"
  22 #include "zebra/mzct.inc"
  23 #include "zebra/fzcx.inc"
  24 C--------------    End CDE                             --------------
  25       DIMENSION    LUNP(9),IXDIVP(9),LENTP(9),IEVP(9)
  26       DIMENSION    NIOP(9),NUHP(9),IUHEAD(99)
  27       CHARACTER    CHOPT*(*)
  28       DIMENSION    IUHDAT(3)
  29 #if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
  30       DIMENSION    NAMESR(2)
  31       DATA  NAMESR / 4HFZOU, 4HT    /
  32 #endif
  33 #if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
  34       DATA  NAMESR / 6HFZOUT  /
  35 #endif
  36 #if !defined(CERNLIB_QTRHOLL)
  37       CHARACTER    NAMESR*8
  38       PARAMETER   (NAMESR = 'FZOUT   ')
  39 #endif
  40
  41 #include "zebra/q_jbit.inc"
  42 #include "zebra/q_jbyt.inc"
  43
  44 #include "zebra/qtrace.inc"
  45
  46       LUNNX   = LUNP(1)
  47       IXDIVX  = IXDIVP(1)
  48       LENTRX  = LENTP(1)
  49       IEVFLX  = IEVP(1)
  50       IOCHX(1)= NIOP(1)
  51       NWUHOR  = MAX (NUHP(1),0)
  52       NWUHX   = MIN (NWUHOR,400)
  53       NWFILX  = 0
  54       NWMEMT  = 0
  55       ICOPYX  = 0
  56
  57 C--                Set current output unit
  58
  59       IF (LUNNX.NE.LUNX)  CALL FZLOC (LUNNX,2)
  60 #if defined(CERNLIB_QDEBPRI)
  61       IF (LOGLVX.GE.3)
  62      +   WRITE (IQLOG,9111) LUNNX,LENTRX,IEVFLX,IACTVX,CHOPT
  63  9111 FORMAT (1X/' FZOUT-   Enter for LUN=',I3,
  64      F' LENTRY,IEVFL,IACTV,OPT=',I8,2I3,1X,A)
  65
  66 #endif
  67 #if defined(CERNLIB_QDEBUG)
  68       IF (IQVSTA.NE.0)       CALL ZVAUTX
  69 #endif
  70 #if defined(CERNLIB_QPRINT)
  71       IF (NWUHOR.GT.NWUHX)  THEN
  72           IF (LOGLVX.GE.-2)  WRITE (IQLOG,9112) LUNX,NWUHOR
  73         ENDIF
  74  9112 FORMAT (1X/' FZOUT.   LUN=',I4,' Of ',I4,' user header words',
  75      F' only 400 are taken !!!')
  76 #endif
  77 #if defined(CERNLIB_FZCHANNEL)
  78       IF (IACMOX.EQ.3)  THEN
  79           IF (IADOPX.EQ.0)         GO TO 907
  80         ENDIF
  81
  82 #endif
  83 #if defined(CERNLIB_FZMEMORY)
  84       IF (IFIFOX.EQ.3)  THEN
  85           IADOPX = IQ(KQSP+LQFX+8)
  86           IF (IADOPX.EQ.0)         GO TO 907
  87           IQ(KQSP+LQFX+1) = IADOPX
  88         ENDIF
  89
  90 #endif
  91 C-      from FZRUN to 401
  92       IF (IEVFLX.LT.0)             GO TO 401
  93 C-      from FZENDO to 411
  94       IF (IEVFLX.GE.2)             GO TO 411
  95       IF (IACTVX.GE.16)            GO TO 901
  96
  97    21 NWTXX   = 0
  98       NWSEGX  = 0
  99       NWTABX  = 0
 100       NWBKX   = 0
 101       NWUHCX  = 0
 102       NWIOX   = 0
 103
 104 C--                Ready I/O characteristic
 105
 106       IF (NWUHX.EQ.0)              GO TO 39
 107
 108       IF   (IOCHX(1))        34, 32, 33
 109    32 IOCHX(1) = 3
 110    33 NWIOX = 1
 111       IF (IOCHX(1).LT.8)           GO TO 38
 112    34 NWIOX = JBYT (IOCHX(1), 7,5)
 113       J     = JBYT (IOCHX(1),12,5)
 114       IF     (JBYT (IOCHX(1), 1,6).NE.1)  GO TO 903
 115       IF (NWIOX.GT.16)             GO TO 903
 116       IF (NWIOX.NE.J+1)            GO TO 903
 117
 118       IF (NWIOX.GT.1)  CALL UCOPY (NIOP,IOCHX,NWIOX)
 119    38 NWUHCX = NWUHX + NWIOX
 120    39 CONTINUE
 121
 122 C----              Ready text vector
 123
 124       LTEXTX = LQ(KQSP+LQFX-2)
 125       IF (LTEXTX.NE.0)  CALL FZOTXT
 126
 127 C----              Construct table of material to be written
 128
 129       CALL UOPTC (CHOPT,'DISZMLNP',IOPTXD)
 130       IOPTXN = IOPTXN + IOPTXS + IOPTXZ
 131
 132       IF (IOPTXZ.NE.0)             GO TO 121
 133
 134       CALL MZSDIV (IXDIVX,0)
 135       JQSTMV = -1
 136       MODTBX = 0
 137       JFLGAX = 0
 138       CALL FZOTAB
 139       IF (IQUEST(1).NE.0)          GO TO 999
 140       IF (IOPTXN.NE.0)  NWTABX=0
 141
 142 C------            Output of pilot records
 143
 144   121 IDX(2) = 3
 145       IF (IEVFLX.NE.0)  IDX(2)=2
 146       NWMEMT = 20 + NWUHCX + NWSEGX + NWTXX + NWTABX + NWBKX
 147
 148 #if defined(CERNLIB_QDEBPRI)
 149       IF (LOGLVX.EQ.2)
 150      +WRITE (IQLOG,9121) LUNX,JQSTOR,LENTRX,NWTABX,NWBKX,IEVFLX,CHOPT
 151  9121 FORMAT (' FZOUT-   LUN=',I4,' Store/LENTRY=',I3,I9,
 152      F' NWTAB,NWBANK=',I5,I7,' Evfl/Opt=',I3,1X,A)
 153
 154 #endif
 155 #if defined(CERNLIB_FZFFNAT)
 156       IF (IFIFOX.EQ.0)  THEN
 157           CALL FZOFFN (IUHEAD)
 158           GO TO 124
 159         ENDIF
 160 #endif
 161 #if defined(CERNLIB_FZMEMORY)
 162       IF (IFIFOX.EQ.3)  THEN
 163           IF (NWMEMT.GT.IQ(KQSP+LQFX+9))      GO TO 909
 164         ENDIF
 165 #endif
 166       CALL FZOFFX (IUHEAD)
 167   124 IQ(KQSP+LQFX+15) = IQ(KQSP+LQFX+15) + 1
 168
 169       IACTVX  = 12
 170       IF (NWBKX.EQ.0)              GO TO 190
 171
 172 C------            Write out material according to table
 173
 174 #if defined(CERNLIB_QDEBPRI)
 175       IF (LOGLVX.GE.3)  WRITE (IQLOG,9140) NWTABX,NWBKX
 176  9140 FORMAT (10X,'NWTAB/NWBK =',2I9)
 177 #endif
 178       IQ(KQSP+LQFX+16) = IQ(KQSP+LQFX+16) + 1
 179
 180       IDX(2) = 0
 181 #if defined(CERNLIB_FZFFNAT)
 182       IF (IFIFOX.EQ.0)  THEN
 183           CALL FZOFFN (0)
 184           GO TO 191
 185         ENDIF
 186 #endif
 187       CALL FZOFFX (0)
 188       GO TO 191
 189
 190 C----              Test for pseudo end-of-tape
 191
 192   190 IQ(KQSP+LQFX+17) = IQ(KQSP+LQFX+17) + 1
 193   191 NUM1 = IQ(KQSP+LQFX+19)
 194       NUM2 = IQ(KQSP+LQFX+20)
 195   192 IF (NUM2.GE.1000000)  THEN
 196           NUM1 = NUM1 + 1
 197           NUM2 = NUM2 - 1000000
 198           IQ(KQSP+LQFX+19) = NUM1
 199           IQ(KQSP+LQFX+20) = NUM2
 200           GO TO 192
 201         ENDIF
 202
 203       LIM1 = IQ(KQSP+LQFX+37)
 204       LIM2 = IQ(KQSP+LQFX+38)
 205
 206       IF (LIM1+LIM2.EQ.0)          GO TO 991
 207       IF (NUM1-LIM1)         991, 196, 197
 208   196 IF (NUM2.LT.LIM2)            GO TO 991
 209
 210   197 IQUEST(1) = 1
 211       GO TO 992
 212
 213 C-------------------------------------------------
 214 C-                 Write start-of-run
 215 C-                 Write end-of-run, end-of-file
 216 C-------------------------------------------------
 217
 218 C-      from FZRUN to 401
 219   401 JRUN   = LENTRX
 220       JRUNCR = IQ(KQSP+LQFX+29)
 221       IF (JRUN.LT.0)               GO TO 410
 222       IF (IACTVX.LT.11)            GO TO 406
 223       IF (IACTVX.GE.14)            GO TO 406
 224       JTRA  = 1
 225       NWUHU = 0
 226 C-      precede start-of-run by end-of-run
 227       GO TO 422
 228
 229 C--                Write start-of-run
 230
 231   406 IACTVX = 11
 232       JRUNX  = 1
 233       JRUN   = LENTRX
 234       IF (JRUN.EQ.0)  JRUN=JRUNCR+1
 235       IQ(KQSP+LQFX+29) = JRUN
 236       IQ(KQSP+LQFX+14) = IQ(KQSP+LQFX+14) + 1
 237 #if defined(CERNLIB_QPRINT)
 238       IF (LOGLVX.GE.0)  WRITE (IQLOG,9406) LUNX,JRUN
 239  9406 FORMAT (1X/' FZOUT.   LUN=',I4,' Write Start-of-Run ',I6)
 240 #endif
 241       JTRA  = 2
 242       NWUHU = NWUHX
 243       GO TO 424
 244
 245 C-  IACTV : last action            IEVFL : action requested
 246 C-
 247 C-     11   StoR written
 248 C-     12   d/s written
 249 C-     13   buffer flushed            13   flush buffer
 250 C-     14   EOR written               14   write EOR
 251 C-     15   first  EOF written        15   write EoF
 252 C-     16   second EOF written        16   write EoD
 253 C-     17   attempted write after eod
 254
 255   410 IEVFLX = 14
 256 C-      from FZENDO to 411
 257   411 IF (IEVFLX.LT.13)            GO TO 902
 258       IF (IEVFLX.GE.17)            GO TO 902
 259       IF (IACTVX.LT.11)            GO TO 991
 260       IF (IEVFLX.LE.IACTVX)        GO TO 991
 261
 262       IF (IEVFLX.GE.14)            GO TO 421
 263       IACTVX = 13
 264       JTRA   = 3
 265       GO TO 441
 266
 267 C----              Write end-of-run
 268
 269   421 IF (IACTVX.GE.14)            GO TO 461
 270       JRUNCR = IQ(KQSP+LQFX+29)
 271       JTRA   = 4
 272       NWUHU  = NWUHX
 273
 274   422 IQ(KQSP+LQFX+13) = IQ(KQSP+LQFX+13) + 1
 275 #if defined(CERNLIB_QPRINT)
 276       IF (LOGLVX.GE.0)  WRITE (IQLOG,9421) LUNX,JRUNCR
 277  9421 FORMAT (' FZOUT.   LUN=',I4,' Write End-of-Run ',I8)
 278 #endif
 279 C--       flush the buffer before EoR
 280       IF   (IACTVX.LT.13)  THEN
 281         IF (IFIFOX.NE.0)   THEN
 282             IDX(2) = -1
 283             CALL FZOFFX (IUHEAD)
 284           ENDIF
 285         ENDIF
 286       IACTVX = 14
 287       JRUNX  = 0
 288       JRUN   = 0
 289
 290 C--                Write StoR/EoR record
 291
 292   424 IDX(1) = 1 + NWUHU
 293       IDX(2) = 1
 294       IQUEST(11) = JRUN
 295 #if defined(CERNLIB_FZFFNAT)
 296       IF (IFIFOX.EQ.0)  THEN
 297           CALL FZOFFN (IUHEAD)
 298           GO TO 426
 299         ENDIF
 300 #endif
 301       CALL FZOFFX (IUHEAD)
 302   426 CONTINUE
 303
 304       IF (JBIT(MSTATX,15).NE.0)    GO TO 441
 305       IF (JTRA.EQ.2)               GO TO 991
 306
 307 C--                Flush the buffer after operation
 308
 309   441 IF (IFIFOX.NE.0)  THEN
 310           IDX(2) = -1
 311           CALL FZOFFX (0)
 312         ENDIF
 313
 314       GO TO ( 406, 991, 991, 461, 471), JTRA
 315
 316 C----              Write end-of-file / end-of-data
 317
 318   461 IF (IEVFLX.LT.15)            GO TO 991
 319       IF (IACTVX.EQ.15)            GO TO 471
 320       NWUHU = 0
 321       JTRA  = 5
 322       IQ(KQSP+LQFX+12) = IQ(KQSP+LQFX+12) + 1
 323 #if defined(CERNLIB_QPRINT)
 324       IF (LOGLVX.GE.0)  WRITE (IQLOG,9464) LUNX
 325  9464 FORMAT (' FZOUT.   LUN=',I4,' Write Zebra EoF')
 326 #endif
 327
 328       JRUNX  = 0
 329       IDX(1) = 4
 330       IDX(2) = 1
 331       IUHDAT(1)  = IQ(KQSP+LQFX+34)
 332       IUHDAT(2)  = IQ(KQSP+LQFX+35)
 333       IUHDAT(3)  = IQ(KQSP+LQFX+33) + 1
 334       IQUEST(11) = -1
 335 #if defined(CERNLIB_FZFFNAT)
 336       IF (IFIFOX.EQ.0)  THEN
 337           CALL FZOFFN (IUHDAT)
 338           GO TO 426
 339         ENDIF
 340 #endif
 341       CALL FZOFFX (IUHDAT)
 342       GO TO 426
 343
 344 C--                Write true EOF
 345
 346   471 NEOF  = JBYT (MSTATX,13,2)
 347       IF (IEVFLX.EQ.15)  THEN
 348           NEOFU = MOD (NEOF,2)
 349         ELSE
 350           NEOFU = MAX (0,NEOF-1)
 351         ENDIF
 352       IF (NEOFU.EQ.0)              GO TO 474
 353
 354       IQUEST(11) = NEOFU
 355       IQUEST(12) = NEOF
 356       IDX(2)     = 13 - IEVFLX
 357 #if defined(CERNLIB_FZFFNAT)
 358       IF (IFIFOX.EQ.0)  THEN
 359           CALL FZOFFN (0)
 360           GO TO 473
 361         ENDIF
 362 #endif
 363       CALL FZOFFX (0)
 364   473 IQ(KQSP+LQFX+11) = IQ(KQSP+LQFX+11) + IQUEST(11)
 365
 366   474 IACTVX = IEVFLX
 367 #if defined(CERNLIB_QPRINT)
 368       IF   (LOGLVX.GE.0)  THEN
 369          IF (IEVFLX.NE.16)  THEN
 370             WRITE (IQLOG,9474) LUNX
 371           ELSE
 372             WRITE (IQLOG,9475) LUNX
 373           ENDIF
 374         ENDIF
 375  9474 FORMAT (' FZOUT.   LUN=',I4,' End-of-File')
 376  9475 FORMAT (' FZOUT.   LUN=',I4,' End-of-Data')
 377 #endif
 378       GO TO 991
 379
 380 C-------------------------------------------------
 381 C-                 ERROR HANDLING
 382 C-------------------------------------------------
 383
 384   901 IF (IACTVX.EQ.18)            GO TO 21
 385       IF (IACTVX.EQ.17)   CALL ZFATAM ('FZOUT - Going beyond EoD.')
 386       IACTVX = 17
 387       IQUEST(1) = -1
 388       GO TO 992
 389
 390   902 IQUEST(11) = IEVFLX
 391       CALL ZFATAM ('FZOUT - Faulty parameter IEVENT.')
 392
 393   903 IQUEST(11) = IOCHX(1)
 394       CALL ZFATAM ('FZOUT - IOCH invalid.')
 395
 396 #if defined(CERNLIB_FZCHANNEL)||defined(CERNLIB_FZMEMORY)
 397   907 IQUEST(1)  = -2
 398       IQUEST(11) = LUNX
 399       IF (IEVFLX.GE.2)             GO TO 992
 400       CALL ZFATAM ('FZOUT - User routine / buffer not connected.')
 401 #endif
 402 #if defined(CERNLIB_FZMEMORY)
 403   909 IQUEST(1)  = -2
 404       IQUEST(2)  = 14
 405       IQUEST(8)  = IQ(KQSP+LQFX+9)
 406       IQUEST(9)  = NWMEMT
 407       IF (IOPTXP.EQ.0)  CALL ZTELL (14,1)
 408       GO TO 999
 409 #endif
 410 C-------------------------------------------------
 411 C-                 COMMON EXIT
 412 C-------------------------------------------------
 413
 414   991 IQUEST(1)  = 0
 415   992 IQUEST(2)  = 0
 416       IQUEST(5)  = IQ(KQSP+LQFX+31)
 417       IQUEST(6)  = IQ(KQSP+LQFX+32)
 418       IQ(KQSP+LQFX+2)  = IACTVX
 419 #if defined(CERNLIB_FZMEMORY)
 420       IF (IFIFOX.EQ.3)
 421      +IQUEST(9)  = IQ(KQSP+LQFX+1) - IQ(KQSP+LQFX+8)
 422 #endif
 423       IQUEST(10) = NWMEMT
 424       IQUEST(11) = NWBKX
 425       IQUEST(12) = NWTABX
 426       IQUEST(13) = IQ(KQSP+LQFX+15)
 427       IQUEST(14) = IQ(KQSP+LQFX+19)
 428       IQUEST(15) = IQ(KQSP+LQFX+20)
 429       IQUEST(16) = IQ(KQSP+LQFX+21)
 430       IQUEST(17) = IQ(KQSP+LQFX+22)
 431 #include "zebra/qtrace99.inc"
 432       RETURN
 433       END
 434 *      ==================================================
 435 #include "zebra/qcardl.inc"