* * $Id$ * * $Log$ * Revision 1.2 1996/04/18 16:11:19 mclareni * Incorporate changes from J.Zoll for version 3.77 * * Revision 1.1.1.1 1996/03/06 10:47:19 mclareni * Zebra * * #include "zebra/pilot.h" SUBROUTINE MZCOPY (IXDVFR,LENTP,IXDVTO,LSUPP,JBIASP,CHOPT) C- Copy a data-structure, User called #include "zebra/zbcd.inc" #include "zebra/zstate.inc" #include "zebra/zunit.inc" #include "zebra/zvfaut.inc" #include "zebra/mqsys.inc" #include "zebra/mzct.inc" #include "zebra/mzcn.inc" #include "zebra/fzcx.inc" C-------------- END CDE -------------- DIMENSION IXDVFR(9),LENTP(9),IXDVTO(9),LSUPP(9),JBIASP(9) CHARACTER CHOPT*(*) DIMENSION LADESV(6) #if defined(CERNLIB_QMVDS) SAVE LADESV #endif #if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M)) DIMENSION NAMESR(2) DATA NAMESR / 4HMZCO, 4HPY / #endif #if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M)) DATA NAMESR / 6HMZCOPY / #endif #if !defined(CERNLIB_QTRHOLL) CHARACTER NAMESR*8 PARAMETER (NAMESR = 'MZCOPY ') #endif DATA LADESV / 6, 5*0 / #include "zebra/q_locf.inc" #include "zebra/qtrace.inc" #if defined(CERNLIB_QDEBUG) IF (IQVSTA.NE.0) CALL ZVAUTX #endif LENTRX = LENTP(1) LSUP = LSUPP(1) NWBKFR = IQUEST(1) NOFFFR = IQUEST(2) NWBKMX = IQUEST(3) NOFFTO = IQUEST(4) CALL UOPTC (CHOPT,'DISZMLNPFT',IOPTXD) JFLGAX = 0 IHANDL = 0 NWBKU = -7 LOGLEV = NQLOGD C---- TO option yes / no IF (IOPTXT.NE.0) THEN LOCTO = LOCF(IXDVTO(1)) - 1 - NOFFTO KSQTO = LOCTO - LQASTO JSTOTO = -2 ELSE IXDIVI = IXDVTO(1) CALL MZSDIV (IXDIVI,7) IF (JQDIVI.EQ.0) GO TO 97 KSQTO = KQS JSTOTO = JQSTOR JDIVTO = JQDIVI JDMODE = IQMODE(KQT+JQDIVI) NWBKMX = NQDMAX(KQT+JQDIVI) LOGLEV = MAX (LOGLEV,NQLOGL) LQSYSR(KQT+2) = LSUP ENDIF C---- FROM option yes / no IF (IOPTXF.NE.0) THEN LOCFR = LOCF(IXDVFR(1)) - 1 - NOFFFR KSQFR = LOCFR - LQASTO JSTOFR = -1 NWBKX = NWBKFR IOPTXD = 1 IOPTXL = 1 ELSE IXDIVX = IXDVFR(1) CALL MZSDIV (IXDIVX,0) KSQFR = KQS JSTOFR = JQSTOR LOGLEV = MAX (LOGLEV,NQLOGL) LQSYSR(KQT+1) = LENTRX IF ((JSTOFR.EQ.JSTOTO).AND.(IOPTXZ.EQ.0)) IHANDL=-1 ENDIF #if defined(CERNLIB_QDEBPRI) IF (LOGLEV.GE.2) + WRITE (IQLOG,9009) JSTOFR,JSTOTO,CHOPT 9009 FORMAT (' MZCOPY- Store From/To =',2I3,' Options = ',A) #endif C---------- Table building ---------------------- 11 MODTBX = 1 IQPART = 0 C---- TO option yes / no JQSTMV = -1 IF (IOPTXT.NE.0) GO TO 21 C-- TO option no IF (NWBKU.GE.0) GO TO 21 JQSTMV = JSTOTO JQDVM1 = JDIVTO JQDVM2 = JDIVTO NQDVMV = 1 - 2*JDMODE IQTNMV = -7 C---- FROM option yes / no 21 IF (IOPTXF.EQ.0) GO TO 24 JQGAPM = 0 JQGAPR = 0 LQRTA = LQWKTB LQTA = LQRTA + 2 LQTE = LQTA + 4 LQRTE = LQTE + 1 LQMTA = LQRTE + 2 LQ(LQTA) = NOFFFR + 1 LQ(LQTA+1) = LQ(LQTA) + NWBKX GO TO 33 C-- FROM option no 24 IF (JQSTOR.NE.JSTOFR) CALL MZSDIV (IXDIVX,0) CALL FZOTAB IF (IQUEST(1).EQ.0) GO TO 31 IF (IQUEST(1).EQ.1) GO TO 11 IF (IQUEST(2).NE.13) GO TO 91 IF (JFLGAX.GE.3) GO TO 93 C-- Collect garbage in the TO space, if no room JFLGAX = 3 IF (JSTOTO.EQ.JQSTOR) GO TO 93 IF (JSTOTO.LE.0) GO TO 93 IXGARB = MZIXCO (IXDIVI,21,22,23) IXGARB = MZIXCO (IXGARB,24,0,0) CALL MZGARB (IXGARB,0) GO TO 11 C---------- Reserve target space -------------------- 31 CONTINUE #if defined(CERNLIB_QDEVZE) IF (NQDEVZ.LT.7) GO TO 33 WRITE (IQLOG,9831) LQMTA,LQMTE 9831 FORMAT (1X/' DEVZE MZCOPY, Memory Occupation Table,' F,' LQMTA,LQMTE= ',2I8/16X, F' DIV ACT NWS LFBK LLBK+1 JFE JLE FREE') WRITE (IQLOG,9832) (LQ(J),J=LQMTA,LQMTE-1) 9832 FORMAT (16X,2I4,6I8) #endif 33 IF (NWBKX.GT.NWBKMX) GO TO 94 IF (NWBKX.EQ.0) GO TO 95 IF (IOPTXT.NE.0) GO TO 41 IF (JQSTOR.NE.JSTOTO) CALL MZSDIV (IXDIVI,0) IF (NWBKU.GE.0) GO TO 37 JQDIVI = JDIVTO CALL MZRESV NQRESV = NQRESV - NWBKX IF (NQRESV.LT.0) THEN CALL MZGAR1 IQPART = -7 IF (JSTOTO.EQ.JSTOFR) LENTRX=LQSYSR(KQT+1) ENDIF IF (JDMODE.EQ.0) THEN LTO = LQEND(KQT+JDIVTO) LTOE = LTO + NWBKX LQEND(KQT+JDIVTO) = LTOE ELSE LTOE = LQSTA(KQT+JDIVTO) LTO = LTOE - NWBKX LQSTA(KQT+JDIVTO) = LTO ENDIF IF (IQPART.EQ.0) GO TO 42 LQ(KQS+LTO) = 12 LQ(KQS+LTO+1) = 0 LQ(KQS+LTO+2) = 0 LQ(KQS+LTO+3) = 0 LQ(KQS+LTO+4) = 0 LQ(KQS+LTO+5) = IQLETT(1) LQ(KQS+LTO+6) = 0 LQ(KQS+LTO+7) = 0 LQ(KQS+LTO+8) = NWBKX - 10 LQ(KQS+LTO+9) = 0 NWBKU = NWBKX GO TO 11 C---- Target space already reserved, get it 37 NDIF = NWBKX - NWBKU IF (JDMODE.EQ.0) THEN LTOE = LQEND(KQT+JDIVTO) LTO = LTOE - NWBKU IF (NDIF.EQ.0) GO TO 42 LTOE = LTOE + NDIF LQEND(KQT+JDIVTO) = LTOE ELSE LTO = LQSTA(KQT+JDIVTO) LTOE = LTO + NWBKU IF (NDIF.EQ.0) GO TO 42 LTO = LTO - NDIF LQSTA(KQT+JDIVTO) = LTO ENDIF GO TO 42 C---------- Move material to destination ------------- C-- TO option yes 41 LTO = NOFFTO + 1 LTOE = LTO + NWBKX JQSTOR = -1 LQSTOR = LOCTO KQS = KSQTO KQT = KQFT LQFSTA(1) = LTO LQFSTA(21) = LTOE GO TO 44 C-- TO option no 42 NWBKU = NWBKX LSUP = LQSYSR(KQT+2) 44 LTOA = LTO NREL = LTO LFRE = 0 LTB = LQTA 46 LFR = LQ(LTB) NREL = NREL - (LFR-LFRE) LFRE = LQ(LTB+1) LQ(LTB+2) = NREL LQ(LTB+3) = IHANDL NW = LFRE - LFR CALL UCOPY (LQ(KSQFR+LFR), LQ(KSQTO+LTO), NW) LTO = LTO + NW LTB = LTB + 4 IF (LTB.LT.LQTE) GO TO 46 C---------- Relocation --------------------------- LQ(LQMTA+1) = 1 LQ(LQMTA+3) = LTOA LQ(LQMTA+4) = LTOE LQMTE = LQMTA + 8 IF (IOPTXN.NE.0) GO TO 61 LQ(LQTE) = LQ(LQTE-3) LQ(LQTA-1) = LQ(LQTA) IF (IHANDL.LT.0) THEN C-- retain links pointing outside the d/s IQFLIO = 0 ELSE C-- zero links pointing outside IQFLIO = 7 ENDIF #if defined(CERNLIB_QDEVZE) IF (NQDEVZ.LT.7) GO TO 56 LQ(LQMTA) = 0 LQ(LQMTA+2) = 0 LQ(LQMTA+5) = 0 LQ(LQMTA+6) = 0 LQ(LQMTA+7) = 0 WRITE (IQLOG,9853) LQRTA,LQTA,LQTE,LQ(LQTA-1) 9853 FORMAT (1X/' DEVZE MZCOPY, Link Relocation Table,' F,' LQRTA,LQTA,LQTE= ',3I8 F/16X,' LOC L LE NREL BG' F/28X,I10) IF (LQTE.LE.LQTA) GO TO 55 I = LQRTA JA = LQTA - I JE = LQTE - I - 1 WRITE (IQLOG,9854) (J,LQ(I+J),LQ(I+J+1),LQ(I+J+2),LQ(I+J+3), + J=JA,JE,4) 9854 FORMAT (16X,I6,3I8,I4) 55 WRITE (IQLOG,9855) LQ(LQTE) 9855 FORMAT (20X,I10) 56 CONTINUE #endif CALL MZRELB IF (IQFLIO.LT.0) GO TO 96 C-- Relocate the entry link LADESV(2) = LOCF(LENTRX) - LQSTOR LADESV(3) = LADESV(2) + 1 LADESV(5) = IQLETT(9) LADESV(6) = IQLETT(15) CALL MZRELL (LADESV) IF (IOPTXL.EQ.0) LQ(KQS+LENTRX)=0 LQ(KQS+LENTRX+1) = 0 LQ(KQS+LENTRX+2) = 0 GO TO 64 C-- No-link option 61 CALL FZILIN IF (IQFOUL.NE.0) GO TO 96 LENTRX = IQUEST(1) C---- Connect d/s 64 IF (IOPTXT.NE.0) THEN LSUPP(1) = LENTRX JBIASP(1) = NWBKX ELSE JB = JBIASP(1) LSUPP(1) = LQSYSR(KQT+2) CALL ZSHUNT (IXDIVI,LENTRX,LSUPP,JB,1) ENDIF IQUEST(1) = 0 IQUEST(2) = NWBKX #include "zebra/qtrace99.inc" RETURN C---------- Error conditions ----------------------- C-- LENTRX invalid / Bank chaning clobbered in FZOTAB 91 IQUEST(2) = IQUEST(2) - 10 GO TO 98 C-- Not enough table space 93 IQUEST(2) = 3 GO TO 98 C-- D/s larger than the target space 94 IQUEST(2) = 4 IQUEST(11) = NWBKX IQUEST(12)= NWBKMX GO TO 98 C-- D/s empty 95 IQUEST(2) = 5 GO TO 98 C-- MZRELB or FZILIN find bank chaining clobbered 96 IQUEST(2) = 6 GO TO 98 C-- Target division not specified 97 IQUEST(2) = 7 98 CONTINUE IF (NWBKU.GE.0) THEN IF (JQSTOR.NE.JSTOTO) CALL MZSDIV (IXDIVI,0) IF (JDMODE.EQ.0) THEN LQEND(KQT+JDIVTO) = LQEND(KQT+JDIVTO) - NWBKU ELSE LQSTA(KQT+JDIVTO) = LQSTA(KQT+JDIVTO) + NWBKU ENDIF ENDIF IF (IOPTXP.EQ.0) CALL ZTELL (15,1) IQUEST(1) = IQUEST(2) GO TO 999 END * ================================================== #include "zebra/qcardl.inc"