MINICERN/packlib/zebra/fq/fzcffx.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/03/06 10:47:10  mclareni
   6 * Zebra
   7 *
   8 *
   9 #include "zebra/pilot.h"
  10       SUBROUTINE FZCFFX
  11
  12 C-    Copy table + bank material for input file format X,
  13 C-    subsidiary to FZCOPY
  14
  15 #include "zebra/zunit.inc"
  16 #include "zebra/mqsys.inc"
  17 #include "zebra/eqlqf.inc"
  18 #include "zebra/mzct.inc"
  19 #include "zebra/mzcwk.inc"
  20 #include "zebra/fzci.inc"
  21 #include "zebra/fzcx.inc"
  22 #include "zebra/fzcseg.inc"
  23 C--------------    End CDE                             --------------
  24       EQUIVALENCE (LRTYP,IDI(2))
  25 #if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
  26       DIMENSION    NAMESR(2)
  27       DATA  NAMESR / 4HFZCF, 4HFX   /
  28 #endif
  29 #if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
  30       DATA  NAMESR / 6HFZCFFX  /
  31 #endif
  32 #if !defined(CERNLIB_QTRHOLL)
  33       CHARACTER    NAMESR*8
  34       PARAMETER   (NAMESR = 'FZCFFX  ')
  35 #endif
  36
  37 #include "zebra/qtraceq.inc"
  38
  39
  40       NWDO   = NWBKX
  41       ISTTAB = IQUEST(7)
  42 #if defined(CERNLIB_FZFFNAT)
  43       IF (IFIFOX.EQ.0)             GO TO 41
  44 #endif
  45
  46 C-------------------------------------------------
  47 C-                 Output file format exchange
  48 C-------------------------------------------------
  49
  50       IF (ISTTAB.LT.0)  NWDO = NWDO + NWTABX
  51
  52    24 CALL FZIACN (NWDO,LDATA,NWACC)
  53       IF (IFLAGI.NE.0)             GO TO 999
  54
  55       CALL FZOTRN (LQ(LDATA),NWACC)
  56       NWDO = NWDO - NWACC
  57       IF (NWDO.NE.0)               GO TO 24
  58
  59    29 CALL FZIREC
  60       IF (N4RESI.NE.0)             GO TO 991
  61
  62       IF (IFIFOX.NE.0)  CALL FZOREC
  63
  64 #include "zebra/qtrace99.inc"
  65       RETURN
  66
  67 C-------------------------------------------------
  68 C-                 Output file format native
  69 C-------------------------------------------------
  70
  71 #if defined(CERNLIB_FZFFNAT)
  72    41 MINREC = (4*MAXREX) / 5
  73       LAST   = 0
  74       IF (ISTTAB.GE.0)             GO TO 61
  75
  76 C----              Copy the table
  77
  78       IDX(2) = 4
  79       NWDO = NWTABX
  80
  81    44 NWR  = MIN (NWDO, MAXREX)
  82       CALL FZIACN (NWR,LDATA,NWACC)
  83       IF (IFLAGI.NE.0)             GO TO 999
  84       NWDO = NWDO - NWACC
  85       IF (NWDO.EQ.0)  THEN
  86           IF (LAST.NE.0) IDX(2)=8
  87           CALL FZON1 (LQ(LDATA),NWACC)
  88           GO TO 58
  89         ENDIF
  90
  91       IF (NWACC.GE.MINREC)  THEN
  92           CALL FZON1 (LQ(LDATA),NWACC)
  93           GO TO 44
  94         ENDIF
  95
  96       NIN = 0
  97    46 CALL UCOPY (LQ(LDATA),IQWKTB(NIN+1),NWACC)
  98       NIN = NIN + NWACC
  99
 100       NWR  = MIN (NWDO, MAXREX-NIN)
 101       CALL FZIACN (NWR,LDATA,NWACC)
 102       IF (IFLAGI.NE.0)             GO TO 999
 103       NWDO = NWDO - NWACC
 104       IF (NWDO.EQ.0)  THEN
 105           IF (LAST.NE.0)  IDX(2)=8
 106         ELSE
 107           IF (NIN+NWACC.LT.MINREC) GO TO 46
 108         ENDIF
 109
 110       CALL FZON2 (IQWKTB,NIN,LQ(LDATA),NWACC)
 111       IF (NWDO.NE.0)               GO TO 44
 112
 113    58 IF (LAST.NE.0)               GO TO 999
 114       IF (IDX(2).NE.4)             GO TO 63
 115
 116 C----              Copy the bank material
 117
 118    61 IDX(2) = 7
 119       IF (NQSEG.EQ.0)  THEN
 120           LAST = 7
 121           NWDO = NWBKX
 122           GO TO 44
 123         ENDIF
 124
 125       JSEG = 0
 126    63 JSEG = JSEG + 1
 127       NWDO = IQSEGD(JSEG)
 128       IF (JSEG.EQ.NQSEG)  LAST=7
 129       GO TO 44
 130 #endif
 131 C----              Error handling
 132
 133 C-    JERROR = 455  bank material does not end exactly with LR
 134   991 JERROR = 455
 135       JRETCD = 5
 136       GO TO 999
 137       END
 138 *      ==================================================
 139 #include "zebra/qcardl.inc"