* * $Id: hcopyn.F,v 1.1.1.1 1996/01/16 17:07:34 mclareni Exp $ * * $Log: hcopyn.F,v $ * Revision 1.1.1.1 1996/01/16 17:07:34 mclareni * First import * * #include "hbook/pilot.h" *CMZ : 4.22/11 23/08/94 14.17.45 by Rene Brun *-- Author : SUBROUTINE HCOPYN(IB,LB,ID1,IOFSET,JTAB,KOF) *.==========> *. Auxiliary for HCOPYM *. Copy one histogram from mapped /PAWC/ to current /PAWC/ *..=========> ( R.Brun) #include "hbook/hcbook.inc" #include "hbook/hcflag.inc" #include "hbook/hcform.inc" #include "hbook/hcbits.inc" CHARACTER*4 BNAME DIMENSION IB(1),LB(1) *.___________________________________________ NH=IB(JTAB-1) DO 10 I=1,NH IF(IB(JTAB+I).EQ.ID1)GO TO 20 10 CONTINUE GO TO 99 * 20 CONTINUE ID=ID1+IOFSET JCID=LB(JTAB-I)-KOF I4=JBIT(IB(JCID+KBITS),4) IF(I4.NE.0)THEN CALL HCOPYT(IB,LB,ID1,IOFSET,JCID,KOF) GO TO 99 ENDIF I123=JBYT(IB(JCID+KBITS),1,3) NTOT=IB(JCID+KNTOT) IF(I123.EQ.0)THEN CALL HBUG('Object is not an histogram','HCOPYM',ID1) GO TO 99 ENDIF JCONT=LB(JCID-1)-KOF NWID=IB(JCID-1) NBPROX=IB(JCONT+KNBIT) I1=JBIT(I123,1) * * Check if ID already in the table * NRHIST=IQ(LCDIR+KNRH) IDPOS=LOCATI(IQ(LTAB+1),NRHIST,ID) IF(IDPOS.GT.0)THEN CALL HBUG('+Already existing histogram replaced','HCOPYM',ID) CALL HDELET(ID) NRHIST=IQ(LCDIR+KNRH) IDPOS=-IDPOS+1 ENDIF * * Enough space left to copy ID ? * CALL HSPACE(NTOT+1000,'HCOPYM',ID1) IF(IERR.NE.0) GO TO 99 * * Enter ID in the list of ordered IDs * IDPOS=-IDPOS+1 IF(NRHIST.GE.IQ(LTAB-1))THEN CALL MZPUSH(IHDIV,LTAB,500,500,' ') ENDIF DO 30 I=NRHIST,IDPOS,-1 IQ(LTAB+I+1)=IQ(LTAB+I) LQ(LTAB-I-1)=LQ(LTAB-I) 30 CONTINUE * * Build top level bank * IF(I1.NE.0)THEN IODES=IOH1 BNAME='HID1' NL=1 ELSE IODES=IOH2 BNAME='HID2' NL=7 ENDIF * IF(LIDS.EQ.0)THEN CALL MZBOOK(IHDIV,LIDS,LCDIR,-2,BNAME,NL,NL,NWID,IODES,0) LCID=LIDS ELSE LLID=LQ(LCDIR-9) CALL MZBOOK(IHDIV,LCID,LLID, 0,BNAME,NL,NL,NWID,IODES,0) ENDIF CALL UCOPY(IB(JCID+1),IQ(LCID+1),NWID) LQ(LCDIR-9)=LCID IQ(LCID-5)=ID IQ(LTAB+IDPOS)=ID LQ(LTAB-IDPOS)=LCID NRHIST=NRHIST+1 IQ(LCDIR+KNRH)=NRHIST * * 1-DIM case * IF(I1.NE.0)THEN IF(NBPROX.GE.32)THEN IODES=IOCF1 ELSE IODES=IOCB1 ENDIF NW=IB(JCONT-1) CALL MZBOOK(IHDIV,LCONT,LCID,-1,'HCO1',2,2,NW,IODES,0) CALL UCOPY(IB(JCONT+1),IQ(LCONT+1),NW) IF(LB(JCONT).NE.0)THEN JR1=LB(JCONT)-KOF NW=IB(JR1-1) CALL MZBOOK(IHDIV,LR1,LCONT,0,'HI1E',0,0,NW,3,0) CALL UCOPY(IB(JR1+1),IQ(LR1+1),NW) IF(JBIT(IB(JR1),1).NE.0)CALL SBIT1(IQ(LR1),1) IF(LB(JR1).NE.0)THEN JR2=LB(JR1)-KOF NW=IB(JR2-1) CALL MZBOOK(IHDIV,LR2,LR1,0,'HI1N',0,0,NW,3,0) CALL UCOPY(IB(JR2+1),IQ(LR2+1),NW) ENDIF ENDIF IF(LB(JCONT-1).NE.0)THEN JFUNC=LB(JCONT-1) -KOF NW=IB(JFUNC-1) CALL MZBOOK(IHDIV,LFUNC,LCONT,-1,'HFUN',0,0,NW,IOCF2,0) CALL UCOPY(IB(JFUNC+1),IQ(LFUNC+1),NW) ENDIF *????????????????? Should copy LHFIT structure here. GO TO 99 ENDIF * * 2-DIM case * IF(NBPROX.GE.32)THEN IODES=IOCF2 ELSE IODES=IOCB2 ENDIF NW=IB(JCONT-1) CALL MZBOOK(IHDIV,LCONT,LCID,-1,'HCO2',2,2,NW,IODES,0) CALL UCOPY(IB(JCONT+1),IQ(LCONT+1),NW) * New (30/07/92) 2-D contents bank has 2 structural links. If old histogram * was old style, NTOT should should be increased by 2! IF(IB(JCONT-2).EQ.0)IQ(LCID+KNTOT)=IQ(LCID+KNTOT)+2 * *????????????? Should copy LFUNC and LHFIT structures here. * * PROX * IF(LB(JCID-2).NE.0)THEN JCONT=LB(JCID-2)-KOF NBPROX=IB(JCONT+KNBIT) IF(NBPROX.GE.32)THEN IODES=IOCF1 ELSE IODES=IOCB1 ENDIF NW=IB(JCONT-1) CALL MZBOOK(IHDIV,LCONT,LCID,-2,'PROX',2,2,NW,IODES,0) CALL UCOPY(IB(JCONT+1),IQ(LCONT+1),NW) IF(LB(JCONT).NE.0)THEN JW=LB(JCONT)-KOF NW=IB(JW-1) CALL MZBOOK(IHDIV,LW,LCONT,0,'PRXE',0,0,NW,3,0) CALL UCOPY(IB(JW+1),IQ(LW+1),NW) ENDIF IF(LB(JCONT-1).NE.0)THEN JFUNC=LB(JCONT-1)-KOF NW=IB(JFUNC-1) CALL MZBOOK(IHDIV,LFUNC,LCONT,-1,'HFUN',0,0,NW,IOCF2,0) CALL UCOPY(IB(JFUNC+1),IQ(LFUNC+1),NW) ENDIF ENDIF * * PROY * IF(LB(JCID-3).NE.0)THEN JCONT=LB(JCID-3)-KOF NBPROX=IB(JCONT+KNBIT) IF(NBPROX.GE.32)THEN IODES=IOCF1 ELSE IODES=IOCB1 ENDIF NW=IB(JCONT-1) CALL MZBOOK(IHDIV,LCONT,LCID,-3,'PROY',2,2,NW,IODES,0) CALL UCOPY(IB(JCONT+1),IQ(LCONT+1),NW) IF(LB(JCONT).NE.0)THEN JW=LB(JCONT)-KOF NW=IB(JW-1) CALL MZBOOK(IHDIV,LW,LCONT,0,'PRYE',0,0,NW,3,0) CALL UCOPY(IB(JW+1),IQ(LW+1),NW) ENDIF IF(LB(JCONT-1).NE.0)THEN JFUNC=LB(JCONT-1)-KOF NW=IB(JFUNC-1) CALL MZBOOK(IHDIV,LFUNC,LCONT,-1,'HFUN',0,0,NW,IOCF2,0) CALL UCOPY(IB(JFUNC+1),IQ(LFUNC+1),NW) ENDIF ENDIF * * SLIX * IF(LB(JCID-4).NE.0)THEN JSLIX=LB(JCID-4) DO 40 I=1,IB(JSLIX-2) ** CALL HREZ0(LQ(LSLIX-I)) 40 CONTINUE ENDIF * * SLIY * IF(LB(JCID-5).NE.0)THEN JSLIY=LB(JCID-5) DO 50 I=1,IB(JSLIY-2) ** CALL HREZ0(LQ(LSLIY-I)) 50 CONTINUE ENDIF * * BANX * JBANX=LB(JCID-6) 60 IF(JBANX.NE.0)THEN ** CALL HREZ0(LQ(LBANX-1)) JBANX=LB(JBANX) IF(JBANX.NE.0)GO TO 60 ENDIF * * BANY * JBANY=LB(JCID-7) 70 IF(JBANY.NE.0)THEN ** CALL HREZ0(LQ(LBANY-1)) JBANY=LB(JBANY) IF(JBANY.NE.0)GO TO 70 ENDIF 99 RETURN END