MINICERN/packlib/zebra/rz/rzpurf.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/03/06 10:47:26  mclareni
   6 * Zebra
   7 *
   8 *
   9 #include "zebra/pilot.h"
  10       SUBROUTINE RZPURF(N,KPURG)
  11 *
  12 ************************************************************************
  13 *
  14 *         Update list of purged records
  15 * Input:
  16 *    N      Number of consecutive records purged
  17 *    KPURG  First of the N records purged
  18 *
  19 * Called by RZPURG
  20 *
  21 *  Author  : R.Brun DD/US/PD
  22 *  Written : 06.04.86
  23 *  Last mod: 22.08.90
  24 *
  25 ************************************************************************
  26 *
  27 #include "zebra/rzcl.inc"
  28 #include "zebra/rzclun.inc"
  29 #include "zebra/rzk.inc"
  30 *
  31 *-----------------------------------------------------------------------
  32 *
  33       IF(LQ(KQSP+LTOP-5).EQ.0)THEN
  34          CALL MZBOOK(JQPDVS,LPURG,LTOP,-5,'RZPU',0,0,21,2,0)
  35          IQ(KQSP+LPURG-5)=LUN
  36       ENDIF
  37 *
  38       IF(KPURG.EQ.0)GO TO 99
  39       IPURG=KPURG
  40       IPURL=IPURG+N-1
  41       DO 2 I=IPURG,IPURL
  42          IF(I.EQ.IQ(KQSP+LCDIR+KRLOUT))THEN
  43             IQ(KQSP+LCDIR+KRLOUT)=0
  44             IQ(KQSP+LCDIR+KIP1)=1
  45          ENDIF
  46    2  CONTINUE
  47       NPURG=IQ(KQSP+LPURG+1)
  48       IF(NPURG.EQ.0)THEN
  49          IQ(KQSP+LPURG+1)=1
  50          IQ(KQSP+LPURG+2)=IPURG
  51          IQ(KQSP+LPURG+3)=IPURL
  52          GO TO 99
  53       ENDIF
  54 *
  55       DO 5 I=1,NPURG
  56          IRF=IQ(KQSP+LPURG+2*I)
  57          IRL=IQ(KQSP+LPURG+2*I+1)
  58          IF(IPURG.GE.IRF.AND.IPURG.LE.IRL)IPURG=IRL+1
  59          IF(IPURL.GE.IRF.AND.IPURL.LE.IRL)IPURL=IRF-1
  60          IF(IPURG.GT.IPURL)GO TO 99
  61    5  CONTINUE
  62 *
  63       IPU=2
  64   10  IF(IPURL.LT.IQ(KQSP+LPURG+IPU))THEN
  65          IF(IPURL.EQ.IQ(KQSP+LPURG+IPU)-1)THEN
  66             IQ(KQSP+LPURG+IPU)=IPURG
  67          ELSE
  68             IF(IPU.GT.2.AND.IPURG.LE.IQ(KQSP+LPURG+IPU-1))GO TO 99
  69             NDATA=IQ(KQSP+LPURG-1)
  70             IF(NDATA.LT.2*NPURG+3)THEN
  71                CALL MZPUSH(JQPDVS,LPURG,0,10,'I')
  72             ENDIF
  73             NLEFT=2*NPURG-IPU+2
  74             IF(NLEFT.GT.0)THEN
  75                CALL UCOPY2(IQ(KQSP+LPURG+IPU),
  76      +                     IQ(KQSP+LPURG+IPU+2),NLEFT)
  77             ENDIF
  78             NPURG=NPURG+1
  79             IQ(KQSP+LPURG+1)=NPURG
  80             IQ(KQSP+LPURG+IPU)=IPURG
  81             IQ(KQSP+LPURG+IPU+1)=IPURL
  82          ENDIF
  83          GO TO 99
  84       ENDIF
  85 *
  86       IF(IPURG.EQ.IQ(KQSP+LPURG+IPU+1)+1)THEN
  87          IQ(KQSP+LPURG+IPU+1)=IPURL
  88          IF(IPU+2.LT.2*NPURG)THEN
  89             IF(IQ(KQSP+LPURG+IPU+1).EQ.IQ(KQSP+LPURG+IPU+2))THEN
  90                IQ(KQSP+LPURG+IPU+1)=IQ(KQSP+LPURG+IPU+3)
  91                NLEFT=2*NPURG-IPU-2
  92                IF(NLEFT.GT.0)THEN
  93                   CALL UCOPY2(IQ(KQSP+LPURG+IPU+4),
  94      +                        IQ(KQSP+LPURG+IPU+2),NLEFT)
  95                ENDIF
  96                NPURG=NPURG-1
  97                IQ(KQSP+LPURG+1)=NPURG
  98             ENDIF
  99          ENDIF
 100          GO TO 99
 101       ENDIF
 102 *
 103       IPU=IPU+2
 104       IF(IPU.LE.2*NPURG)GO TO 10
 105 *
 106       NDATA=IQ(KQSP+LPURG-1)
 107       IF(NDATA.LT.2*NPURG+3)THEN
 108          CALL MZPUSH(JQPDVS,LPURG,0,2,'I')
 109       ENDIF
 110       IQ(KQSP+LPURG+IPU)=IPURG
 111       IQ(KQSP+LPURG+IPU+1)=IPURL
 112       NPURG=NPURG+1
 113       IQ(KQSP+LPURG+1)=NPURG
 114 *
 115   99  RETURN
 116       END