MINICERN/packlib/zebra/rz/rzwrt.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/03/06 10:47:27  mclareni
   6 * Zebra
   7 *
   8 *
   9 #include "zebra/pilot.h"
  10       SUBROUTINE RZWRT(V,N,IOPTB,IEVENT)
  11 *
  12 ************************************************************************
  13 *
  14 *      To write array V of length N into the CWD
  15 *      RZ internal routine called by RZVOUT,RZOHN,RZOBKN
  16 *
  17 * Called by RZOBKN,RZOHN,RZVOUT
  18 *
  19 *  Author  : R.Brun, B.Holl
  20 *  Written : 26.04.86
  21 *  Last mod: 14.04.94 JDS. Correct(?) handling of end of records
  22 *            29.07.94 JDS. In case of termination on EOR, last
  23 *                          fragment of buffer was converted/copied twice
  24 *
  25 ************************************************************************
  26 #if !defined(CERNLIB_FQXISN)
  27 #include "zebra/zunit.inc"
  28 #endif
  29 #include "zebra/rzcl.inc"
  30 #include "zebra/rzclun.inc"
  31 #include "zebra/rzcout.inc"
  32 #include "zebra/rzk.inc"
  33 #include "zebra/mzioc.inc"
  34       DIMENSION V(N)
  35 *
  36 *-----------------------------------------------------------------------
  37 *
  38 *
  39 *     Event continued?
  40 *
  41       IF(IEVENT.EQ.1.AND.IP1.GT.LREC) THEN
  42          IF(IRLOUT.EQ.IR1)THEN
  43             IR=IR2
  44          ELSE
  45             IR=IRLOUT+1
  46          ENDIF
  47          IP1    = 1
  48          IROUT  = IR
  49          IRLOUT = IR
  50       ENDIF
  51
  52       NREC = N + IP1 - 1
  53       NLEFT=LREC-IP1+1
  54       IF(N.LE.NLEFT)THEN
  55          NP1=N
  56       ELSE
  57          NP1=NLEFT
  58       ENDIF
  59 #if !defined(CERNLIB_FQXISN)
  60       IF(IMODEX.GT.0.AND.IOPTB.NE.1)THEN
  61          NWFOTT = N
  62          NWFODN = 0
  63          NWFOAV = NP1
  64          CALL FZOCV(V,IQ(KQSP+LROUT+IP1))
  65          IF(NWFOAV.GT.0.OR.IFOCON(1).LT.0)GO TO 95
  66          IQUEST(1)=0
  67       ELSE
  68 #endif
  69          CALL UCOPY(V,IQ(KQSP+LROUT+IP1),NP1)
  70 #if !defined(CERNLIB_FQXISN)
  71       ENDIF
  72 #endif
  73       IF(IP1.EQ.1)THEN
  74          IROUT =IRLOUT
  75       ENDIF
  76       IP1=IP1+NP1
  77       IF(IP1.GT.LREC)THEN
  78          CALL RZIODO(LUN,LREC,IRLOUT,IQ(KQSP+LROUT+1),2)
  79          IF(IQUEST(1).NE.0)GO TO 99
  80          IF(LRIN.NE.0)THEN
  81             IF(IQ(KQSP+LTOP+KIRIN).EQ.IRLOUT)THEN
  82                IQ(KQSP+LTOP+KIRIN)=0
  83             ENDIF
  84          ENDIF
  85          IF(IRLOUT.EQ.IR1)THEN
  86             IR=IR2
  87          ELSE
  88             IR=IRLOUT+1
  89          ENDIF
  90 * JDS 14/04/94
  91          IF(IR.EQ.0) GOTO 99
  92    10    IP1=1
  93          NW=N-NP1
  94          IF(NW.GT.LREC)NW=LREC
  95          IF(NW.LT.LREC.AND.IOPTRR.NE.0)THEN
  96             CALL RZIODO(LUN,LREC,IR,IQ(KQSP+LROUT+1),1)
  97             IF(IQUEST(1).NE.0)GO TO 99
  98          ENDIF
  99 #if !defined(CERNLIB_FQXISN)
 100          IF(IMODEX.GT.0.AND.IOPTB.NE.1)THEN
 101
 102             IF(NWFOAV.LT.0)THEN
 103 *
 104 *      Case when output buffer overflowed (double precision conversion)
 105 *
 106                NWFOAV=NW-1
 107                IQ(KQSP+LROUT+1)=IQ(KQSP+LROUT+LREC+1)
 108                CALL FZOCV(V,IQ(KQSP+LROUT+2))
 109             ELSE
 110 *
 111 *      Normal case
 112 *
 113                NWFOAV=NW
 114                CALL FZOCV(V,IQ(KQSP+LROUT+1))
 115             ENDIF
 116
 117             IF(NWFOAV.GT.0.OR.IFOCON(1).LT.0)GO TO 95
 118             IQUEST(1)=0
 119             IF(NW.EQ.LREC) THEN
 120                CALL RZIODO(LUN,NW,IR,IQ(KQSP+LROUT+1),2)
 121                IF(IQUEST(1).NE.0)GO TO 99
 122             ENDIF
 123          ELSE
 124 #endif
 125             IF(NW.EQ.LREC) THEN
 126                CALL RZIODO(LUN,NW,IR,V(NP1+1),2)
 127                IF(IQUEST(1).NE.0)GO TO 99
 128             ELSE
 129                CALL UCOPY(V(NP1+1),IQ(KQSP+LROUT+IP1),NW)
 130             ENDIF
 131 #if !defined(CERNLIB_FQXISN)
 132          ENDIF
 133 #endif
 134          IRLOUT=IR
 135          IROUT =IR
 136          IP1=IP1+NW
 137          NP1=NP1+NW
 138 *
 139 * JDS 29/07/94
 140 *
 141 *        IF(NP1.GE.N) GOTO 99
 142 *
 143 * JDS 31/10/94
 144 *
 145 *     All data written - fill output buffer if on a record boundary
 146 *
 147          IF(NP1.GE.N) THEN
 148             IF(MOD(NREC,LREC).EQ.0)THEN
 149 #if !defined(CERNLIB_FQXISN)
 150                IF(IMODEX.GT.0.AND.IOPTB.NE.1)THEN
 151 *                 NWFODN = 0
 152 *                 IF(NWFOAV.LT.0)THEN
 153 *                    NWFOAV=NW-1-NP1
 154 *                    IQ(KQSP+LROUT+IP1-NW)=IQ(KQSP+LROUT+LREC+1)
 155 *                    CALL FZOCV(V,IQ(KQSP+LROUT+IP1-NW+1))
 156 *                 ELSE
 157 *                    NWFOAV=NW-NP1
 158 *                    CALL FZOCV(V,IQ(KQSP+LROUT+IP1-NW))
 159 *                 ENDIF
 160 *                 IF(NWFOAV.GT.0.OR.IFOCON(1).LT.0)GO TO 95
 161 *                 IQUEST(1)=0
 162                ELSE
 163 #endif
 164 *
 165 *     Fill output buffer for the case when vector ends on
 166 *     a record boundary (already filled if data conversion
 167 *     performed).
 168 *
 169                   CALL UCOPY(V(NP1-NW+1),IQ(KQSP+LROUT+IP1-NW),NW)
 170 #if !defined(CERNLIB_FQXISN)
 171                ENDIF
 172 #endif
 173             ENDIF
 174             GO TO 99
 175          ENDIF
 176          IR =IR+1
 177          GO TO 10
 178       ENDIF
 179 #if !defined(CERNLIB_FQXISN)
 180       GO TO 99
 181 *
 182 *           Conversion problem
 183 *
 184    95 IQUEST(1) =5
 185       IQUEST(11)=NWFOTT
 186       IQUEST(12)=NWFORE
 187       IQUEST(13)=NWFOAV
 188       IQUEST(14)=NWFODN
 189       IF(JBYT(IQ(KQSP+LTOP),15,3)-3.GE.-2) WRITE(IQLOG,1000)
 190  1000 FORMAT(' RZOUT/RZVOUT. Error during conversion into',
 191      +       ' exchange format detected by RZWRT')
 192 *1000 FORMAT(' RZWRT. Error during conversion into exchange format')
 193 #endif
 194 *
 195    99 RETURN
 196       END