MINICERN/packlib/zebra/dzebra/zdvcop.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/03/06 10:47:07  mclareni
   6 * Zebra
   7 *
   8 *
   9 *-----------------------------------------------------------
  10 #include "zebra/pilot.h"
  11 #if (defined(CERNLIB_DEBUGON))&&(defined(CERNLIB_VFORT))
  12 #include "zebra/debugvf1.inc"
  13 #endif
  14       SUBROUTINE ZDVCOP (IXDVFR,LIN,IXDVTO,LOUT,*)
  15 #include "zebra/mqsys.inc"
  16 #include "zebra/qequ.inc"
  17 #include "zebra/mzct.inc"
  18 #include "zebra/zstate.inc"
  19 #include "zebra/zunit.inc"
  20 #include "zebra/dzc1.inc"
  21 #include "zebra/bankparq.inc"
  22 #include "zebra/divparq.inc"
  23 #include "zebra/storparq.inc"
  24       CHARACTER CHROUT*(*)
  25       PARAMETER (CHROUT = 'ZDVCOP')
  26 #include "zebra/q_jbit.inc"
  27
  28 #if (defined(CERNLIB_DEBUGON))&&(defined(CERNLIB_VFORT))
  29 #include "zebra/debugvf2.inc"
  30 #endif
  31
  32       CALL MZSDIV(IXDVFR,1)
  33       JSTOR1 = JQSTOR
  34       JDIV1  = JQDIVI
  35       CALL MZSDIV(IXDVTO,1)
  36       JSTOR2 = JQSTOR
  37       JDIV2  = JQDIVI
  38       IF (JSTOR1.NE.JSTOR2) THEN
  39           WRITE(IQPRNT,'('' ZDVCOP -- Stores different '',2I5)')
  40      W         JSTOR1,JSTOR2
  41                                                            GO TO 998
  42       ENDIF
  43
  44       IF (JDIV1.EQ.JDIV2)                                  GO TO 999
  45
  46       IF (JDIV1.GT.JQDVLL.AND.JDIV1.LT.JQDVSY) THEN
  47           WRITE(IQPRNT,'('' ZDVCOP -- Division 1 ID invalid '',I5)')
  48      W         JDIV1
  49                                                            GO TO 998
  50       ENDIF
  51       IF (JDIV2.GT.JQDVLL.AND.JDIV2.LT.JQDVSY) THEN
  52           WRITE(IQPRNT,'('' ZDVCOP -- Division 2 ID invalid '',I5)')
  53      W         JDIV2
  54                                                            GO TO 998
  55
  56       ENDIF
  57       CALL MZGARB(IXDVFR,IXDVTO)
  58       JQDVM1 = 0
  59       JQDVM2 = 0
  60       NQDVMV = 0
  61
  62       NWORDS = LQEND(KQT+JDIV1)-LQSTA(KQT+JDIV1)
  63
  64       IF (JBIT(IQMODE(KQT+JDIV2),JDVBFQ).EQ.IDVFWQ)  THEN
  65
  66
  67           IF (JDIV2.EQ.JQDVLL) THEN
  68               JNEXT  = JQDVSY
  69           ELSE
  70               JNEXT  = JDIV2 + 1
  71           ENDIF
  72           IF (NWORDS.GT.LQSTA(KQT+JNEXT)-LQSTA(KQT+JDIV2))   THEN
  73               WRITE(IQPRNT,'('' ZDVCOP -- TARGET DIVISION TOO SMALL'')')
  74                                                            GO TO 998
  75           ENDIF
  76           CALL UCOPY
  77      U    (LQ(KQS+LQSTA(KQT+JDIV1)),LQ(KQS+LQSTA(KQT+JDIV2)),NWORDS)
  78           LQEND(KQT+JDIV2) = LQSTA(KQT+JDIV2)+NWORDS
  79           NMOVE  = LQSTA(KQT+JDIV2)-LQSTA(KQT+JDIV1)
  80       ELSE
  81
  82
  83           IF (NWORDS.GT.LQEND(KQT+JDIV2)-LQEND(KQT+JDIV2-1))   THEN
  84               WRITE(IQPRNT,'('' ZDVCOP -- TARGET DIVISION TOO SMALL'')')
  85                                                            GO TO 998
  86           ENDIF
  87           CALL UCOPY
  88      U    (LQ(KQS+LQSTA(KQT+JDIV1)),LQ(KQS+LQEND(KQT+JDIV2)-NWORDS)
  89      U     ,NWORDS                                                  )
  90           LQSTA(KQT+JDIV2) = LQEND(KQT+JDIV2)-NWORDS
  91           NMOVE  = LQEND(KQT+JDIV2)-LQSTA(KQT+JDIV1)-NWORDS
  92       ENDIF
  93
  94       LQMTA  = NQOFFS(1) + LQEND(1)
  95       MQDVGA = 0
  96       MQDVWI = 0
  97       CALL SBIT1(MQDVGA,JDIV2)
  98       CALL MZTABM
  99       LQMTE = LQMTA + JDIV2*8
 100       DO 300 L=LQMTA,LQMTE-1,8
 101           IF(LQ(L).EQ.JDIV2)   THEN
 102               LQ(L+1) = 1
 103           ELSE
 104               LQ(L+1) = -1
 105           ENDIF
 106   300 CONTINUE
 107       LQRTA = LQMTE
 108       LQTA   = LQRTA + 2
 109       LQ(LQTA-1) = LQSTA(KQT+JDIV1)
 110       LQ(LQTA  ) = LQSTA(KQT+JDIV1)
 111       LQ(LQTA+1) = LQEND(KQT+JDIV1)
 112       LQ(LQTA+2) = NMOVE
 113       LQ(LQTA+3) = 0
 114       LQTE       = LQTA + 4
 115       LQ(LQTE  ) = LQEND(KQT+JDIV1)
 116       LSUP   = LQLORG(KQS+LIN)
 117       IF (LSUP.NE.0)    THEN
 118           LQLORG(KQS+LIN+NMOVE) = LSUP+LOCF(LOUT)-LOCF(LIN)
 119       ELSE
 120           LQLORG(KQS+LIN+NMOVE) = 0
 121       ENDIF
 122 #if defined(CERNLIB_QDEVZE)
 123       IF(NQDEVZ.NE.0) CALL CQDTAB (0)
 124 #endif
 125       CALL MZRELB
 126       LOUT = LIN + NMOVE
 127
 128                                                            GO TO 999
 129
 130   998 RETURN 1
 131   999 RETURN
 132       END