*------------------------------------------------------------------------------- * * This file contains the hbook's package subset needed to build h2root. * It cannot be used by any hbook application because many hbook functionalities * are missing. * *------------------------------------------------------------------------------- SUBROUTINE HNTVAR2(ID1,IVAR,CHTAG,CHFULL,BLOCK,NSUB,ITYPE,ISIZE + ,NBITS,IELEM) INTEGER ZBITS, ZNDIM, ZNOENT, ZNPRIM, ZNRZB, ZIFCON, + ZIFNAM, ZIFCHA, ZIFINT, ZIFREA, ZNWTIT, ZITIT1, + ZNCHRZ, ZDESC, ZLNAME, ZNAME, ZARIND, ZRANGE, ZNADDR, + ZIBLOK, ZNBLOK, ZLCONT, ZIFBIT, ZIBANK, ZIFTMP, ZITMP, + ZID, ZNTMP, ZNTMP1, ZLINK PARAMETER(ZBITS=1, ZNDIM=2, ZNOENT=3, ZNPRIM=4, ZLCONT=6, + ZNRZB=5, ZIFCON=7, ZIFNAM=4, ZIFCHA=5, ZIFINT=6, + ZIFREA=7, ZNWTIT=8, ZITIT1=9, ZNCHRZ=13, ZIFBIT=8, + ZDESC=1, ZLNAME=2, ZNAME=3, ZRANGE=4, ZNADDR=12, + ZARIND=11, ZIBLOK=8, ZNBLOK=10, ZIBANK=9, ZIFTMP=11, + ZID=12, ZITMP=10, ZNTMP=6, ZNTMP1=3, ZLINK=6) INTEGER ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV COMMON/HCFLAG/ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/BIGBUF/BIGB(4000000) character BIGB COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) INTEGER I1, I2, I3, I4, I5, I6, I7, I8, + I9, I10, I11, I12, I13, I14, I15, I16, +I17, I18, I19, I20, I21, I22, I23, I24, I25, I26, I27, +I28, I29, I30, I31, I32, I33, I34, I35, I123, I230 COMMON / HCBITS / I1, I2, I3, I4, I5, I6, I7, I8, + I9, I10, I11, I12, I13, I14, I15, I16, +I17, I18, I19, I20, I21, I22, I23, I24, I25, I26, I27, +I28, I29, I30, I31, I32, I33, I34, I35, I123, I230 CHARACTER*(*) CHTAG, CHFULL, BLOCK CHARACTER*80 VAR CHARACTER*32 NAME, SUBS LOGICAL LDUM ID = ID1 IDPOS = LOCATI(IQ(LTAB+1),IQ(LCDIR+KNRH),ID) IF (IDPOS .LE. 0) THEN print*,'Unknown N-tuple','HNTVAR',ID1 RETURN ENDIF LCID = LQ(LTAB-IDPOS) CHTAG = ' ' NAME = ' ' BLOCK = ' ' NSUB = 0 ITYPE = 0 ISIZE = 0 IELEM = 0 ICNT = 0 IF (IVAR .GT. IQ(LCID+ZNDIM)) RETURN LBLOK = LQ(LCID-1) LCHAR = LQ(LCID-2) LINT = LQ(LCID-3) LREAL = LQ(LCID-4) 5 LNAME = LQ(LBLOK-1) IOFF = 0 NDIM = IQ(LBLOK+ZNDIM) DO 10 I = 1, NDIM ICNT = ICNT + 1 IF (ICNT .EQ. IVAR) THEN CALL HNDESC(IOFF, NSUB, ITYPE, ISIZE, NBITS, LDUM) LL = IQ(LNAME+IOFF+ZLNAME) LV = IQ(LNAME+IOFF+ZNAME) CALL UHTOC(IQ(LCHAR+LV), 4, NAME, LL) CALL UHTOC(IQ(LBLOK+ZIBLOK), 4, BLOCK, 8) IELEM = 1 IF (NSUB .GT. 0) THEN VAR = NAME(1:LL)//'[' DO 25 J = NSUB,1,-1 LP = IQ(LINT+IQ(LNAME+IOFF+ZARIND)+(J-1)) IF (LP .LT. 0) THEN IE = -LP CALL HITOC(IE, SUBS, LL, IERR) ELSE LL = IQ(LNAME+LP-1+ZLNAME) LV = IQ(LNAME+LP-1+ZNAME) CALL UHTOC(IQ(LCHAR+LV), 4, SUBS, LL) LL1 = IQ(LNAME+LP-1+ZRANGE) IE = IQ(LINT+LL1+1) ENDIF IELEM = IELEM*IE IF (J .EQ. NSUB) THEN VAR = VAR(1:LENOCC(VAR))//SUBS(1:LL) ELSE VAR = VAR(1:LENOCC(VAR))//']['//SUBS(1:LL) ENDIF 25 CONTINUE VAR = VAR(1:LENOCC(VAR))//']' ELSE VAR = NAME(1:LL) ENDIF CHTAG = NAME CHFULL = VAR RETURN ENDIF IOFF = IOFF + ZNADDR 10 CONTINUE LBLOK = LQ(LBLOK) IF (LBLOK .NE. 0) GOTO 5 END *------------------------------------------------------------------------------- subroutine hntvar3(id,last,chvar) character *80 allvars common/callvars/allvars(100) common/calloff/ioffset(100) character *(*) chvar integer id,ivar,last save ivar data ivar/0/ if (ivar.ne.0) then if (allvars(ivar).ne.chvar) then ivar = ivar+1 allvars(ivar) = chvar ioffset(ivar) = 0 endif else ivar = ivar+1 allvars(ivar) = chvar ioffset(ivar) = 0 endif ier = 0 if (last.ne.0) then call hgnt1(id,'*',allvars,ioffset,-ivar,1,ier) allvars(1) = ' ' ivar = 0 endif end *------------------------------------------------------------------------------- SUBROUTINE HLIMIT (LIMIT) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) COMMON/HCFORM/IODIR,IOH1,IOH2,IOHN,IOCF1,IOCF2,IOCB1,IOCB2, + IOCF4,IOFIT,IONT,IOBL,IOCC PARAMETER (NLPATM=100, MXFILES=50, LENHFN=128) COMMON /HCDIRN/NLCDIR,NLNDIR,NLPAT,ICDIR,NCHTOP,ICHTOP(MXFILES) + ,ICHTYP(MXFILES),ICHLUN(MXFILES) CHARACTER*16 CHNDIR, CHCDIR, CHPAT ,CHTOP COMMON /HCDIRC/CHCDIR(NLPATM),CHNDIR(NLPATM),CHPAT(NLPATM) + ,CHTOP(NLPATM) CHARACTER*(LENHFN) HFNAME COMMON /HCFILE/HFNAME(MXFILES) CALL HMACHI NHBOOK = IABS(LIMIT) IF (NHBOOK.LT.10000) NHBOOK=10000 IF (LIMIT.GT.0) CALL MZEBRA(-3) IF(LIMIT.NE.0)CALL MZPAW(NHBOOK,' ') CALL MZLINK(IXPAWC,'/HCBOOK/',LHBOOK,LCDIR,LCIDN) IHWORK = IXPAWC+1 IHDIV = IXPAWC+2 CALL MZFORM('HDIR','4H -I',IODIR) CALL MZFORM('HID1','1B 2I 6F -H',IOH1) CALL MZFORM('HID2','1B 2I 3F 1I 4F -H',IOH2) CALL MZFORM('HIDN','11I -H',IOHN) CALL MZFORM('HIDT','13I -H',IONT) CALL MZFORM('HBLK','7I -H',IOBL) CALL MZFORM('HCF1','2I 2F 4D -F',IOCF1) CALL MZFORM('HCB1','2I 2F 4D -B',IOCB1) CALL MZFORM('HCF2','2I -F',IOCF2) CALL MZFORM('HCF4','4I -F',IOCF4) CALL MZFORM('HCB2','2I -B',IOCB2) CALL MZFORM('HFIT','5I 5F -D',IOFIT) CALL MZFORM('LCHX','2I -H',IOCC) CALL MZBOOK(IHDIV,LCDIR,LHBOOK, 1,'HDIR',50,8,10,IODIR,0) CALL UCTOH('PAWC ',IQ(LCDIR+1),4,16) CALL MZBOOK(IHDIV,LTAB ,LHBOOK,-3,'HTAB',500,0,500,2,0) LMAIN = LHBOOK NLCDIR = 1 NLPAT = 1 CHCDIR(1) = 'PAWC' NCHTOP = 1 CHTOP(1) = 'PAWC' HFNAME(1) = 'COMMON /PAWC/ in memory' ICHTOP(1) = 0 ICHLUN(1) = 0 ICDIR = 1 END *------------------------------------------------------------------------------- SUBROUTINE HROPEN(LUN,CHDIR,CFNAME,CHOPTT,LRECL,ISTAT) PARAMETER (NLPATM=100, MXFILES=50, LENHFN=128) COMMON /HCDIRN/NLCDIR,NLNDIR,NLPAT,ICDIR,NCHTOP,ICHTOP(MXFILES) + ,ICHTYP(MXFILES),ICHLUN(MXFILES) CHARACTER*16 CHNDIR, CHCDIR, CHPAT ,CHTOP COMMON /HCDIRC/CHCDIR(NLPATM),CHNDIR(NLPATM),CHPAT(NLPATM) + ,CHTOP(NLPATM) CHARACTER*(LENHFN) HFNAME COMMON /HCFILE/HFNAME(MXFILES) COMMON/QUEST/IQUEST(100) CHARACTER*(*) CFNAME,CHDIR,CHOPTT CHARACTER*8 CHOPT CHOPT=CHOPTT CALL CLTOU(CHOPT) DO 10 I=1,NCHTOP IF(CFNAME.EQ.HFNAME(I))THEN print*, 'File already connected','HROPEN',0 GO TO 99 ENDIF 10 CONTINUE IQ10=IQUEST(10) IF (INDEX(CHOPT,'F').EQ.0) THEN IC = MIN(LENOCC(CHOPT)+1,8) CHOPT(IC:IC) = 'C' ENDIF CALL RZOPEN(LUN,CHDIR,CFNAME,CHOPT,LRECL,ISTAT) 90 IF(ISTAT.NE.0)THEN print*, 'Cannot open file','HROPEN',0 GO TO 99 ENDIF IF (IQUEST(12).NE.0 ) THEN IC = MIN(LENOCC(CHOPT)+1,8) CHOPT(IC:IC) = 'X' ENDIF LRE=IQUEST(10) IQUEST(10)=IQ10 IQUEST(99)=LRE CALL HRFILE(LUN,CHDIR,CHOPT) IF(IQUEST(1).NE.0)THEN ISTAT=IQUEST(1) print*,'>>>>>> CALL RZEND(CHDIR)' ****** CALL RZEND(CHDIR) CLOSE(LUN) GO TO 90 ENDIF IF(ICDIR.GT.0)HFNAME(ICDIR)=CFNAME IF(INDEX(CHOPT,'Q').EQ.0)IQUEST(10)=LRE 99 RETURN END *------------------------------------------------------------------------------- SUBROUTINE HRFILE(LUN,CHDIR,CHOPT) PARAMETER (NLPATM=100, MXFILES=50, LENHFN=128) COMMON /HCDIRN/NLCDIR,NLNDIR,NLPAT,ICDIR,NCHTOP,ICHTOP(MXFILES) + ,ICHTYP(MXFILES),ICHLUN(MXFILES) CHARACTER*16 CHNDIR, CHCDIR, CHPAT ,CHTOP COMMON /HCDIRC/CHCDIR(NLPATM),CHNDIR(NLPATM),CHPAT(NLPATM) + ,CHTOP(NLPATM) CHARACTER*(LENHFN) HFNAME COMMON /HCFILE/HFNAME(MXFILES) CHARACTER*128 CHMAIL COMMON /HCMAIL/CHMAIL COMMON/QUEST/IQUEST(100) CHARACTER*(*) CHDIR,CHOPT CHARACTER*8 TAGS(2),CHOPTT DIMENSION IOPT(6) EQUIVALENCE (IOPTN,IOPT(1)),(IOPTG,IOPT(2)),(IOPTQ,IOPT(3)) EQUIVALENCE (IOPTM,IOPT(4)),(IOPTO,IOPT(5)),(IOPTE,IOPT(6)) IF(NCHTOP.GE.MXFILES)THEN print*, 'Too many open files','HRFILE',LUN GO TO 99 ENDIF CALL HUOPTC(CHOPT,'NGQMOE',IOPT) IF(IOPTM.NE.0)IOPTG=1 IQUEST(1)=0 IF(IOPTG.EQ.0)THEN IF(IOPTN.NE.0)THEN IF(IOPTQ.NE.0)THEN NQUOT=IQUEST(10) IF(NQUOT.LT.100)NQUOT=100 IF(NQUOT.GT.65000.AND.IOPTE.EQ.0)NQUOT=65000 ELSE NQUOT=32000 ENDIF TAGS(1) = 'HBOOK-ID' TAGS(2) = 'VARIABLE' NCH=LENOCC(CHOPT) IF(NCH.EQ.0)THEN CHOPTT='X' ELSE CHOPTT='X'//CHOPT(1:NCH) ENDIF CALL CLTOU(CHOPTT) I=INDEX(CHOPTT,'N') IF(I.NE.0)CHOPTT(I:I)='?' I=INDEX(CHOPTT,'E') IF(I.NE.0)CHOPTT(I:I)='N' IF(IOPTO.NE.0)THEN NWK=1 CHOPTT(1:1)='?' ELSE NWK=2 ENDIF IQ10=IQUEST(10) IF(INDEX(CHOPT,'C').NE.0) IQUEST(10)=IQUEST(99) print*,'>>>>>> CALL RZMAKE(...)' ****** CALL RZMAKE(LUN,CHDIR,NWK,'II',TAGS,NQUOT,CHOPTT) IQUEST(10)=IQ10 ELSE IQ10=IQUEST(10) IF(INDEX(CHOPT,'C').NE.0) IQUEST(10)=IQUEST(99) CALL RZFILE(LUN,CHDIR,CHOPT) IQUEST(10)=IQ10 IF(IQUEST(1).EQ.2)IQUEST(1)=0 NWK=IQUEST(8) ENDIF ENDIF IF(IQUEST(1).NE.0)RETURN NCHTOP=NCHTOP+1 CHTOP(NCHTOP)=CHDIR ICHLUN(NCHTOP)=0 IF(IOPTG.EQ.0)THEN ICHTOP(NCHTOP)=LUN ICHTYP(NCHTOP)=NWK HFNAME(NCHTOP)=CHDIR ELSE ICHTOP(NCHTOP)=-LOCF(LUN) ICHTYP(NCHTOP)=0 IF(IOPTM.EQ.0)THEN HFNAME(NCHTOP)='Global section - '//CHDIR ELSE HFNAME(NCHTOP)='Global memory - '//CHDIR ENDIF ENDIF 10 CHMAIL='//'//CHTOP(NCHTOP) CALL HCDIR(CHMAIL,' ') 99 RETURN END *------------------------------------------------------------------------------- SUBROUTINE HRIN(IDD,ICYCLE,KOFSET) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) PARAMETER (NLPATM=100, MXFILES=50, LENHFN=128) COMMON /HCDIRN/NLCDIR,NLNDIR,NLPAT,ICDIR,NCHTOP,ICHTOP(MXFILES) + ,ICHTYP(MXFILES),ICHLUN(MXFILES) CHARACTER*16 CHNDIR, CHCDIR, CHPAT ,CHTOP COMMON /HCDIRC/CHCDIR(NLPATM),CHNDIR(NLPATM),CHPAT(NLPATM) + ,CHTOP(NLPATM) CHARACTER*(LENHFN) HFNAME COMMON /HCFILE/HFNAME(MXFILES) INTEGER ZBITS, ZNDIM, ZNOENT, ZNPRIM, ZNRZB, ZIFCON, + ZIFNAM, ZIFCHA, ZIFINT, ZIFREA, ZNWTIT, ZITIT1, + ZNCHRZ, ZDESC, ZLNAME, ZNAME, ZARIND, ZRANGE, ZNADDR, + ZIBLOK, ZNBLOK, ZLCONT, ZIFBIT, ZIBANK, ZIFTMP, ZITMP, + ZID, ZNTMP, ZNTMP1, ZLINK PARAMETER(ZBITS=1, ZNDIM=2, ZNOENT=3, ZNPRIM=4, ZLCONT=6, + ZNRZB=5, ZIFCON=7, ZIFNAM=4, ZIFCHA=5, ZIFINT=6, + ZIFREA=7, ZNWTIT=8, ZITIT1=9, ZNCHRZ=13, ZIFBIT=8, + ZDESC=1, ZLNAME=2, ZNAME=3, ZRANGE=4, ZNADDR=12, + ZARIND=11, ZIBLOK=8, ZNBLOK=10, ZIBANK=9, ZIFTMP=11, + ZID=12, ZITMP=10, ZNTMP=6, ZNTMP1=3, ZLINK=6) COMMON /HNTCUR/ NTCUR INTEGER ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV COMMON/HCFLAG/ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV COMMON/QUEST/IQUEST(100) CHARACTER*128 CHWOLD INTEGER KEYS(2) DATA KHIDE,KHID1,KHID2,KHCO1,KHCO2/4HHIDE,4HHID1,4HHID2, + 4hHCO1,4HHCO2/ IOFSET=KOFSET IF(ICHTOP(ICDIR).LT.0)THEN print*, '>>>>>> HRIN: ICHTOP(ICDIR).LT.0' ENDIF IF(ICYCLE.GT.1000.AND.IDD.EQ.0)THEN CALL HPAFF(CHCDIR,NLCDIR,CHWOLD) LQ(LHBOOK-NLPAT-10)=LCDIR ENDIF NRHIST=IQ(LCDIR+KNRH) IF(KOFSET.EQ.99999.AND.NRHIST.GT.0)THEN IF(IQ(LTAB+NRHIST).GE.KOFSET)IOFSET=IQ(LTAB+NRHIST)+1000000 ENDIF KEYS(2) = 0 IQ42=0 IDN=IDD IF(IDD.EQ.0)THEN KEYS(1) = 1 CALL HRZIN(IHDIV,0,0,KEYS,9999,'SC') IDN=IQUEST(21) IQ42=IQUEST(22) ENDIF 10 ID=IDN+IOFSET NRHIST=IQ(LCDIR+KNRH) IDPOS=LOCATI(IQ(LTAB+1),NRHIST,ID) INMEM=0 IF(IDPOS.GT.0)THEN LC=LQ(LTAB-IDPOS) IF(JBIT(IQ(LC),5).EQ.0)THEN INMEM=1 ELSE print*, '+Already existing histogram replaced','HRIN',ID CALL HDELET(ID) NRHIST=IQ(LCDIR+KNRH) IDPOS=-IDPOS+1 ENDIF ENDIF KEYS(1) = IDN KEYS(2) = IQ42 CALL HRZIN(IHDIV,0,0,KEYS,ICYCLE,'NC') IF(IQUEST(1).NE.0)GO TO 70 IQ40=IQUEST(40) IQ41=IQUEST(41) IQ42=IQUEST(42) NWORDS=IQUEST(12) IOPTA=JBIT(IQUEST(14),4) IF(IOPTA.NE.0)GO TO 60 IF(INMEM.NE.0)GO TO 60 CALL HSPACE(NWORDS+1000,'HRIN ',IDD) IF(IERR.NE.0) GO TO 70 IDPOS=-IDPOS+1 IF(NRHIST.GE.IQ(LTAB-1))THEN CALL MZPUSH(IHDIV,LTAB,500,500,' ') ENDIF DO 20 I=NRHIST,IDPOS,-1 IQ(LTAB+I+1)=IQ(LTAB+I) LQ(LTAB-I-1)=LQ(LTAB-I) 20 CONTINUE IF(LIDS.EQ.0)THEN KEYS(1) = IDN CALL HRZIN(IHDIV,LCDIR,-2,KEYS,ICYCLE,'ND') IF(IQUEST(1).NE.0)THEN print*, 'Bad sequence for RZ','HRIN',IDN GO TO 70 ENDIF LIDS=LQ(LCDIR-2) LCID=LIDS ELSE LLID=LQ(LCDIR-9) KEYS(1) = IDN CALL HRZIN(IHDIV,LLID, 0,KEYS,ICYCLE,'ND') IF(IQUEST(1).NE.0)THEN print*, 'Bad sequence for RZ','HRIN',IDN GO TO 70 ENDIF LCID=LQ(LLID) ENDIF IQ(LCID-5)=ID LQ(LCDIR-9)=LCID IQ(LCDIR+KNRH)=IQ(LCDIR+KNRH)+1 IQ(LTAB+IDPOS)=ID LQ(LTAB-IDPOS)=LCID CALL SBIT1(IQ(LCID),5) IF(JBIT(IQ(LCID+KBITS),1).NE.0)THEN IF(IQ(LCID-4).EQ.KHIDE)THEN IQ(LCID-4)=KHID1 L=LQ(LCID-1) IF(L.NE.0)IQ(L-4)=KHCO1 ENDIF ENDIF IF(JBYT(IQ(LCID+KBITS),2,2).NE.0)THEN IF(IQ(LCID-4).EQ.KHIDE)THEN IQ(LCID-4)=KHID2 L=LQ(LCID-1) IF(L.NE.0)IQ(L-4)=KHCO2 ENDIF ENDIF IF(JBIT(IQ(LCID+KBITS),4).NE.0)THEN IF (IQ(LCID-2) .EQ. 2) THEN NCHRZ=IQ(LCID+11) IF(NCHRZ.LE.0)GO TO 30 ITAG1=IQ(LCID+10) NW=IQ(LCID-1)-ITAG1+1 NPLUS=32-ITAG1 IF(NPLUS.GT.0)THEN CALL MZPUSH(IHDIV,LCID,0,NPLUS,' ') CALL UCOPY2(IQ(LCID+ITAG1),IQ(LCID+32),NW) IQ(LCID+9)=IQ(LCID+9)+NPLUS IQ(LCID+10)=32 ENDIF CALL HPAFF(CHCDIR,NLCDIR,CHWOLD) NCHRZ=LENOCC(CHWOLD) CALL UCTOH(CHWOLD,IQ(LCID+12),4,NCHRZ) IQ(LCID+11)=NCHRZ 30 IQ(LCID)=9999 LC=LQ(LCID-1) CALL SBIT0(IQ(LC),1) IF(NCHRZ.LE.0)THEN NMORE=IQ(LCID+5)+3-IQ(LCID-3) IF(NMORE.GT.0)THEN CALL MZPUSH(IHDIV,LCID,NMORE,0,' ') ENDIF IF(IQ(LCID+5).GE.1)THEN DO 40 IB=1,IQ(LCID+5) LQ(LCID-3-IB)=LC LC=LQ(LC) IF(LC.EQ.0)THEN LC=LQ(LCID-1) GO TO 60 ENDIF 40 CONTINUE LC=LQ(LCID-1) ENDIF ELSE IF(ICHTOP(ICDIR).LT.1000) THEN print*, '>>>>>> CALL HRZKEY(IDN)' ****** CALL HRZKEY(IDN) ENDIF IQ(LCID+5)=IDN ENDIF GO TO 60 ELSE NCHRZ=IQ(LCID+ZNCHRZ) IF(NCHRZ.LE.0)GO TO 50 ITIT1=IQ(LCID+ZITIT1) NW=IQ(LCID-1)-ITIT1+1 NPLUS=34-ITIT1 IF(NPLUS.GT.0)THEN CALL MZPUSH(IHDIV,LCID,0,NPLUS,' ') CALL UCOPY2(IQ(LCID+ITIT1),IQ(LCID+34),NW) IQ(LCID+ZITIT1)=34 ENDIF CALL HPAFF(CHCDIR,NLCDIR,CHWOLD) NCHRZ=LENOCC(CHWOLD) CALL UCTOH(CHWOLD,IQ(LCID+ZNCHRZ+1),4,NCHRZ) IQ(LCID+ZNCHRZ)=NCHRZ 50 IQ(LCID)=9999 LC = LQ(LCID-1) CALL SBIT0(IQ(LC),1) CALL SBIT0(IQ(LC),2) CALL SBIT0(IQ(LC),3) CALL HNMSET(ID,ZIBANK,0) CALL HNMSET(ID,ZITMP,0) IQ(LCID+ZIFTMP) = 2 IQ(LCID+ZID) = IDN NTCUR = 0 GO TO 60 ENDIF ENDIF 60 IF(IQ40.EQ.0)GO TO 80 IDN=IQ41 IF(IDD.EQ.0)GO TO 10 70 CONTINUE 80 RETURN END *------------------------------------------------------------------------------- SUBROUTINE HRZIN(IXDIV,LBANK,JBIAS,KEYS,ICYCLE,CHOPT) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) PARAMETER (NLPATM=100, MXFILES=50, LENHFN=128) COMMON /HCDIRN/NLCDIR,NLNDIR,NLPAT,ICDIR,NCHTOP,ICHTOP(MXFILES) + ,ICHTYP(MXFILES),ICHLUN(MXFILES) CHARACTER*16 CHNDIR, CHCDIR, CHPAT ,CHTOP COMMON /HCDIRC/CHCDIR(NLPATM),CHNDIR(NLPATM),CHPAT(NLPATM) + ,CHTOP(NLPATM) CHARACTER*(LENHFN) HFNAME COMMON /HCFILE/HFNAME(MXFILES) CHARACTER*128 CHMAIL COMMON /HCMAIL/CHMAIL COMMON/QUEST/IQUEST(100) DIMENSION LBANK(1),JBIAS(1) INTEGER KEYS(2) CHARACTER*(*)CHOPT CHARACTER*1 FCHOPT CHARACTER*8 CHOPT1 IF(ICHTOP(ICDIR).GT.1000)THEN print*, 'CZ option not active','HRZIN',0 RETURN ENDIF CALL RZIN(IXDIV,LBANK,JBIAS,KEYS,ICYCLE,CHOPT) END *------------------------------------------------------------------------------- SUBROUTINE HNOENT(IDD,NUMB) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) COMMON /QUEST/ IQUEST(100) CALL HFIND(IDD,'HNOENT') IF(IQUEST(1).NE.0)THEN NUMB=0 ELSE I4=JBIT(IQ(LCID+KBITS),4) IF(I4.NE.0)THEN NUMB=IQ(LCID+3) ELSE NUMB=IQ(LCONT+KNOENT) ENDIF ENDIF END *------------------------------------------------------------------------------- SUBROUTINE HGIVE(IDD,CHTITL,NCX,XMIN,XMAX,NCY,YMIN,YMAX,NWT,IDB) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) INTEGER ZBITS, ZNDIM, ZNOENT, ZNPRIM, ZNRZB, ZIFCON, + ZIFNAM, ZIFCHA, ZIFINT, ZIFREA, ZNWTIT, ZITIT1, + ZNCHRZ, ZDESC, ZLNAME, ZNAME, ZARIND, ZRANGE, ZNADDR, + ZIBLOK, ZNBLOK, ZLCONT, ZIFBIT, ZIBANK, ZIFTMP, ZITMP, + ZID, ZNTMP, ZNTMP1, ZLINK PARAMETER(ZBITS=1, ZNDIM=2, ZNOENT=3, ZNPRIM=4, ZLCONT=6, + ZNRZB=5, ZIFCON=7, ZIFNAM=4, ZIFCHA=5, ZIFINT=6, + ZIFREA=7, ZNWTIT=8, ZITIT1=9, ZNCHRZ=13, ZIFBIT=8, + ZDESC=1, ZLNAME=2, ZNAME=3, ZRANGE=4, ZNADDR=12, + ZARIND=11, ZIBLOK=8, ZNBLOK=10, ZIBANK=9, ZIFTMP=11, + ZID=12, ZITMP=10, ZNTMP=6, ZNTMP1=3, ZLINK=6) INTEGER I1, I2, I3, I4, I5, I6, I7, I8, + I9, I10, I11, I12, I13, I14, I15, I16, +I17, I18, I19, I20, I21, I22, I23, I24, I25, I26, I27, +I28, I29, I30, I31, I32, I33, I34, I35, I123, I230 COMMON / HCBITS / I1, I2, I3, I4, I5, I6, I7, I8, + I9, I10, I11, I12, I13, I14, I15, I16, +I17, I18, I19, I20, I21, I22, I23, I24, I25, I26, I27, +I28, I29, I30, I31, I32, I33, I34, I35, I123, I230 CHARACTER*(*) CHTITL NARG=10 NCX=0 IF(NARG.GT.5)NCY=0 IF(NARG.GT.8)NWT=0 IF(NARG.GT.9)IDB=0 CALL HFIND(IDD,'HGIVE ') IF(LCID.LE.0)GO TO 99 CALL HDCOFL IF(I4.NE.0)THEN IF (IQ(LCID-2) .NE. ZLINK) THEN NCX = IQ(LCID+2) IWT = IQ(LCID+9)+LCID NWTIT = IQ(LCID+8) ELSE NCX = IQ(LCID+ZNDIM) IWT = IQ(LCID+ZITIT1)+LCID NWTIT = IQ(LCID+ZNWTIT) ENDIF XMIN=0. XMAX=0. YMIN=0. YMAX=0. ELSE NCX=IQ(LCID+KNCX) XMIN=Q(LCID+KXMIN) XMAX=Q(LCID+KXMAX) IWT=LCID+KTIT1 IF(I230.NE.0)THEN IF(NARG.GT.5)NCY=IQ(LCID+KNCY) IF(NARG.GT.6)YMIN=Q(LCID+KYMIN) IF(NARG.GT.7)YMAX=Q(LCID+KYMAX) IWT=LCID+KTIT2 ENDIF NWTIT=IQ(LCID-1)-IWT+LCID+1 ENDIF IF(NARG.GT.9)IDB=LCID IF(NARG.LT.9)GO TO 99 NWT=NWTIT IF(NWT.EQ.0)GO TO 99 NCH=LEN(CHTITL) NWCH=MIN(NCH,4*NWT) IF(NCH.GT.0)CHTITL=' ' CALL UHTOC(IQ(IWT),4,CHTITL,NWCH) 99 RETURN END *------------------------------------------------------------------------------- SUBROUTINE HGIVEN( ID1, CHTITL, NVAR, TAGS, RLOW, RHIGH ) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) INTEGER ZBITS, ZNDIM, ZNOENT, ZNPRIM, ZNRZB, ZIFCON, + ZIFNAM, ZIFCHA, ZIFINT, ZIFREA, ZNWTIT, ZITIT1, + ZNCHRZ, ZDESC, ZLNAME, ZNAME, ZARIND, ZRANGE, ZNADDR, + ZIBLOK, ZNBLOK, ZLCONT, ZIFBIT, ZIBANK, ZIFTMP, ZITMP, + ZID, ZNTMP, ZNTMP1, ZLINK PARAMETER(ZBITS=1, ZNDIM=2, ZNOENT=3, ZNPRIM=4, ZLCONT=6, + ZNRZB=5, ZIFCON=7, ZIFNAM=4, ZIFCHA=5, ZIFINT=6, + ZIFREA=7, ZNWTIT=8, ZITIT1=9, ZNCHRZ=13, ZIFBIT=8, + ZDESC=1, ZLNAME=2, ZNAME=3, ZRANGE=4, ZNADDR=12, + ZARIND=11, ZIBLOK=8, ZNBLOK=10, ZIBANK=9, ZIFTMP=11, + ZID=12, ZITMP=10, ZNTMP=6, ZNTMP1=3, ZLINK=6) INTEGER ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV COMMON/HCFLAG/ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV INTEGER I1, I2, I3, I4, I5, I6, I7, I8, + I9, I10, I11, I12, I13, I14, I15, I16, +I17, I18, I19, I20, I21, I22, I23, I24, I25, I26, I27, +I28, I29, I30, I31, I32, I33, I34, I35, I123, I230 COMMON / HCBITS / I1, I2, I3, I4, I5, I6, I7, I8, + I9, I10, I11, I12, I13, I14, I15, I16, +I17, I18, I19, I20, I21, I22, I23, I24, I25, I26, I27, +I28, I29, I30, I31, I32, I33, I34, I35, I123, I230 CHARACTER*(*) CHTITL, TAGS(*) INTEGER ID1, NVAR REAL RLOW(*), RHIGH(*) CHARACTER*8 BLOCK LOGICAL NTOLD NMAX = NVAR NVAR = 0 ID = ID1 IDPOS = LOCATI(IQ(LTAB+1),IQ(LCDIR+KNRH),ID) IF( IDPOS.LE.0 ) RETURN IDLAST = ID1 LCID = LQ(LTAB-IDPOS) I4 = JBIT(IQ(LCID+KBITS),4) IF( I4.EQ.0 ) RETURN IF (IQ(LCID-2) .NE. ZLINK) THEN NTOLD = .TRUE. ELSE NTOLD = .FALSE. ENDIF IF (NTOLD) THEN NDIM = IQ(LCID+2) LLIMS = LQ(LCID-2) ITAG1 = IQ(LCID+10) ITIT1 = IQ(LCID+9) NWTIT = IQ(LCID+8) ELSE NDIM = IQ(LCID+ZNDIM) ITIT1 = IQ(LCID+ZITIT1) NWTIT = IQ(LCID+ZNWTIT) ENDIF NVAR = MIN(NDIM, NMAX) NCH = LEN(CHTITL) IF (NCH .GT. 0) CHTITL = ' ' NCH = MIN( NCH, 4*NWTIT ) IF (NCH .GT. 0) CALL UHTOC( IQ(LCID+ITIT1), 4, CHTITL, NCH ) IF (NTOLD) THEN NCH = LEN( TAGS(1) ) NCH = MIN( NCH, 8 ) DO 10 I = 1, NVAR IF( NCH.GT.0 ) TAGS(I) = ' ' IF( NCH.GT.0 )THEN TAGS(I)=' ' CALL UHTOC( IQ(LCID+ITAG1+2*(I-1)), 4, TAGS(I), NCH ) ENDIF RLOW (I) = Q(LLIMS+2*I-1) RHIGH(I) = Q(LLIMS+2*I) 10 CONTINUE ELSE DO 20 I = 1, NVAR CALL HNTVAR(ID1, I, TAGS(I), BLOCK, NS, IT, IS, IE) RLOW(I) = 0.0 RHIGH(I) = 0.0 20 CONTINUE ENDIF NVAR = NDIM END *------------------------------------------------------------------------------- SUBROUTINE HGNPAR(IDN,CHROUT) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) CHARACTER*(*) CHROUT INTEGER KEYS(2) LCIDN=0 NIDN=LOCATI(IQ(LTAB+1),IQ(LCDIR+KNRH),IDN) IF(NIDN.LE.0)THEN CALL HRIN(IDN,9999,0) NIDN=LOCATI(IQ(LTAB+1),IQ(LCDIR+KNRH),IDN) IF(NIDN.LE.0)THEN print*, 'Unknown N-tuple',CHROUT,IDN RETURN ENDIF ENDIF LCIDN=LQ(LTAB-NIDN) I4=JBIT(IQ(LCIDN+KBITS),4) IF(I4.EQ.0)THEN print*, 'Not a N-tuple',CHROUT,IDN RETURN ENDIF IF (IQ(LCIDN-2) .NE. 2) THEN print*,'New N-tuple, this routine works only for old '// + 'N-tuples',CHROUT,IDN RETURN ENDIF NCHRZ=IQ(LCIDN+11) IF(NCHRZ.EQ.0)THEN NMORE=IQ(LCIDN+5)+3-IQ(LCIDN-3) IF(NMORE.GT.0)THEN CALL MZPUSH(IHDIV,LCIDN,NMORE,0,' ') LC=LQ(LCIDN-1) IF(IQ(LCIDN+5).GE.1)THEN DO 10 IB=1,IQ(LCIDN+5) LQ(LCIDN-3-IB)=LC LC=LQ(LC) IF(LC.EQ.0)GO TO 999 10 CONTINUE ENDIF GO TO 999 ENDIF ENDIF LC=LQ(LCIDN-1) IF(JBIT(IQ(LC),1).NE.0)THEN CALL SBIT0(IQ(LC),1) KEYS(1) = IDN KEYS(2) = 0 print*, '>>>>>> HRZOUT' ****** CALL HRZOUT(IHDIV,LCIDN,KEYS,ICYCLE,' ') ENDIF 999 END *------------------------------------------------------------------------------- SUBROUTINE HGNF(IDN,IDNEVT,X,IERROR) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) PARAMETER (NLPATM=100, MXFILES=50, LENHFN=128) COMMON /HCDIRN/NLCDIR,NLNDIR,NLPAT,ICDIR,NCHTOP,ICHTOP(MXFILES) + ,ICHTYP(MXFILES),ICHLUN(MXFILES) CHARACTER*16 CHNDIR, CHCDIR, CHPAT ,CHTOP COMMON /HCDIRC/CHCDIR(NLPATM),CHNDIR(NLPATM),CHPAT(NLPATM) + ,CHTOP(NLPATM) CHARACTER*(LENHFN) HFNAME COMMON /HCFILE/HFNAME(MXFILES) COMMON/QUEST/IQUEST(100) DIMENSION X(*) INTEGER KEYS(2) LC=LQ(LCIDN-1) NEVB=IQ(LC-1)/IQ(LCIDN+2) IBANK=(IDNEVT-1)/NEVB + 1 IF(IQ(LCIDN+11).EQ.0)THEN LC=LQ(LCIDN-3-IBANK) ELSE IF(IQ(LCIDN).EQ.IBANK.OR.IQ(LCIDN+6).EQ.0)GO TO 20 IF(IBANK.LE.IQ(LCIDN+6))THEN LKEY=LQ(LC) IF(LKEY.GT.0)THEN KEYS(1)=IQ(LKEY+IBANK) CALL HRZIN(IHDIV,LCIDN,-1,KEYS,99999,'RS') ELSE IF(ICHTYP(ICDIR).EQ.1)THEN KEYS(1) = IQ(LCIDN+5)+10000*IBANK KEYS(2) = 0 ELSE KEYS(1) = IQ(LCIDN+5) KEYS(2) = IBANK ENDIF CALL HRZIN(IHDIV,LCIDN,-1,KEYS,99999,'R') IF(IQUEST(1).NE.0)GO TO 90 ENDIF ELSE IOFSET=IDN-IQ(LCIDN+5) CALL HDELET(IDN) CALL HRIN(IDN-IOFSET,99999,IOFSET) NIDN=LOCATI(IQ(LTAB+1),IQ(LCDIR+KNRH),IDN) LCIDN=LQ(LTAB-NIDN) ENDIF LC=LQ(LCIDN-1) IQ(LCIDN)=IBANK ENDIF 20 IERROR=0 IAD=IQ(LCIDN+2)*(IDNEVT-NEVB*(IBANK-1)-1) DO 30 I=1,IQ(LCIDN+2) X(I)=Q(LC+IAD+I) 30 CONTINUE RETURN 90 IERROR=1 END *------------------------------------------------------------------------------- SUBROUTINE HGNT(IDN,IDNEVT,IERROR) CALL HGNT1(IDN, '*', '*', 0, 0, IDNEVT, IERROR) END *------------------------------------------------------------------------------- SUBROUTINE HGNT1(IDD,BLKNA1,VAR,IOFFST,NVAR,IDNEVT,IERROR) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) INTEGER ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV COMMON/HCFLAG/ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV INTEGER ZBITS, ZNDIM, ZNOENT, ZNPRIM, ZNRZB, ZIFCON, + ZIFNAM, ZIFCHA, ZIFINT, ZIFREA, ZNWTIT, ZITIT1, + ZNCHRZ, ZDESC, ZLNAME, ZNAME, ZARIND, ZRANGE, ZNADDR, + ZIBLOK, ZNBLOK, ZLCONT, ZIFBIT, ZIBANK, ZIFTMP, ZITMP, + ZID, ZNTMP, ZNTMP1, ZLINK PARAMETER(ZBITS=1, ZNDIM=2, ZNOENT=3, ZNPRIM=4, ZLCONT=6, + ZNRZB=5, ZIFCON=7, ZIFNAM=4, ZIFCHA=5, ZIFINT=6, + ZIFREA=7, ZNWTIT=8, ZITIT1=9, ZNCHRZ=13, ZIFBIT=8, + ZDESC=1, ZLNAME=2, ZNAME=3, ZRANGE=4, ZNADDR=12, + ZARIND=11, ZIBLOK=8, ZNBLOK=10, ZIBANK=9, ZIFTMP=11, + ZID=12, ZITMP=10, ZNTMP=6, ZNTMP1=3, ZLINK=6) COMMON /HNTCUR/ NTCUR CHARACTER*(*) BLKNA1, VAR(*) CHARACTER*8 BLKNAM, BLKSAV INTEGER HNBPTR, IOFFST(*) LOGICAL ALLBLK SAVE BLKSAV DATA BLKSAV /' '/ IERR = 0 IERR1 = 0 IERROR = 0 IF (IDD.NE.IDLAST .OR. NTCUR.EQ.0) THEN CALL HPARNT(IDD,'HGNT') IF (IDD .EQ. 0) GOTO 20 IDLAST = IDD BLKSAV = ' ' ENDIF IF (LCID .LE. 0) GOTO 20 CALL HNBUFR(IDD) IF (IERR .NE. 0) GOTO 20 NTCUR = IDD IF (IDNEVT .LE. 0) GOTO 20 BLKNAM = BLKNA1 ALLBLK = .FALSE. IF (BLKNAM(1:1) .EQ. '*') THEN ALLBLK = .TRUE. LBLOK = LQ(LCID-1) IF (IDNEVT .GT. IQ(LCID+ZNOENT)) GOTO 20 ELSEIF (BLKSAV .NE. BLKNAM) THEN LBLOK = HNBPTR(BLKNAM) IF (LBLOK .EQ. 0) THEN print*, 'Block does not exist','HGNTB',IDD GOTO 20 ENDIF BLKSAV = BLKNAM LQ(LCID-8) = LBLOK IF (IDNEVT .GT. IQ(LBLOK+ZNOENT)) GOTO 20 ELSE LBLOK = LQ(LCID-8) IF (IDNEVT .GT. IQ(LBLOK+ZNOENT)) GOTO 20 ENDIF LCHAR = LQ(LCID-2) LINT = LQ(LCID-3) LREAL = LQ(LCID-4) IQ(LTMP1+1) = 0 IF (ALLBLK) THEN 10 CALL HGNT2(VAR, IOFFST, NVAR, IDNEVT, IERROR) IF (IERROR .NE. 0) IERR1 = 1 LBLOK = LQ(LBLOK) IF (LBLOK .NE. 0) GOTO 10 ELSE CALL HGNT2(VAR, IOFFST, NVAR, IDNEVT, IERROR) IF (IERROR .NE. 0) IERR1 = 1 ENDIF IF (IERR1 .EQ. 0) THEN IQ(LTMP+1) = IDNEVT ELSE IQ(LTMP+1) = 0 IERROR = 2 ENDIF RETURN 20 IERROR = 1 END *------------------------------------------------------------------------------- SUBROUTINE HGNT2(VAR1,IVOFF,NVAR1,IDNEVT,IERROR) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) INTEGER ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV COMMON/HCFLAG/ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV INTEGER ZBITS, ZNDIM, ZNOENT, ZNPRIM, ZNRZB, ZIFCON, + ZIFNAM, ZIFCHA, ZIFINT, ZIFREA, ZNWTIT, ZITIT1, + ZNCHRZ, ZDESC, ZLNAME, ZNAME, ZARIND, ZRANGE, ZNADDR, + ZIBLOK, ZNBLOK, ZLCONT, ZIFBIT, ZIBANK, ZIFTMP, ZITMP, + ZID, ZNTMP, ZNTMP1, ZLINK PARAMETER(ZBITS=1, ZNDIM=2, ZNOENT=3, ZNPRIM=4, ZLCONT=6, + ZNRZB=5, ZIFCON=7, ZIFNAM=4, ZIFCHA=5, ZIFINT=6, + ZIFREA=7, ZNWTIT=8, ZITIT1=9, ZNCHRZ=13, ZIFBIT=8, + ZDESC=1, ZLNAME=2, ZNAME=3, ZRANGE=4, ZNADDR=12, + ZARIND=11, ZIBLOK=8, ZNBLOK=10, ZIBANK=9, ZIFTMP=11, + ZID=12, ZITMP=10, ZNTMP=6, ZNTMP1=3, ZLINK=6) COMMON /HCNT/ IBIPW, IBIPB, IBYPW, ISHBIT LOGICAL NRECOV COMMON /HCRECV/ NRECOV CHARACTER*(*) VAR1(*) INTEGER IVOFF(*) CHARACTER*32 VAR INTEGER ILOGIC, HNMPTR LOGICAL LOGIC, INDVAR, ALLVAR, USEBUF, CHKOFF EQUIVALENCE (LOGIC, ILOGIC) IERROR = 0 IERR1 = 0 LNAME = LQ(LBLOK-1) CHKOFF = .FALSE. USEBUF = .FALSE. NVAR = NVAR1 IF (NVAR .LT. 0) THEN NVAR = -NVAR CHKOFF = .TRUE. ENDIF IF (NVAR .EQ. 0) THEN ALLVAR = .TRUE. IOFF = 0 NDIM = IQ(LBLOK+ZNDIM) ELSE ALLVAR = .FALSE. NDIM = NVAR ENDIF DO 40 I = 1, NDIM IF (.NOT.ALLVAR) THEN VAR = VAR1(I) print*, '>>>>>> IOFF = HNMPTR(VAR)' ****** IOFF = HNMPTR(VAR) IF (IOFF .LT. 0) GOTO 40 INDX = IOFF/ZNADDR + 1 IF (CHKOFF) THEN IF (IVOFF(I) .NE. 0) THEN USEBUF = .TRUE. IOFFST = IVOFF(I) ELSE USEBUF = .FALSE. IOFFST = 0 ENDIF ENDIF ELSE INDX = I ENDIF NSUB = JBYT(IQ(LNAME+IOFF+ZDESC), 18, 3) ITYPE = JBYT(IQ(LNAME+IOFF+ZDESC), 14, 4) ISIZE = JBYT(IQ(LNAME+IOFF+ZDESC), 8, 6) NBITS = JBYT(IQ(LNAME+IOFF+ZDESC), 1, 7) INDVAR = .FALSE. IF (JBIT(IQ(LNAME+IOFF+ZDESC),28) .EQ. 1) INDVAR = .TRUE. IF (.NOT.NRECOV .AND. IQ(LNAME+IOFF+ZNADDR).EQ.0) GOTO 35 IF (ITYPE .EQ. 5) THEN NBITS = IBIPB*ISIZE MXBY = ISHFT(ISIZE,-2) MXBY1 = MXBY IF (JBIT(IQ(LQ(LCID-1)),3) .NE. 0) MXBY1 = 8 ENDIF IF (IQ(LNAME+IOFF+ZITMP) .EQ. 0) THEN IQ(LNAME+IOFF+ZITMP) = IQ(LCID+ZIFTMP) IQ(LCID+ZIFTMP) = IQ(LCID+ZIFTMP) + ZNTMP ENDIF ITMP = IQ(LNAME+IOFF+ZITMP) IEDIF = 0 IELEM = 1 NELEM = 1 INEVT = IDNEVT DO 10 J = 1, NSUB LP = IQ(LINT+IQ(LNAME+IOFF+ZARIND)+(J-1)) IF (LP .LT. 0) THEN IELEM = IELEM*(-LP) NELEM = IELEM ELSE IF (IQ(LNAME+LP-1+ZNADDR) .EQ. 0) THEN print*,'Address of index variable not set', + 'HGNT',ID GOTO 35 ENDIF LL = IQ(LNAME+LP-1+ZRANGE) IEMAX = IELEM*IQ(LINT+LL+1) IPTMP = IQ(LNAME+LP-1+ZITMP) INEVT = (IQ(LTMP+IPTMP+4) * IELEM) + 1 IELEM = IELEM*IQ(LTMP+IPTMP+5) NELEM = 1 IEDIF = IEMAX - IELEM ENDIF 10 CONTINUE LCIND = IQ(LNAME+IOFF+ZLCONT) LRECL = IABS(IQ(LCID+ZNPRIM)) - 1 IF (IQ(LTMP+1).NE.0 .AND. IDNEVT.EQ.IQ(LTMP+1)+1) THEN IBANK = IQ(LTMP+ITMP) IFIRST = IQ(LTMP+ITMP+1) NB = IQ(LTMP+ITMP+2) NLEFT = IQ(LTMP+ITMP+3) ELSE IB = NBITS NW = 1 IF (ISIZE .GT. IBYPW) THEN NW = ISIZE/IBYPW IB = NBITS/NW ENDIF IPW = IBIPW/IB NWRD = (INEVT-1)*NELEM*NW/IPW IBANK = NWRD/LRECL + 1 IFIRST = MOD(NWRD+2, LRECL) IF (IFIRST .EQ. 0) IFIRST = LRECL IF (IFIRST .EQ. 1) IFIRST = LRECL + 1 NB = (INEVT-1)*NELEM*NW*IB - NWRD*IB*IPW NLEFT = LRECL - IFIRST + 2 NLEFT = NLEFT*IBIPW - NB ENDIF IF (IELEM .GT. 0) THEN IF (IQ(LNAME+IOFF+ZIBANK) .EQ. IBANK) THEN LR2 = LQ(LNAME-INDX) ELSE CALL HNTRD(INDX, IOFF, IBANK, IER) IF (IER .NE. 0) THEN IERR1 = 1 GOTO 32 ENDIF ENDIF ENDIF DO 30 J = 1, IELEM IM = IAND(NB, IBIPW-1) IF (IM.NE.0 .AND. NBITS.GT.IBIPW-IM) THEN NB = 0 NLEFT = NLEFT - IBIPW+IM IFIRST = IFIRST + 1 ENDIF IF (NBITS .GT. NLEFT) THEN IBANK = IBANK + 1 CALL HNTRD(INDX, IOFF, IBANK, IER) IF (IER .NE. 0) THEN IERR1 = 1 GOTO 32 ENDIF NB = 0 NLEFT = LRECL*IBIPW IFIRST = 2 ENDIF IF (NRECOV .AND. .NOT.INDVAR) GOTO 25 IF (ITYPE .EQ. 1) THEN IF (ISIZE .EQ. 4) THEN IF (NBITS .EQ. 32) THEN IF (USEBUF) THEN Q(IOFFST+1) = Q(LR2+IFIRST) ELSE Q(IQ(LNAME+IOFF+ZNADDR)+J) = Q(LR2+IFIRST) ENDIF ELSE RMIN = Q(LREAL+IQ(LNAME+IOFF+ZRANGE)) RMAX = Q(LREAL+IQ(LNAME+IOFF+ZRANGE)+1) IPACK = JBYT(IQ(LR2+IFIRST), NB+1, NBITS) IF (USEBUF) THEN Q(IOFFST+1) = IPACK * + (RMAX - RMIN)/(ISHFT(1,NBITS)-1) + RMIN ELSE Q(IQ(LNAME+IOFF+ZNADDR)+J) = IPACK * + (RMAX - RMIN)/(ISHFT(1,NBITS)-1) + RMIN ENDIF ENDIF ELSEIF (ISIZE .EQ. 8) THEN IF (NBITS .EQ. 64) THEN IF (USEBUF) THEN Q(IOFFST+1) = Q(LR2+IFIRST+1) Q(IOFFST+2) = Q(LR2+IFIRST) ELSE Q(IQ(LNAME+IOFF+ZNADDR)+2*J-1) = Q(LR2+IFIRST+1) Q(IQ(LNAME+IOFF+ZNADDR)+2*J) = Q(LR2+IFIRST) ENDIF ELSE ENDIF ENDIF ELSEIF (ITYPE .EQ. 2) THEN IF (ISIZE .EQ. 2) THEN ELSEIF (ISIZE .EQ. 4) THEN IF (INDVAR) THEN IF (USEBUF) THEN IQ(IOFFST+1) = IQ(LR2+IFIRST) - + IQ(LR2+IFIRST-1) IQ(LTMP+ITMP+5) = IQ(IOFFST+1) ELSE IQ(IQ(LNAME+IOFF+ZNADDR)+J) = IQ(LR2+IFIRST) - + IQ(LR2+IFIRST-1) IQ(LTMP+ITMP+5) = IQ(IQ(LNAME+IOFF+ZNADDR)+J) ENDIF IQ(LTMP+ITMP+4) = IQ(LR2+IFIRST-1) ELSEIF (NBITS .EQ. 32) THEN IF (USEBUF) THEN IQ(IOFFST+1) = IQ(LR2+IFIRST) ELSE IQ(IQ(LNAME+IOFF+ZNADDR)+J) = IQ(LR2+IFIRST) ENDIF ELSE IF (JBIT(IQ(LR2+IFIRST), NB+NBITS) .EQ. 1) THEN IF (USEBUF) THEN IQ(IOFFST+1) = + -JBYT(IQ(LR2+IFIRST), NB+1, NBITS-1) ELSE IQ(IQ(LNAME+IOFF+ZNADDR)+J) = + -JBYT(IQ(LR2+IFIRST), NB+1, NBITS-1) ENDIF ELSE IF (USEBUF) THEN IQ(IOFFST+1) = + JBYT(IQ(LR2+IFIRST), NB+1, NBITS-1) ELSE IQ(IQ(LNAME+IOFF+ZNADDR)+J) = + JBYT(IQ(LR2+IFIRST), NB+1, NBITS-1) ENDIF ENDIF ENDIF ELSEIF (ISIZE .EQ. 8) THEN IF (NBITS .EQ. 64) THEN IF (USEBUF) THEN IQ(IOFFST+1) = IQ(LR2+IFIRST) IQ(IOFFST+2) = IQ(LR2+IFIRST+1) ELSE IQ(IQ(LNAME+IOFF+ZNADDR)+2*J-1)=IQ(LR2+IFIRST) IQ(IQ(LNAME+IOFF+ZNADDR)+2*J)=IQ(LR2+IFIRST+1) ENDIF ELSE ENDIF ENDIF ELSEIF (ITYPE .EQ. 3) THEN IF (ISIZE .EQ. 2) THEN ELSEIF (ISIZE .EQ. 4) THEN IF (NBITS .EQ. 32) THEN IF (USEBUF) THEN IQ(IOFFST+1) = IQ(LR2+IFIRST) ELSE IQ(IQ(LNAME+IOFF+ZNADDR)+J) = IQ(LR2+IFIRST) ENDIF ELSE IF (USEBUF) THEN IQ(IOFFST+1) = + JBYT(IQ(LR2+IFIRST), NB+1, NBITS) ELSE IQ(IQ(LNAME+IOFF+ZNADDR)+J) = + JBYT(IQ(LR2+IFIRST), NB+1, NBITS) ENDIF ENDIF ELSEIF (ISIZE .EQ. 8) THEN IF (NBITS .EQ. 64) THEN IF (USEBUF) THEN IQ(IOFFST+1)=IQ(LR2+IFIRST) IQ(IOFFST+2)=IQ(LR2+IFIRST+1) ELSE IQ(IQ(LNAME+IOFF+ZNADDR)+2*J-1)=IQ(LR2+IFIRST) IQ(IQ(LNAME+IOFF+ZNADDR)+2*J)=IQ(LR2+IFIRST+1) ENDIF ELSE ENDIF ENDIF ELSEIF (ITYPE .EQ. 4) THEN IF (ISIZE .EQ. 1) THEN ELSEIF (ISIZE .EQ. 2) THEN ELSEIF (ISIZE .EQ. 4) THEN ILOGI = JBYT(IQ(LR2+IFIRST), NB+1, NBITS) IF (ILOGI .EQ. 1) THEN LOGIC = .TRUE. ELSE LOGIC = .FALSE. ENDIF IF (USEBUF) THEN IQ(IOFFST+1) = ILOGIC ELSE IQ(IQ(LNAME+IOFF+ZNADDR)+J) = ILOGIC ENDIF ENDIF ELSEIF (ITYPE .EQ. 5) THEN IF (USEBUF) THEN CALL HRZFRA(IQ(LR2+IFIRST),IQ(IOFFST+1),MXBY) ELSE CALL HRZFRA(IQ(LR2+IFIRST), + IQ(IQ(LNAME+IOFF+ZNADDR)+MXBY1*(J-1)+1), + MXBY) ENDIF ENDIF 25 NB = NB + NBITS IF (ISHBIT .NE. 0) THEN IFIRST = IFIRST + ISHFT(NB,-ISHBIT) ELSE IFIRST = IFIRST + NB/IBIPW ENDIF NB = IAND(NB, IBIPW-1) NLEFT = NLEFT - NBITS IF (USEBUF) IOFFST = IOFFST + ISHFT(ISIZE,-2) 30 CONTINUE IQ(LTMP+ITMP) = IBANK IQ(LTMP+ITMP+1) = IFIRST IQ(LTMP+ITMP+2) = NB IQ(LTMP+ITMP+3) = NLEFT 32 IQ(LTMP1+1) = IQ(LTMP1+1) + 1 JTMP = ZNTMP1*(IQ(LTMP1+1)-1) + 2 IQ(LTMP1+JTMP) = INDX IQ(LTMP1+JTMP+1) = IOFF IF (USEBUF) THEN IF (IEDIF .EQ. 0) THEN IQ(LTMP1+JTMP+2) = IOFFST ELSE IQ(LTMP1+JTMP+2) = IOFFST + (IEDIF*ISHFT(ISIZE,-2)) ENDIF ELSE IQ(LTMP1+JTMP+2) = 0 ENDIF LQ(LTMP1-IQ(LTMP1+1)) = LBLOK 35 IOFF = IOFF + ZNADDR 40 CONTINUE IF (IERR1 .NE. 0) THEN IERROR = 1 ENDIF END *------------------------------------------------------------------------------- SUBROUTINE HDCOFL INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) INTEGER I1, I2, I3, I4, I5, I6, I7, I8, + I9, I10, I11, I12, I13, I14, I15, I16, +I17, I18, I19, I20, I21, I22, I23, I24, I25, I26, I27, +I28, I29, I30, I31, I32, I33, I34, I35, I123, I230 COMMON / HCBITS / I1, I2, I3, I4, I5, I6, I7, I8, + I9, I10, I11, I12, I13, I14, I15, I16, +I17, I18, I19, I20, I21, I22, I23, I24, I25, I26, I27, +I28, I29, I30, I31, I32, I33, I34, I35, I123, I230 DIMENSION IFLAG(37) EQUIVALENCE (IFLAG(1),I1) IF(IQ(LCID-2).NE.0)THEN DO 10 J=1,31 10 IFLAG(J)=JBIT(IQ(LCID+KBITS),J) ELSE CALL VZERO(IFLAG,31) ENDIF I230=I2+I3 I123= I1+I230 END *------------------------------------------------------------------------------- SUBROUTINE HDELET(ID1) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) INTEGER ZBITS, ZNDIM, ZNOENT, ZNPRIM, ZNRZB, ZIFCON, + ZIFNAM, ZIFCHA, ZIFINT, ZIFREA, ZNWTIT, ZITIT1, + ZNCHRZ, ZDESC, ZLNAME, ZNAME, ZARIND, ZRANGE, ZNADDR, + ZIBLOK, ZNBLOK, ZLCONT, ZIFBIT, ZIBANK, ZIFTMP, ZITMP, + ZID, ZNTMP, ZNTMP1, ZLINK PARAMETER(ZBITS=1, ZNDIM=2, ZNOENT=3, ZNPRIM=4, ZLCONT=6, + ZNRZB=5, ZIFCON=7, ZIFNAM=4, ZIFCHA=5, ZIFINT=6, + ZIFREA=7, ZNWTIT=8, ZITIT1=9, ZNCHRZ=13, ZIFBIT=8, + ZDESC=1, ZLNAME=2, ZNAME=3, ZRANGE=4, ZNADDR=12, + ZARIND=11, ZIBLOK=8, ZNBLOK=10, ZIBANK=9, ZIFTMP=11, + ZID=12, ZITMP=10, ZNTMP=6, ZNTMP1=3, ZLINK=6) INTEGER ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV COMMON/HCFLAG/ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV IF(LCDIR.LE.0)GO TO 999 IF(ID1.EQ.0)GO TO 120 ID=ID1 IDPOS=LOCATI(IQ(LTAB+1),IQ(LCDIR+KNRH),ID) IF(IDPOS.LE.0)THEN print*, 'Unknown histogram','HDELET',ID1 GO TO 999 ENDIF LCID=LQ(LTAB-IDPOS) IF (JBIT(IQ(LCID+KBITS),4).NE.0 .AND. IQ(LCID-2).EQ.ZLINK) THEN CALL HNBUFD(ID1) ENDIF CALL MZDROP(IHDIV,LCID,' ') LIDS=LQ(LCDIR-2) LQ(LTAB-IDPOS)=0 NRHIST=IQ(LCDIR+KNRH) DO 10 I=IDPOS,NRHIST-1 IQ(LTAB+I)=IQ(LTAB+I+1) LQ(LTAB-I)=LQ(LTAB-I-1) 10 CONTINUE IQ(LCDIR+KNRH)=NRHIST-1 NRHIST=IQ(LCDIR+KNRH) IF(LQ(LCDIR-9).EQ.LCID)THEN LREF=0 LCID=LIDS 20 IF(LCID.NE.0)THEN LREF=LCID LCID=LQ(LCID) GO TO 20 ENDIF LQ(LCDIR-9)=LREF ENDIF GO TO 999 120 IF(LIDS .GT. 0) THEN CALL HNBUFD(0) CALL MZDROP(IHDIV,LIDS ,'L') ENDIF NRHIST=IQ(LCDIR+KNRH) IF(NRHIST.GT.0.AND.LTAB.GT.0)THEN CALL VZERO(LQ(LTAB-NRHIST),NRHIST) ENDIF IQ(LCDIR+KNRH)=0 LQ(LCDIR-2)=0 LQ(LCDIR-9)=0 LIDS=0 LLID=0 NRHIST=0 999 IDLAST=0 IDHOLD=0 LID =0 END *------------------------------------------------------------------------------- SUBROUTINE HBNAM(IDD, BLKNA1, ADDRES, FORM1, ISCHAR) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) COMMON/HCFORM/IODIR,IOH1,IOH2,IOHN,IOCF1,IOCF2,IOCB1,IOCB2, + IOCF4,IOFIT,IONT,IOBL,IOCC INTEGER ZBITS, ZNDIM, ZNOENT, ZNPRIM, ZNRZB, ZIFCON, + ZIFNAM, ZIFCHA, ZIFINT, ZIFREA, ZNWTIT, ZITIT1, + ZNCHRZ, ZDESC, ZLNAME, ZNAME, ZARIND, ZRANGE, ZNADDR, + ZIBLOK, ZNBLOK, ZLCONT, ZIFBIT, ZIBANK, ZIFTMP, ZITMP, + ZID, ZNTMP, ZNTMP1, ZLINK PARAMETER(ZBITS=1, ZNDIM=2, ZNOENT=3, ZNPRIM=4, ZLCONT=6, + ZNRZB=5, ZIFCON=7, ZIFNAM=4, ZIFCHA=5, ZIFINT=6, + ZIFREA=7, ZNWTIT=8, ZITIT1=9, ZNCHRZ=13, ZIFBIT=8, + ZDESC=1, ZLNAME=2, ZNAME=3, ZRANGE=4, ZNADDR=12, + ZARIND=11, ZIBLOK=8, ZNBLOK=10, ZIBANK=9, ZIFTMP=11, + ZID=12, ZITMP=10, ZNTMP=6, ZNTMP1=3, ZLINK=6) INTEGER ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV COMMON/HCFLAG/ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV INTEGER IDD, ADDRES, HNBPTR CHARACTER*(*) BLKNA1, FORM1 PARAMETER (MAXTOK = 50) CHARACTER*8 BLKNAM CHARACTER*40 SFORM CHARACTER*80 TOK(MAXTOK) CHARACTER*1300 FORM LOGICAL ISCHAR IF (IDD .NE. IDLAST) THEN ID = IDD IDPOS = LOCATI(IQ(LTAB+1),IQ(LCDIR+KNRH),ID) IF (IDPOS .LE. 0) THEN print*, 'nTuple does not exist.','HBNAME',IDD RETURN ENDIF IDLAST = ID LCID = LQ(LTAB-IDPOS) I4 = JBIT(IQ(LCID+KBITS),4) IF (I4 .EQ. 0) RETURN IF (IQ(LCID-2) .NE. ZLINK) THEN print*,'HBNAME cannot be used for Row-wise nTuples', + 'HBNAME',IDD RETURN ENDIF ENDIF BLKNAM = BLKNA1 IF (LENOCC(BLKNA1) .GT. LEN(BLKNAM)) THEN PRINT *, '*** Warning: Block name truncated to: ', BLKNAM ENDIF CALL CLTOU(BLKNAM) IF (LENOCC(FORM1) .GT. LEN(FORM)) THEN print*, 'CHFORM string too long','HBNAME',IDD RETURN ENDIF FORM = FORM1 IADD = ADDRES LBLOK = LQ(LCID-1) LCHAR = LQ(LCID-2) LINT = LQ(LCID-3) LREAL = LQ(LCID-4) SFORM = FORM CALL CLTOU(SFORM) IF (SFORM(1:6) .EQ. '$CLEAR') THEN CALL HNMSET(IDD, ZNADDR, 0) CALL SBIT0(IQ(LBLOK),3) RETURN ELSEIF (SFORM(1:4).EQ.'$SET' .OR. SFORM(1:4).EQ.'!SET') THEN IF (SFORM(1:1) .EQ. '!') CALL SBIT1(IQ(LBLOK),3) LBLOK = HNBPTR(BLKNAM) IF (LBLOK .EQ. 0) THEN print*, 'Unknown block '//BLKNAM,'HBNAME',IDD RETURN ENDIF LNAME = LQ(LBLOK-1) LSF = LENOCC(SFORM) I = INDEX(SFORM,':') IF (I.GT.0 .AND. LSF.GT.5) THEN CALL HNMADR(SFORM(I+1:LSF), IADD, ISCHAR) ELSE CALL HNMADR('*', IADD, ISCHAR) ENDIF RETURN ENDIF print*, '>>>>>> Should not be here when called from h2root' END *------------------------------------------------------------------------------- FUNCTION HI(IDD,I) CALL HFIND(IDD,'HI ') HI=HCX(I,1) END *------------------------------------------------------------------------------- FUNCTION HIE(IDD,I) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) CALL HFIND(IDD,'HIE ') IF(JBIT(IQ(LCID+KBITS),9).NE.0)THEN HIE=HCX(I,2) ELSE RES=ABS(HCX(I,1)) HIE=SQRT(RES) ENDIF END *------------------------------------------------------------------------------- FUNCTION HIF(IDD,I) CALL HFIND(IDD,'HIF ') HIF=HCX(I,3) END *------------------------------------------------------------------------------- FUNCTION HIJ(IDD,I,J) CALL HFIND(IDD,'HIJ ') HIJ=HCXY(I,J,1) END *------------------------------------------------------------------------------- SUBROUTINE HIX(IDD,I,X) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) INTEGER I1, I2, I3, I4, I5, I6, I7, I8, + I9, I10, I11, I12, I13, I14, I15, I16, +I17, I18, I19, I20, I21, I22, I23, I24, I25, I26, I27, +I28, I29, I30, I31, I32, I33, I34, I35, I123, I230 COMMON / HCBITS / I1, I2, I3, I4, I5, I6, I7, I8, + I9, I10, I11, I12, I13, I14, I15, I16, +I17, I18, I19, I20, I21, I22, I23, I24, I25, I26, I27, +I28, I29, I30, I31, I32, I33, I34, I35, I123, I230 CALL HFIND(IDD,'HIX ') CALL HDCOFL IF(I6.EQ.0)THEN DX=(Q(LCID+KXMAX)-Q(LCID+KXMIN))/FLOAT(IQ(LCID+KNCX)) X=FLOAT(I-1)*DX+Q(LCID+KXMIN) ELSE LBINS=LQ(LCID-2) X=Q(LBINS+I) ENDIF END *------------------------------------------------------------------------------- SUBROUTINE HIJXY(IDD,I,J,X,Y) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) CALL HFIND(IDD,'HIJXY ') DX=(Q(LCID+KXMAX)-Q(LCID+KXMIN))/FLOAT(IQ(LCID+KNCX)) DY=(Q(LCID+KYMAX)-Q(LCID+KYMIN))/FLOAT(IQ(LCID+KNCY)) X=FLOAT(I-1)*DX+Q(LCID+KXMIN) Y=FLOAT(J-1)*DY+Q(LCID+KYMIN) END *------------------------------------------------------------------------------- FUNCTION HIJE(IDD,I,J) CALL HFIND(IDD,'HIJE ') HIJE=HCXY(I,J,2) END *------------------------------------------------------------------------------- SUBROUTINE HCDIR(CHPATH,CHOPT) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) PARAMETER (NLPATM=100, MXFILES=50, LENHFN=128) COMMON /HCDIRN/NLCDIR,NLNDIR,NLPAT,ICDIR,NCHTOP,ICHTOP(MXFILES) + ,ICHTYP(MXFILES),ICHLUN(MXFILES) CHARACTER*16 CHNDIR, CHCDIR, CHPAT ,CHTOP COMMON /HCDIRC/CHCDIR(NLPATM),CHNDIR(NLPATM),CHPAT(NLPATM) + ,CHTOP(NLPATM) CHARACTER*(LENHFN) HFNAME COMMON /HCFILE/HFNAME(MXFILES) INTEGER ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV COMMON/HCFLAG/ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV INTEGER LOUT,LERR,LINFIT COMMON/HCUNIT/LOUT,LERR,LINFIT CHARACTER*128 CHMAIL COMMON /HCMAIL/CHMAIL COMMON/QUEST/IQUEST(100) CHARACTER*2 NODIR PARAMETER (NODIR = '@#') CHARACTER*128 CHAIN, CACHE DIMENSION IOPTV(2),IHDIR(4) EQUIVALENCE (IOPTR,IOPTV(1)), (IOPTP,IOPTV(2)) CHARACTER*(*) CHPATH,CHOPT SAVE CACHE DATA CACHE /NODIR/ IF(LHBOOK.EQ.0)GO TO 99 CALL HUOPTC (CHOPT,'RP',IOPTV) IF(IOPTR.NE.0)THEN CALL HPAFF(CHCDIR,NLCDIR,CHPATH) GO TO 99 ENDIF IF(IOPTP.NE.0)THEN CALL HPAFF(CHCDIR,NLCDIR,CHMAIL) WRITE(LOUT,1000)CHMAIL(1:90) 1000 FORMAT(' Current Working Directory = ',A) GO TO 99 ENDIF IQUEST(1)=0 IF(CHPATH(1:1).EQ.'.')THEN CALL HPATH(' ') ELSE CALL HPATH(CHPATH) ENDIF IF(NLPAT.LE.0)GO TO 99 ICDOLD=ICDIR ICDIR=1 DO 10 I=1,NCHTOP IF(CHPAT(1).EQ.CHTOP(I))THEN ICDIR=I IF(ICHTOP(I).GT.0)THEN IF (ICHTOP(I).GT.200 .AND. ICHTOP(I).LT.300) THEN print*, '>>>>>> HCDIR: ICHTOP(I).GT.200' ELSE IF(CHPATH(1:1).EQ.'.')THEN CALL HRZCD(' ',CHOPT) ELSE CALL HRZCD(CHPATH,CHOPT) ENDIF ENDIF IF(IQUEST(1).NE.0)THEN ICDIR=ICDOLD GO TO 99 ENDIF GO TO 60 ELSEIF(ICHTOP(I).LT.0)THEN GO TO 60 ENDIF GO TO 20 ENDIF 10 CONTINUE ICDIR=ICDOLD GO TO 90 20 LR1 = LHBOOK IF(NLPAT.GT.1)THEN DO 50 IL=2,NLPAT CALL UCTOH(CHPAT(IL),IHDIR,4,16) LR1=LQ(LR1-1) 30 IF(LR1.EQ.0)GO TO 90 DO 40 I=1,4 IF(IHDIR(I).NE.IQ(LR1+I))THEN LR1=LQ(LR1) GO TO 30 ENDIF 40 CONTINUE 50 CONTINUE ENDIF 60 NLCDIR= NLPAT DO 70 I=1,NLPAT CHCDIR(I)=CHPAT(I) 70 CONTINUE IF(ICHTOP(ICDIR).EQ.0)THEN LCDIR = LR1 LID = 0 ENDIF IDLAST= 0 IDHOLD= 0 LIDS = LQ(LCDIR-2) LTAB = LQ(LCDIR-3) LBUFM = LQ(LCDIR-4) LTMPM = LQ(LCDIR-5) IQUEST(1)=0 GO TO 99 90 CALL HPAFF(CHPAT,NLPAT,CHMAIL) IQUEST(1)=1 WRITE(LOUT,2000)CHMAIL(1:90) 2000 FORMAT(' HCDIR. UNKNOWN DIRECTORY ',A) 99 RETURN END *------------------------------------------------------------------------------- SUBROUTINE HMACHI INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) INTEGER ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV COMMON/HCFLAG/ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV INTEGER I1, I2, I3, I4, I5, I6, I7, I8, + I9, I10, I11, I12, I13, I14, I15, I16, +I17, I18, I19, I20, I21, I22, I23, I24, I25, I26, I27, +I28, I29, I30, I31, I32, I33, I34, I35, I123, I230 COMMON / HCBITS / I1, I2, I3, I4, I5, I6, I7, I8, + I9, I10, I11, I12, I13, I14, I15, I16, +I17, I18, I19, I20, I21, I22, I23, I24, I25, I26, I27, +I28, I29, I30, I31, I32, I33, I34, I35, I123, I230 INTEGER LOUT,LERR,LINFIT COMMON/HCUNIT/LOUT,LERR,LINFIT INTEGER IFW ,NW ,NB ,IH ,NHT ,ICN ,IPONCE, + NH ,MSTEP ,NOENT ,NOLD ,IDOLAR,IBLANC,KBINSZ,INO , + KSQUEZ,NCOLMA,NCOLPA,NLINPA, ICBLAC,ICSTAR,ICFUNC, + IDG(42),MAXBIT(30),IDENT(9) REAL BIGP COMMON/HCPRIN/IFW ,NW ,NB ,IH ,NHT ,ICN ,IPONCE, + NH ,MSTEP ,NOENT ,NOLD ,IDOLAR,IBLANC,KBINSZ,INO , + KSQUEZ,NCOLMA,NCOLPA,NLINPA,BIGP ,ICBLAC,ICSTAR,ICFUNC, + IDG ,MAXBIT,IDENT COMMON /HCNT/ IBIPW, IBIPB, IBYPW, ISHBIT COMMON /HCSET/ IBSIZE LOGICAL NRECOV COMMON /HCRECV/ NRECOV PARAMETER (MBIT=32,MBITCH=8,MOUT=6,HMBIGP=1.E+30) CHARACTER*1 IDGTDA(42) CHARACTER*4 IPROJ(9) SAVE IDGTDA,IPROJ DATA IDGTDA/'0','1','2','3','4','5','6','7','8','9', + 'A','B','C','D','E','F','G','H','I','J', + 'K','L','M','N','O','P','Q','R','S','T', + 'U','V','W','X','Y','Z','*','.','-','+', + ' ','/'/ DATA IPROJ/'HIST','HIST','PROX','PROY','SLIX', + 'SLIY','BANX','BANY','FUNC'/ HVERSN = 1.00 NBIT = MBIT NBITCH = MBITCH LINFIT = 5 LOUT = MOUT BIGP = HMBIGP LERR = LOUT NHT = 1 MSTEP = 1 NOLD = 4 NCHAR = NBIT/NBITCH NCOLPA = 128 NCOLMA = 100 NLINPA = 61 IDHOLD = 0 IDLAST = 0 NV = 2 KBINSZ = 0 KSQUEZ = 0 LID = 0 NRHIST = 0 IERR = 0 IH = 0 NH = 0 IPONCE = 0 CALL VZERO(I1,37) K = (NBIT+1)/2 MAXBIT(1) = 2 DO 10 I=2,K MAXBIT(I) = MAXBIT(I-1)*2 MAXBIT(I-1) = MAXBIT(I-1)-1 10 CONTINUE MAXBIT(K) = MAXBIT(K)-1 CALL VBLANK(IDG,42) CALL UCTOH(IDGTDA,IDG,1,42) ICSTAR = IDG(37) ICBLAC = IDG(34) ICFUNC = IDG(37) CALL UCTOH(IPROJ,IDENT,4,36) CALL UCTOH('NO ',INO,4,4) L2 = 1 CALL UCTOH('$ ',IDOL,4,4) IDOLAR = JBYT(IDOL,L2,NBITCH) IBLANC = JBYT(IDG(41),L2,NBITCH) NRECOV = .FALSE. IBSIZE = 1009 IBIPW = MBIT IBIPB = MBITCH IBYPW = NCHAR ISHBIT = 0 DO 20 I = 1, 10 IF (2**I .EQ. IBIPW) THEN ISHBIT = I ENDIF 20 CONTINUE END *------------------------------------------------------------------------------- FUNCTION HCX(ICX,IOPT) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) INTEGER IFW ,NW ,NB ,IH ,NHT ,ICN ,IPONCE, + NH ,MSTEP ,NOENT ,NOLD ,IDOLAR,IBLANC,KBINSZ,INO , + KSQUEZ,NCOLMA,NCOLPA,NLINPA, ICBLAC,ICSTAR,ICFUNC, + IDG(42),MAXBIT(30),IDENT(9) REAL BIGP COMMON/HCPRIN/IFW ,NW ,NB ,IH ,NHT ,ICN ,IPONCE, + NH ,MSTEP ,NOENT ,NOLD ,IDOLAR,IBLANC,KBINSZ,INO , + KSQUEZ,NCOLMA,NCOLPA,NLINPA,BIGP ,ICBLAC,ICSTAR,ICFUNC, + IDG ,MAXBIT,IDENT DOUBLE PRECISION CONT,ERR2,SUM,EPRIM HCX = 0.0 LW = LQ(LCONT) IF(IOPT.EQ.1.OR.(IOPT.EQ.2.AND.LW.EQ.0)) THEN IF(NB.GE.32)THEN HCX = Q(LCONT+KCON1+ICX) IF(LW.NE.0)THEN IF(LQ(LW).NE.0)THEN LN=LQ(LW) IF(ICX.LE.0.OR.ICX.GT.IQ(LN-1)) THEN HCX = 0.0 GOTO 1 ENDIF SUM=Q(LN+ICX) IF(SUM.NE.0.) HCX = HCX/SUM ENDIF ENDIF ELSE L1=ICX*NB NBITH=32-MOD(32,NB) L2=MOD(L1,NBITH)+1 L1=LCONT+KCON1+L1/NBITH HCX = JBYT(IQ(L1),L2,NB) ENDIF 1 IF(IOPT.EQ.1) RETURN ENDIF IF(IOPT.EQ.2) THEN IF(LW.EQ.0) THEN HCX = SQRT(ABS(HCX)) RETURN ENDIF IF(LQ(LW).EQ.0)THEN HCX=SQRT(Q(LW+ICX)) RETURN ELSE IOPTS=JBYT(IQ(LW),1,2) LN=LQ(LW) CONT=Q(LCONT+KCON1+ICX) ERR2=Q(LW+ICX) SUMP=ABS(Q(LN+ICX)) IF(SUMP.NE.0.)THEN IF(JBIT(IQ(LW),3).EQ.0)THEN EPRIM=SQRT(ABS(ERR2/SUMP - (CONT/SUMP)**2)) ELSE EPRIM=SQRT(ABS(ERR2/SUMP)) ENDIF IF(EPRIM.LE.0..AND.SUMP.GE.1.)THEN IF(IOPTS.EQ.2)THEN EPRIM=1./SQRT(12.) ELSE EPRIM=SQRT(ABS(CONT)) ENDIF ENDIF IF(IOPTS.EQ.0)THEN HCX=EPRIM/SQRT(SUMP) ELSEIF(IOPTS.EQ.1)THEN HCX=EPRIM ELSE HCX=EPRIM/SQRT(SUMP) ENDIF ENDIF RETURN ENDIF ELSE IF(IOPT.EQ.3) THEN LFUNC=LQ(LCONT-1) IC1=IQ(LFUNC+1) IF(ICX.GE.IC1.AND.ICX.LE.IQ(LFUNC+2))THEN HCX=Q(LFUNC+ICX-IC1+3) ENDIF ELSE print*, '+Error in option value','HCX',IOPT ENDIF END *------------------------------------------------------------------------------- FUNCTION HCXY(ICX,ICY,IOPT) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) INTEGER IFW ,NW ,NB ,IH ,NHT ,ICN ,IPONCE, + NH ,MSTEP ,NOENT ,NOLD ,IDOLAR,IBLANC,KBINSZ,INO , + KSQUEZ,NCOLMA,NCOLPA,NLINPA, ICBLAC,ICSTAR,ICFUNC, + IDG(42),MAXBIT(30),IDENT(9) REAL BIGP COMMON/HCPRIN/IFW ,NW ,NB ,IH ,NHT ,ICN ,IPONCE, + NH ,MSTEP ,NOENT ,NOLD ,IDOLAR,IBLANC,KBINSZ,INO , + KSQUEZ,NCOLMA,NCOLPA,NLINPA,BIGP ,ICBLAC,ICSTAR,ICFUNC, + IDG ,MAXBIT,IDENT NW=32/NB J=(IQ(LCID+KNCY)-ICY+1)*(IQ(LCID+KNCX)+2) L2=ICX+J L1=L2/NW+LSCAT+KCON2 IF(NW.NE.1)THEN L2=(NW-1-MOD(L2,NW))*NB +1 HCXY=JBYT(IQ(L1),L2,NB) ELSE HCXY=Q(L1) ENDIF IF(IOPT.EQ.2) THEN LW = LQ(LCONT) IF(LW.NE.0) THEN NCX = IQ(LCID+KNCX) IOFF = (ICY-1)*NCX + ICX HCXY = SQRT(Q(LW+IOFF)) ELSE HCXY = SQRT(ABS(HCXY)) ENDIF ENDIF END *------------------------------------------------------------------------------- SUBROUTINE HFIND(IDD,CHROUT) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) INTEGER ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV COMMON/HCFLAG/ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV INTEGER IFW ,NW ,NB ,IH ,NHT ,ICN ,IPONCE, + NH ,MSTEP ,NOENT ,NOLD ,IDOLAR,IBLANC,KBINSZ,INO , + KSQUEZ,NCOLMA,NCOLPA,NLINPA, ICBLAC,ICSTAR,ICFUNC, + IDG(42),MAXBIT(30),IDENT(9) REAL BIGP COMMON/HCPRIN/IFW ,NW ,NB ,IH ,NHT ,ICN ,IPONCE, + NH ,MSTEP ,NOENT ,NOLD ,IDOLAR,IBLANC,KBINSZ,INO , + KSQUEZ,NCOLMA,NCOLPA,NLINPA,BIGP ,ICBLAC,ICSTAR,ICFUNC, + IDG ,MAXBIT,IDENT COMMON /QUEST/ IQUEST(100) CHARACTER*(*) CHROUT IF(LFIX.NE.0)GO TO 99 IQUEST(1)=0 ID=IDD IDLAST=0 IDPOS=LOCATI(IQ(LTAB+1),IQ(LCDIR+KNRH),ID) IF(IDPOS.LE.0)THEN LCID=0 print*, 'Unknown histogram',CHROUT,IDD IQUEST(1)=1 GO TO 99 ENDIF LCID=LQ(LTAB-IDPOS) LCONT=LQ(LCID-1) LSCAT=LCONT NB=IQ(LCONT+KNBIT) LPRX=LCID+KNCX IF(JBYT(IQ(LCID+KBITS),2,2).NE.0)THEN LPRY=LCID+KNCY ELSE LPRY=0 ENDIF 99 RETURN END *------------------------------------------------------------------------------- SUBROUTINE HUOPTC(CCHOPT,CSTR,IOPT) CHARACTER*(*) CCHOPT,CSTR CHARACTER*12 CHOPT DIMENSION IOPT(1) CHOPT = CCHOPT CALL CLTOU(CHOPT) CALL UOPTC(CHOPT,CSTR,IOPT) RETURN END *------------------------------------------------------------------------------- SUBROUTINE HRZCD(CHDIR,CHOPT) PARAMETER (NLPATM=100, MXFILES=50, LENHFN=128) COMMON /HCDIRN/NLCDIR,NLNDIR,NLPAT,ICDIR,NCHTOP,ICHTOP(MXFILES) + ,ICHTYP(MXFILES),ICHLUN(MXFILES) CHARACTER*16 CHNDIR, CHCDIR, CHPAT ,CHTOP COMMON /HCDIRC/CHCDIR(NLPATM),CHNDIR(NLPATM),CHPAT(NLPATM) + ,CHTOP(NLPATM) CHARACTER*(LENHFN) HFNAME COMMON /HCFILE/HFNAME(MXFILES) CHARACTER*(*)CHDIR,CHOPT IF(ICHTOP(ICDIR).GT.1000)THEN print*, 'CZ option not active','HRZCD',0 RETURN ENDIF CALL RZCDIR(CHDIR,CHOPT) END *------------------------------------------------------------------------------- SUBROUTINE HNMADR(VAR1, IADD, ISCHAR) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) COMMON /HCNT/ IBIPW, IBIPB, IBYPW, ISHBIT INTEGER ZBITS, ZNDIM, ZNOENT, ZNPRIM, ZNRZB, ZIFCON, + ZIFNAM, ZIFCHA, ZIFINT, ZIFREA, ZNWTIT, ZITIT1, + ZNCHRZ, ZDESC, ZLNAME, ZNAME, ZARIND, ZRANGE, ZNADDR, + ZIBLOK, ZNBLOK, ZLCONT, ZIFBIT, ZIBANK, ZIFTMP, ZITMP, + ZID, ZNTMP, ZNTMP1, ZLINK PARAMETER(ZBITS=1, ZNDIM=2, ZNOENT=3, ZNPRIM=4, ZLCONT=6, + ZNRZB=5, ZIFCON=7, ZIFNAM=4, ZIFCHA=5, ZIFINT=6, + ZIFREA=7, ZNWTIT=8, ZITIT1=9, ZNCHRZ=13, ZIFBIT=8, + ZDESC=1, ZLNAME=2, ZNAME=3, ZRANGE=4, ZNADDR=12, + ZARIND=11, ZIBLOK=8, ZNBLOK=10, ZIBANK=9, ZIFTMP=11, + ZID=12, ZITMP=10, ZNTMP=6, ZNTMP1=3, ZLINK=6) CHARACTER*(*) VAR1 CHARACTER*32 NAME, VAR INTEGER IADD LOGICAL ISCHAR, ALL, LDUM VAR = VAR1 CALL CLTOU(VAR) LVAR = LENOCC(VAR) ALL = .FALSE. IF (VAR(1:1).EQ.'*' .AND. LVAR.EQ.1) ALL = .TRUE. IOFF = 0 NDIM = IQ(LBLOK+ZNDIM) DO 30 I = 1, NDIM CALL HNDESC(IOFF, NSUB, ITYPE, ISIZE, NBITS, LDUM) LL = IQ(LNAME+IOFF+ZLNAME) LV = IQ(LNAME+IOFF+ZNAME) NAME = ' ' CALL UHTOC(IQ(LCHAR+LV), 4, NAME, LL) CALL CLTOU(NAME) IF (.NOT.ALL .AND. VAR(1:LVAR).NE.NAME(1:LL)) GOTO 20 IF (ISCHAR .AND. ITYPE.NE.5) GOTO 20 IF (.NOT.ISCHAR .AND. ITYPE.EQ.5) GOTO 20 IELEM = 1 DO 10 J = 1, NSUB LP = IQ(LINT+IQ(LNAME+IOFF+ZARIND)+(J-1)) IF (LP .LT. 0) THEN IE = -LP ELSE LL = IQ(LNAME+LP-1+ZRANGE) IE = IQ(LINT+LL+1) ENDIF IELEM = IELEM*IE 10 CONTINUE IADDW = ISHFT(IADD, -2) IBYOF = IAND(IADD, IBYPW-1) IF (IBYOF .NE. 0) GOTO 40 IQ(LNAME+IOFF+ZNADDR) = IADDW - LOCF(IQ(1)) IADD = IADD + IELEM*ISIZE 20 IOFF = IOFF + ZNADDR 30 CONTINUE RETURN 40 PRINT *, 'Variable ', NAME(1:LENOCC(NAME)) print*, 'Address not word aligned','HBNAME' RETURN END *------------------------------------------------------------------------------- SUBROUTINE HITOC(IVAL, VALC, NCSTR, IERR) CHARACTER*(*) VALC INTEGER IVAL, IERR CHARACTER*32 TT INTEGER I, J, NCSTR, NCH, LENOCC IERR = 0 WRITE(TT,'(I32)',ERR=20) IVAL J = 0 DO 10 I = 1, LENOCC(TT) IF (TT(I:I) .EQ. ' ') GOTO 10 J = J + 1 TT(J:J) = TT(I:I) 10 CONTINUE NCSTR = J TT = TT(1:NCSTR) NCH = LEN(VALC) IF (NCH .LT. NCSTR) IERR = -1 VALC(1:NCH) = TT GOTO 999 20 IERR = 1 999 END *------------------------------------------------------------------------------- SUBROUTINE HPATH(CHPATH) PARAMETER (NLPATM=100, MXFILES=50, LENHFN=128) COMMON /HCDIRN/NLCDIR,NLNDIR,NLPAT,ICDIR,NCHTOP,ICHTOP(MXFILES) + ,ICHTYP(MXFILES),ICHLUN(MXFILES) CHARACTER*16 CHNDIR, CHCDIR, CHPAT ,CHTOP COMMON /HCDIRC/CHCDIR(NLPATM),CHNDIR(NLPATM),CHPAT(NLPATM) + ,CHTOP(NLPATM) CHARACTER*(LENHFN) HFNAME COMMON /HCFILE/HFNAME(MXFILES) INTEGER LOUT,LERR,LINFIT COMMON/HCUNIT/LOUT,LERR,LINFIT CHARACTER*(*) CHPATH CHARACTER*1 CH1,BSLASH CHARACTER*2 CH2 BSLASH='\\' NCHP=LEN(CHPATH) NLPAT=0 10 IF(CHPATH(NCHP:NCHP).EQ.' ')THEN NCHP=NCHP-1 IF(NCHP.GT.0)GO TO 10 NLPAT=NLCDIR DO 20 I=1,NLCDIR CHPAT(I)=CHCDIR(I) 20 CONTINUE GO TO 99 ENDIF IS1=1 30 IF(CHPATH(IS1:IS1).EQ.' ')THEN IS1=IS1+1 GO TO 30 ENDIF CH1=CHPATH(IS1:IS1) IF(IS1.LT.NCHP)CH2=CHPATH(IS1:IS1+1) IF(CH1.EQ.'/')THEN IF(IS1.GE.NCHP)GO TO 90 IF(CHPATH(IS1+1:IS1+1).EQ.'/')THEN IS=IS1+2 IF(IS.GT.NCHP)GO TO 99 40 IF(CHPATH(IS:IS).EQ.'/')THEN IF(IS.EQ.IS1+2)GO TO 90 NLPAT=1 CHPAT(1)=CHPATH(IS1+2:IS-1) IS1=IS+1 IS=IS1 GO TO 50 ELSE IS=IS+1 IF(IS.LT.NCHP)GO TO 40 NLPAT=1 CHPAT(1)=CHPATH(IS1+2:IS) GO TO 99 ENDIF ENDIF IF(CHPATH(IS1+1:IS1+1).EQ.BSLASH)GO TO 90 NLPAT=1 CHPAT(1)=CHCDIR(1) IS=IS1+1 IS1=IS 50 IF(IS.EQ.NCHP)THEN IF(CHPATH(IS1:IS).NE.'..'.AND. + CHPATH(IS1:IS).NE.BSLASH) THEN NLPAT=NLPAT+1 IF(NLPAT.GT.NLPATM)GO TO 90 CHPAT(NLPAT)=CHPATH(IS1:IS) ELSE NLPAT = NLPAT -1 ENDIF GO TO 99 ELSE IF(CHPATH(IS:IS).EQ.'/')THEN IF(NLPAT.GT.NLPATM)GO TO 90 IF(CHPATH(IS1:IS-1).NE.'..'.AND. + CHPATH(IS1:IS-1).NE.BSLASH) THEN NLPAT=NLPAT+1 CHPAT(NLPAT)=CHPATH(IS1:IS-1) ELSE NLPAT = NLPAT - 1 ENDIF IS1=IS+1 ENDIF IS=IS+1 GO TO 50 ENDIF ENDIF DO 70 I=1,NLCDIR CHPAT(I)=CHCDIR(I) 70 CONTINUE NLPAT=NLCDIR 75 IF(CH1.EQ.BSLASH)THEN NLPAT=NLPAT-1 IF(NLPAT.EQ.0)NLPAT=1 IF(IS1.EQ.NCHP)GO TO 99 IS1=IS1+1 CH1=CHPATH(IS1:IS1) GO TO 75 ENDIF IS=IS1 76 IF(CH2.EQ.'..')THEN NLPAT=NLPAT-1 IF(NLPAT.EQ.0)NLPAT=1 IF(IS1+1.EQ.NCHP)GO TO 99 IF(CHPATH(IS1+2:IS1+2).NE.'/') GOTO 90 IS =IS1 IS1=IS1+3 CH2=CHPATH(IS1:IS1+1) GO TO 76 ENDIF 80 IF(IS.EQ.NCHP)THEN NLPAT=NLPAT+1 IF(NLPAT.GT.NLPATM)GO TO 90 CHPAT(NLPAT)=CHPATH(IS1:IS) GO TO 99 ELSE IF(CHPATH(IS:IS).EQ.'/')THEN IF(IS.GT.IS1)THEN NLPAT=NLPAT+1 IF(NLPAT.GT.NLPATM)GO TO 90 CHPAT(NLPAT)=CHPATH(IS1:IS-1) ENDIF IS1=IS+1 ENDIF IS=IS+1 GO TO 80 ENDIF 90 IS1=LEN(CHPATH) IF(IS1.GT.90)IS1=90 WRITE(LOUT,1000)CHPATH(1:IS1) 1000 FORMAT(' HPATH. ERROR IN PATHNAME,',A) NLPAT=0 99 RETURN END *------------------------------------------------------------------------------- SUBROUTINE HNDESC(IOFF, NSUB, ITYPE, ISIZE, NBITS, INDVAR) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) INTEGER ZBITS, ZNDIM, ZNOENT, ZNPRIM, ZNRZB, ZIFCON, + ZIFNAM, ZIFCHA, ZIFINT, ZIFREA, ZNWTIT, ZITIT1, + ZNCHRZ, ZDESC, ZLNAME, ZNAME, ZARIND, ZRANGE, ZNADDR, + ZIBLOK, ZNBLOK, ZLCONT, ZIFBIT, ZIBANK, ZIFTMP, ZITMP, + ZID, ZNTMP, ZNTMP1, ZLINK PARAMETER(ZBITS=1, ZNDIM=2, ZNOENT=3, ZNPRIM=4, ZLCONT=6, + ZNRZB=5, ZIFCON=7, ZIFNAM=4, ZIFCHA=5, ZIFINT=6, + ZIFREA=7, ZNWTIT=8, ZITIT1=9, ZNCHRZ=13, ZIFBIT=8, + ZDESC=1, ZLNAME=2, ZNAME=3, ZRANGE=4, ZNADDR=12, + ZARIND=11, ZIBLOK=8, ZNBLOK=10, ZIBANK=9, ZIFTMP=11, + ZID=12, ZITMP=10, ZNTMP=6, ZNTMP1=3, ZLINK=6) COMMON /HCNT/ IBIPW, IBIPB, IBYPW, ISHBIT LOGICAL INDVAR NSUB = JBYT(IQ(LNAME+IOFF+ZDESC), 18, 3) ITYPE = JBYT(IQ(LNAME+IOFF+ZDESC), 14, 4) ISIZE = JBYT(IQ(LNAME+IOFF+ZDESC), 8, 6) NBITS = JBYT(IQ(LNAME+IOFF+ZDESC), 1, 7) INDVAR = .FALSE. IF (JBIT(IQ(LNAME+IOFF+ZDESC),28) .EQ. 1) INDVAR = .TRUE. IF (ITYPE .EQ. 5) NBITS = IBIPB*ISIZE END *------------------------------------------------------------------------------- SUBROUTINE HPARNT(IDN, CHROUT) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) INTEGER ZBITS, ZNDIM, ZNOENT, ZNPRIM, ZNRZB, ZIFCON, + ZIFNAM, ZIFCHA, ZIFINT, ZIFREA, ZNWTIT, ZITIT1, + ZNCHRZ, ZDESC, ZLNAME, ZNAME, ZARIND, ZRANGE, ZNADDR, + ZIBLOK, ZNBLOK, ZLCONT, ZIFBIT, ZIBANK, ZIFTMP, ZITMP, + ZID, ZNTMP, ZNTMP1, ZLINK PARAMETER(ZBITS=1, ZNDIM=2, ZNOENT=3, ZNPRIM=4, ZLCONT=6, + ZNRZB=5, ZIFCON=7, ZIFNAM=4, ZIFCHA=5, ZIFINT=6, + ZIFREA=7, ZNWTIT=8, ZITIT1=9, ZNCHRZ=13, ZIFBIT=8, + ZDESC=1, ZLNAME=2, ZNAME=3, ZRANGE=4, ZNADDR=12, + ZARIND=11, ZIBLOK=8, ZNBLOK=10, ZIBANK=9, ZIFTMP=11, + ZID=12, ZITMP=10, ZNTMP=6, ZNTMP1=3, ZLINK=6) CHARACTER*(*) CHROUT LCID = 0 NIDN = LOCATI(IQ(LTAB+1),IQ(LCDIR+KNRH),IDN) IF (NIDN .LE. 0) THEN CALL HRIN(IDN,9999,0) NIDN = LOCATI(IQ(LTAB+1),IQ(LCDIR+KNRH),IDN) IF (NIDN .LE. 0) THEN print*,'Unknown N-tuple',CHROUT,IDN IDN = 0 RETURN ENDIF ENDIF LCID = LQ(LTAB-NIDN) I4 = JBIT(IQ(LCID+KBITS),4) IF (I4 .EQ. 0) THEN print*,'Not a N-tuple',CHROUT,IDN IDN = 0 RETURN ENDIF IF (IQ(LCID-2) .NE. ZLINK) THEN print*,'Old N-tuple, this routine works only for new '// + 'N-tuples',CHROUT,IDN IDN = 0 RETURN ENDIF IF (IQ(LCID+ZNPRIM) .GT. 0) THEN CALL HNBFWR(IDN) CALL HNHDWR(IDN) ENDIF END *------------------------------------------------------------------------------- SUBROUTINE HNTMP(IDD) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) INTEGER ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV COMMON/HCFLAG/ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV INTEGER ZBITS, ZNDIM, ZNOENT, ZNPRIM, ZNRZB, ZIFCON, + ZIFNAM, ZIFCHA, ZIFINT, ZIFREA, ZNWTIT, ZITIT1, + ZNCHRZ, ZDESC, ZLNAME, ZNAME, ZARIND, ZRANGE, ZNADDR, + ZIBLOK, ZNBLOK, ZLCONT, ZIFBIT, ZIBANK, ZIFTMP, ZITMP, + ZID, ZNTMP, ZNTMP1, ZLINK PARAMETER(ZBITS=1, ZNDIM=2, ZNOENT=3, ZNPRIM=4, ZLCONT=6, + ZNRZB=5, ZIFCON=7, ZIFNAM=4, ZIFCHA=5, ZIFINT=6, + ZIFREA=7, ZNWTIT=8, ZITIT1=9, ZNCHRZ=13, ZIFBIT=8, + ZDESC=1, ZLNAME=2, ZNAME=3, ZRANGE=4, ZNADDR=12, + ZARIND=11, ZIBLOK=8, ZNBLOK=10, ZIBANK=9, ZIFTMP=11, + ZID=12, ZITMP=10, ZNTMP=6, ZNTMP1=3, ZLINK=6) NDIM = IQ(LCID+ZNDIM) NW = 1 + ZNTMP*NDIM IF (LQ(LCDIR-5) .EQ. 0) THEN NW1 = 1 + ZNTMP1*NDIM NTOT = NW + NW1 + NDIM + 2*33 CALL HSPACE(NTOT,'HNTMP',IDD) IF (IERR.NE.0) GOTO 70 IDLAST = IDD CALL MZBOOK(IHDIV,LTMPM,LCDIR,-5,'HTMP',2,1,NW,2,1) LTMP = LTMPM IQ(LTMP-5) = IDD CALL MZBOOK(IHDIV,LTMP1,LTMP,-1,'HTMP1',NDIM,0,NW1,2,-1) ELSEIF (IQ(LTMP-5) .NE. IDD) THEN LTMP = LQ(LCDIR-5) 20 IF (IQ(LTMP-5) .EQ. IDD) GOTO 40 IF (LQ(LTMP) .NE. 0) THEN LTMP = LQ(LTMP) GOTO 20 ENDIF NW1 = 1 + ZNTMP1*NDIM NTOT = NW + NW1 + NDIM + 2*33 CALL HSPACE(NTOT,'HNTMP',IDD) IF (IERR.NE.0) GOTO 70 IDLAST = IDD CALL MZBOOK(IHDIV,LTMP,LTMP,0,'HTMP',2,1,NW,2,1) IQ(LTMP-5) = IDD CALL MZBOOK(IHDIV,LTMP1,LTMP,-1,'HTMP1',NDIM,0,NW1,2,-1) ENDIF 40 LTMP1 = LQ(LTMP-1) LQ(LTMP-2) = LCID NWP = IQ(LTMP-1) IF (NWP .NE. NW) THEN ND = NW - NWP CALL MZPUSH(IHDIV, LTMP, 0, ND, 'I') NWP = IQ(LTMP1-1) ND = 1+ZNTMP1*NDIM - NWP NLP = IQ(LTMP1-3) NL = NDIM - NLP CALL MZPUSH(IHDIV, LTMP1, NL, ND, 'I') ENDIF 70 RETURN END *------------------------------------------------------------------------------- SUBROUTINE HNBUFR(IDD) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) INTEGER ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV COMMON/HCFLAG/ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV INTEGER ZBITS, ZNDIM, ZNOENT, ZNPRIM, ZNRZB, ZIFCON, + ZIFNAM, ZIFCHA, ZIFINT, ZIFREA, ZNWTIT, ZITIT1, + ZNCHRZ, ZDESC, ZLNAME, ZNAME, ZARIND, ZRANGE, ZNADDR, + ZIBLOK, ZNBLOK, ZLCONT, ZIFBIT, ZIBANK, ZIFTMP, ZITMP, + ZID, ZNTMP, ZNTMP1, ZLINK PARAMETER(ZBITS=1, ZNDIM=2, ZNOENT=3, ZNPRIM=4, ZLCONT=6, + ZNRZB=5, ZIFCON=7, ZIFNAM=4, ZIFCHA=5, ZIFINT=6, + ZIFREA=7, ZNWTIT=8, ZITIT1=9, ZNCHRZ=13, ZIFBIT=8, + ZDESC=1, ZLNAME=2, ZNAME=3, ZRANGE=4, ZNADDR=12, + ZARIND=11, ZIBLOK=8, ZNBLOK=10, ZIBANK=9, ZIFTMP=11, + ZID=12, ZITMP=10, ZNTMP=6, ZNTMP1=3, ZLINK=6) COMMON/QUEST/IQUEST(100) CHARACTER*128 CHWOLD, CHDIR, CWDRZ INTEGER KEYS(2) LOGICAL MEMORY IERR = 0 ICYCLE = 9999 NDIM = IQ(LCID+ZNDIM) NWP = IABS(IQ(LCID+ZNPRIM)) IF (LQ(LCDIR-4) .EQ. 0) THEN NTOT = NDIM+2+33 CALL HSPACE(NTOT,'HNBUFR',IDD) IF (IERR.NE.0) GOTO 50 CALL MZBOOK(IHDIV,LBUFM,LCDIR,-4,'HBUF',NDIM,NDIM,2,2,0) LBUF = LBUFM IQ(LBUF-5) = IDD ELSEIF (IQ(LBUF-5) .NE. IDD) THEN LBUF = LQ(LCDIR-4) 10 IF (IQ(LBUF-5) .EQ. IDD) GOTO 20 IF (LQ(LBUF) .NE. 0) THEN LBUF = LQ(LBUF) GOTO 10 ENDIF NTOT = NDIM+2+33 CALL HSPACE(NTOT,'HNBUFR',IDD) IF (IERR.NE.0) GOTO 50 CALL MZBOOK(IHDIV,LBUF,LBUF,0,'HBUF',NDIM,NDIM,2,2,0) IQ(LBUF-5) = IDD ENDIF 20 MEMORY = IQ(LCID+ZNPRIM) .LE. 0 IF (MEMORY) THEN NCHRZ = IQ(LCID+ZNCHRZ) CALL RZCDIR(CWDRZ,'R') CALL HCDIR(CHWOLD,'R') CHDIR = ' ' CALL UHTOC(IQ(LCID+ZNCHRZ+1),4,CHDIR,NCHRZ) IF (CHDIR.NE.CWDRZ) THEN CALL HCDIR(CHDIR,' ') ENDIF KEYS(1) = IQ(LCID+ZID) ENDIF LBLOK = LQ(LCID-1) LCHAR = LQ(LCID-2) LINT = LQ(LCID-3) LREAL = LQ(LCID-4) 30 LNAME = LQ(LBLOK-1) IOFF = 0 NDIM = IQ(LBLOK+ZNDIM) DO 40 I = 1, NDIM LCIND = IQ(LNAME+IOFF+ZLCONT) IADD = IQ(LNAME+IOFF+ZNADDR) LB = LQ(LBUF-LCIND) IF (IADD .EQ. 0) THEN IF (LB .NE. 0) THEN IF (JBIT(IQ(LB),1) .EQ. 0) THEN CALL MZDROP(IHDIV,LB,' ') LQ(LBUF-LCIND) = 0 ENDIF ENDIF ELSEIF (MEMORY .AND. LB.EQ.0) THEN KEYS(2) = IQ(LNAME+IOFF+ZNRZB)*10000 + + IQ(LNAME+IOFF+ZLCONT) CALL HRZIN(IHDIV,0,0,KEYS,ICYCLE,'C') IF (IQUEST(1) .NE. 0) THEN print*,'Error reading contents bank', 'HNBUFR', IDD IERR = 1 GOTO 50 ENDIF NWORDS = IQUEST(12) CALL HSPACE(NWORDS+1000,'HNBUFR',IDD) IF (IERR .NE. 0) GOTO 50 CALL HRZIN(IHDIV,LBUF,-LCIND,KEYS,ICYCLE,' ') ELSEIF (LB .EQ. 0) THEN NTOT = NWP+33 CALL HSPACE(NTOT,'HNBUFR',IDD) IF (IERR.NE.0) GOTO 50 CALL MZBOOK(IHDIV,L,LBUF,-LCIND,'HCON',0,0,NWP,1,-1) ENDIF IOFF = IOFF + ZNADDR 40 CONTINUE LBLOK = LQ(LBLOK) IF (LBLOK .NE. 0) GOTO 30 IF (MEMORY) THEN IF (CHDIR.NE.CWDRZ) THEN CALL HCDIR(CHWOLD,' ') IF (CHWOLD .NE. CWDRZ) THEN CALL RZCDIR(CWDRZ,' ') ENDIF ENDIF ENDIF CALL HNTMP(IDD) 50 RETURN END *------------------------------------------------------------------------------- SUBROUTINE HNTRD(INDX, IOFF, IBANK, IERROR) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) INTEGER ZBITS, ZNDIM, ZNOENT, ZNPRIM, ZNRZB, ZIFCON, + ZIFNAM, ZIFCHA, ZIFINT, ZIFREA, ZNWTIT, ZITIT1, + ZNCHRZ, ZDESC, ZLNAME, ZNAME, ZARIND, ZRANGE, ZNADDR, + ZIBLOK, ZNBLOK, ZLCONT, ZIFBIT, ZIBANK, ZIFTMP, ZITMP, + ZID, ZNTMP, ZNTMP1, ZLINK PARAMETER(ZBITS=1, ZNDIM=2, ZNOENT=3, ZNPRIM=4, ZLCONT=6, + ZNRZB=5, ZIFCON=7, ZIFNAM=4, ZIFCHA=5, ZIFINT=6, + ZIFREA=7, ZNWTIT=8, ZITIT1=9, ZNCHRZ=13, ZIFBIT=8, + ZDESC=1, ZLNAME=2, ZNAME=3, ZRANGE=4, ZNADDR=12, + ZARIND=11, ZIBLOK=8, ZNBLOK=10, ZIBANK=9, ZIFTMP=11, + ZID=12, ZITMP=10, ZNTMP=6, ZNTMP1=3, ZLINK=6) LOGICAL NRECOV COMMON /HCRECV/ NRECOV COMMON/QUEST/IQUEST(100) CHARACTER*128 CHWOLD, CHDIR, CWDRZ INTEGER KEYS(2) IF (IQ(LNAME+IOFF+ZIBANK) .EQ. IBANK) THEN LR2 = LQ(LNAME-INDX) RETURN ENDIF IERROR = 0 IDD = IQ(LBUF-5) LCIND = IQ(LNAME+IOFF+ZLCONT) IF (IQ(LCID+ZNPRIM) .LT. 0) THEN LR2 = LQ(LBUF-LCIND) DO 10 I = 2, IBANK IF (LQ(LR2) .NE. 0) LR2 = LQ(LR2) 10 CONTINUE IF (LR2 .EQ. 0) THEN print*,'Bank does not exist', 'HGNT', IDD GOTO 90 ENDIF ELSE IF (.NOT.NRECOV .AND. IBANK.GT.IQ(LNAME+IOFF+ZNRZB)) THEN print*,'Bank does not exist', 'HGNT', IDD GOTO 90 ENDIF NCHRZ = IQ(LCID+ZNCHRZ) IF(NCHRZ.NE.0)THEN CALL RZCDIR(CWDRZ,'R') CALL HCDIR(CHWOLD,'R') CHDIR = ' ' CALL UHTOC(IQ(LCID+ZNCHRZ+1),4,CHDIR,NCHRZ) IF (CHDIR.NE.CWDRZ) THEN CALL HCDIR(CHDIR,' ') ENDIF ENDIF KEYS(1) = IQ(LCID+ZID) KEYS(2) = IBANK*10000 + IQ(LNAME+IOFF+ZLCONT) IF (NRECOV) THEN CALL RZINK(KEYS,99999,'R') IF (IQUEST(1) .NE. 0) GOTO 90 IQ(LNAME+IOFF+ZNRZB) = IBANK IF (JBIT(IQ(LNAME+IOFF+ZDESC),28) .EQ. 1) THEN CALL HRZIN(IHDIV,LBUF,-LCIND,KEYS,99999,'R') IF (IQUEST(1) .NE. 0) GOTO 90 ENDIF ELSE CALL HRZIN(IHDIV,LBUF,-LCIND,KEYS,99999,'R') IF (IQUEST(1) .NE. 0) THEN KEYS(1) = 0 IQUEST(1) = 0 CALL HRZIN(IHDIV,LBUF,-LCIND,KEYS,99999,'R') ENDIF IF (IQUEST(1) .NE. 0) GOTO 90 IQ(LQ(LBUF-LCIND)) = 0 ENDIF IF (NCHRZ.NE.0.AND.CHDIR .NE. CWDRZ) THEN CALL HCDIR(CHWOLD,' ') IF (CHWOLD .NE. CWDRZ) THEN CALL RZCDIR(CWDRZ,' ') ENDIF ENDIF LR2 = LQ(LBUF-LCIND) ENDIF IQ(LNAME+IOFF+ZIBANK) = IBANK LQ(LNAME-INDX) = LR2 RETURN 90 IERROR = 1 99 END *------------------------------------------------------------------------------- SUBROUTINE HPAFF(CH,NL,CHPATH) CHARACTER*128 CHMAIL COMMON /HCMAIL/CHMAIL CHARACTER*(*) CHPATH,CH(*) CHARACTER*16 CHL MAXLEN=LEN(CHPATH) IF(MAXLEN.GT.110)MAXLEN=110 CHPATH='//'//CH(1) LENG=LENOCC(CHPATH) IF(LENG.EQ.2) THEN CHPATH='//HOME' LENG=6 ENDIF IF(NL.EQ.1) GOTO 99 DO 20 I=2,NL CHL=CH(I) NMAX=LENOCC(CHL) IF(NMAX.EQ.0) GOTO 99 IF(LENG+NMAX.GT.MAXLEN)NMAX=MAXLEN-LENG CHMAIL=CHPATH(1:LENG)//'/'//CHL(1:NMAX) CHPATH=CHMAIL LENG=LENG+NMAX+1 IF(LENG.EQ.MAXLEN)GO TO 99 20 CONTINUE 99 RETURN END *------------------------------------------------------------------------------- SUBROUTINE HRZFRA(IH,IOH,NW) DIMENSION IH(1), IOH(1) DO 20 IW=1,NW IB1=JBYT(IH(IW), 1,8) IB2=JBYT(IH(IW), 9,8) IB3=JBYT(IH(IW),17,8) IB4=JBYT(IH(IW),25,8) IOH(IW)=IB4 CALL SBYT(IB3,IOH(IW), 9,8) CALL SBYT(IB2,IOH(IW),17,8) CALL SBYT(IB1,IOH(IW),25,8) 20 CONTINUE END *------------------------------------------------------------------------------- SUBROUTINE HSPACE (N,CHROUT,IDD) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) INTEGER ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV COMMON/HCFLAG/ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV COMMON/QUEST/IQUEST(100) CHARACTER*(*) CHROUT IDLAST=0 IERR=0 CALL MZNEED(IHDIV,N,' ') IF(IQUEST(11).LT.0)THEN CALL MZNEED(IHDIV,N,'G') ENDIF IQUEST(1)=0 IF(IQUEST(11).LT.0)THEN print*,'Not enough space in memory',CHROUT,IDD IERR =1 ENDIF END *------------------------------------------------------------------------------- SUBROUTINE HNTMPD(IDD) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) IF (LQ(LCDIR-5) .EQ. 0) RETURN IF (IDD .EQ. 0) THEN CALL MZDROP(IHDIV,LQ(LCDIR-5),'L') LQ(LCDIR-5) = 0 LTMPM = 0 LTMP = 0 ELSE LTMP = LQ(LCDIR-5) 20 IF (IQ(LTMP-5) .EQ. IDD) THEN CALL MZDROP(IHDIV,LTMP,' ') LTMP = LQ(LCDIR-5) GOTO 40 ENDIF LTMP = LQ(LTMP) IF (LTMP .NE. 0) GOTO 20 RETURN ENDIF 40 END *------------------------------------------------------------------------------- SUBROUTINE HNBUFD(IDD) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) CALL HNTMPD(IDD) IF (LQ(LCDIR-4) .EQ. 0) RETURN IF (IDD .EQ. 0) THEN CALL MZDROP(IHDIV,LQ(LCDIR-4),'L') LQ(LCDIR-4) = 0 LBUFM = 0 LBUF = 0 ELSE LBUF = LQ(LCDIR-4) 20 IF (IQ(LBUF-5) .EQ. IDD) THEN CALL MZDROP(IHDIV,LBUF,' ') LBUF = LQ(LCDIR-4) GOTO 40 ENDIF LBUF = LQ(LBUF) IF (LBUF .NE. 0) GOTO 20 RETURN ENDIF 40 END *------------------------------------------------------------------------------- SUBROUTINE HNTVAR(ID1,IVAR,CHTAG,BLOCK,NSUB,ITYPE,ISIZE,IELEM) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) INTEGER ZBITS, ZNDIM, ZNOENT, ZNPRIM, ZNRZB, ZIFCON, + ZIFNAM, ZIFCHA, ZIFINT, ZIFREA, ZNWTIT, ZITIT1, + ZNCHRZ, ZDESC, ZLNAME, ZNAME, ZARIND, ZRANGE, ZNADDR, + ZIBLOK, ZNBLOK, ZLCONT, ZIFBIT, ZIBANK, ZIFTMP, ZITMP, + ZID, ZNTMP, ZNTMP1, ZLINK PARAMETER(ZBITS=1, ZNDIM=2, ZNOENT=3, ZNPRIM=4, ZLCONT=6, + ZNRZB=5, ZIFCON=7, ZIFNAM=4, ZIFCHA=5, ZIFINT=6, + ZIFREA=7, ZNWTIT=8, ZITIT1=9, ZNCHRZ=13, ZIFBIT=8, + ZDESC=1, ZLNAME=2, ZNAME=3, ZRANGE=4, ZNADDR=12, + ZARIND=11, ZIBLOK=8, ZNBLOK=10, ZIBANK=9, ZIFTMP=11, + ZID=12, ZITMP=10, ZNTMP=6, ZNTMP1=3, ZLINK=6) INTEGER ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV COMMON/HCFLAG/ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV INTEGER I1, I2, I3, I4, I5, I6, I7, I8, + I9, I10, I11, I12, I13, I14, I15, I16, +I17, I18, I19, I20, I21, I22, I23, I24, I25, I26, I27, +I28, I29, I30, I31, I32, I33, I34, I35, I123, I230 COMMON / HCBITS / I1, I2, I3, I4, I5, I6, I7, I8, + I9, I10, I11, I12, I13, I14, I15, I16, +I17, I18, I19, I20, I21, I22, I23, I24, I25, I26, I27, +I28, I29, I30, I31, I32, I33, I34, I35, I123, I230 CHARACTER*(*) CHTAG, BLOCK CHARACTER*32 NAME LOGICAL NEWTUP, LDUM ID = ID1 IDPOS = LOCATI(IQ(LTAB+1),IQ(LCDIR+KNRH),ID) IF (IDPOS .LE. 0) THEN print*,'Unknown N-tuple','HNTVAR',ID1 RETURN ENDIF LCID = LQ(LTAB-IDPOS) I4 = JBIT(IQ(LCID+KBITS),4) IF (I4 .EQ. 0) RETURN NEWTUP = .TRUE. IF (IQ(LCID-2) .NE. ZLINK) NEWTUP = .FALSE. CHTAG = ' ' NAME = ' ' BLOCK = ' ' NSUB = 0 ITYPE = 0 ISIZE = 0 IELEM = 0 ICNT = 0 IF (NEWTUP) THEN IF (IVAR .GT. IQ(LCID+ZNDIM)) RETURN LBLOK = LQ(LCID-1) LCHAR = LQ(LCID-2) LINT = LQ(LCID-3) LREAL = LQ(LCID-4) 5 LNAME = LQ(LBLOK-1) IOFF = 0 NDIM = IQ(LBLOK+ZNDIM) DO 10 I = 1, NDIM ICNT = ICNT + 1 IF (ICNT .EQ. IVAR) THEN CALL HNDESC(IOFF, NSUB, ITYPE, ISIZE, NBITS, LDUM) LL = IQ(LNAME+IOFF+ZLNAME) LV = IQ(LNAME+IOFF+ZNAME) CALL UHTOC(IQ(LCHAR+LV), 4, NAME, LL) CALL UHTOC(IQ(LBLOK+ZIBLOK), 4, BLOCK, 8) IELEM = 1 DO 25 J = 1, NSUB LP = IQ(LINT+IQ(LNAME+IOFF+ZARIND)+(J-1)) IF (LP .LT. 0) THEN IE = -LP ELSE LL = IQ(LNAME+LP-1+ZRANGE) IE = IQ(LINT+LL+1) ENDIF IELEM = IELEM*IE 25 CONTINUE CHTAG = NAME RETURN ENDIF IOFF = IOFF + ZNADDR 10 CONTINUE LBLOK = LQ(LBLOK) IF (LBLOK .NE. 0) GOTO 5 ELSE IF (IVAR .GT. IQ(LCID+2)) RETURN ITAG1 = IQ(LCID+10) CALL UHTOC(IQ(LCID+ITAG1+2*(IVAR-1)), 4, NAME, 8) CHTAG = NAME ITYPE = 1 ISIZE = 4 IELEM = 1 ENDIF END *------------------------------------------------------------------------------- SUBROUTINE HNMSET(IDD, ITEM, IVAL) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) INTEGER ZBITS, ZNDIM, ZNOENT, ZNPRIM, ZNRZB, ZIFCON, + ZIFNAM, ZIFCHA, ZIFINT, ZIFREA, ZNWTIT, ZITIT1, + ZNCHRZ, ZDESC, ZLNAME, ZNAME, ZARIND, ZRANGE, ZNADDR, + ZIBLOK, ZNBLOK, ZLCONT, ZIFBIT, ZIBANK, ZIFTMP, ZITMP, + ZID, ZNTMP, ZNTMP1, ZLINK PARAMETER(ZBITS=1, ZNDIM=2, ZNOENT=3, ZNPRIM=4, ZLCONT=6, + ZNRZB=5, ZIFCON=7, ZIFNAM=4, ZIFCHA=5, ZIFINT=6, + ZIFREA=7, ZNWTIT=8, ZITIT1=9, ZNCHRZ=13, ZIFBIT=8, + ZDESC=1, ZLNAME=2, ZNAME=3, ZRANGE=4, ZNADDR=12, + ZARIND=11, ZIBLOK=8, ZNBLOK=10, ZIBANK=9, ZIFTMP=11, + ZID=12, ZITMP=10, ZNTMP=6, ZNTMP1=3, ZLINK=6) INTEGER ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV COMMON/HCFLAG/ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV ID = IDD IDPOS = LOCATI(IQ(LTAB+1),IQ(LCDIR+KNRH),ID) IF (IDPOS .LE. 0) THEN print*,'Unknown N-tuple','HNMSET',IDD RETURN ENDIF LCID=LQ(LTAB-IDPOS) LBLOK = LQ(LCID-1) LCHAR = LQ(LCID-2) LINT = LQ(LCID-3) LREAL = LQ(LCID-4) 10 LNAME = LQ(LBLOK-1) IOFF = 0 NDIM = IQ(LBLOK+ZNDIM) DO 20 I = 1, NDIM IQ(LNAME+IOFF+ITEM) = IVAL IOFF = IOFF + ZNADDR 20 CONTINUE LBLOK = LQ(LBLOK) IF (LBLOK .NE. 0) GOTO 10 END *------------------------------------------------------------------------------- INTEGER FUNCTION HNBPTR(BLKNA1) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) INTEGER ZBITS, ZNDIM, ZNOENT, ZNPRIM, ZNRZB, ZIFCON, + ZIFNAM, ZIFCHA, ZIFINT, ZIFREA, ZNWTIT, ZITIT1, + ZNCHRZ, ZDESC, ZLNAME, ZNAME, ZARIND, ZRANGE, ZNADDR, + ZIBLOK, ZNBLOK, ZLCONT, ZIFBIT, ZIBANK, ZIFTMP, ZITMP, + ZID, ZNTMP, ZNTMP1, ZLINK PARAMETER(ZBITS=1, ZNDIM=2, ZNOENT=3, ZNPRIM=4, ZLCONT=6, + ZNRZB=5, ZIFCON=7, ZIFNAM=4, ZIFCHA=5, ZIFINT=6, + ZIFREA=7, ZNWTIT=8, ZITIT1=9, ZNCHRZ=13, ZIFBIT=8, + ZDESC=1, ZLNAME=2, ZNAME=3, ZRANGE=4, ZNADDR=12, + ZARIND=11, ZIBLOK=8, ZNBLOK=10, ZIBANK=9, ZIFTMP=11, + ZID=12, ZITMP=10, ZNTMP=6, ZNTMP1=3, ZLINK=6) CHARACTER*(*) BLKNA1 CHARACTER*8 BLKNAM INTEGER IBLKN(2) BLKNAM = BLKNA1 CALL CLTOU(BLKNAM) HNBPTR = 0 CALL UCTOH(BLKNAM, IBLKN, 4, 8) LL = LQ(LCID-1) 10 IF (IBLKN(1).EQ.IQ(LL+ZIBLOK) .AND. + IBLKN(2).EQ.IQ(LL+ZIBLOK+1)) THEN HNBPTR = LL RETURN ENDIF LL = LQ(LL) IF (LL .NE. 0) GOTO 10 END *------------------------------------------------------------------------------- SUBROUTINE HNBUFF(IDD, FATAL) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) INTEGER ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV COMMON/HCFLAG/ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV LOGICAL FATAL IF (LQ(LCDIR-4) .EQ. 0) THEN IF (FATAL) THEN print*,'Buffer structure not initialized.','HNBUFF',IDD ENDIF IERR = 1 RETURN ELSEIF (IQ(LBUF-5) .NE. IDD) THEN LBUF = LQ(LCDIR-4) 20 IF (IQ(LBUF-5) .EQ. IDD) GOTO 40 IF (LQ(LBUF) .NE. 0) THEN LBUF = LQ(LBUF) GOTO 20 ENDIF IF (FATAL) THEN print*,'Buffer structure not found.','HNBUFF',IDD ENDIF IERR = 1 RETURN ENDIF 40 CONTINUE print*, '>>>>>> CALL HNTMPF(IDD, FATAL)' ******CALL HNTMPF(IDD, FATAL) END *------------------------------------------------------------------------------- SUBROUTINE HNBFWR(IDD) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) INTEGER ZBITS, ZNDIM, ZNOENT, ZNPRIM, ZNRZB, ZIFCON, + ZIFNAM, ZIFCHA, ZIFINT, ZIFREA, ZNWTIT, ZITIT1, + ZNCHRZ, ZDESC, ZLNAME, ZNAME, ZARIND, ZRANGE, ZNADDR, + ZIBLOK, ZNBLOK, ZLCONT, ZIFBIT, ZIBANK, ZIFTMP, ZITMP, + ZID, ZNTMP, ZNTMP1, ZLINK PARAMETER(ZBITS=1, ZNDIM=2, ZNOENT=3, ZNPRIM=4, ZLCONT=6, + ZNRZB=5, ZIFCON=7, ZIFNAM=4, ZIFCHA=5, ZIFINT=6, + ZIFREA=7, ZNWTIT=8, ZITIT1=9, ZNCHRZ=13, ZIFBIT=8, + ZDESC=1, ZLNAME=2, ZNAME=3, ZRANGE=4, ZNADDR=12, + ZARIND=11, ZIBLOK=8, ZNBLOK=10, ZIBANK=9, ZIFTMP=11, + ZID=12, ZITMP=10, ZNTMP=6, ZNTMP1=3, ZLINK=6) INTEGER ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV COMMON/HCFLAG/ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV CHARACTER*128 CHWOLD, CHDIR, CWDRZ INTEGER KEYS(2) IERR = 0 CALL HNBUFF(IDD, .FALSE.) IF (IERR .NE. 0) GOTO 99 NCHRZ = IQ(LCID+ZNCHRZ) IF(NCHRZ.NE.0)THEN CALL RZCDIR(CWDRZ,'R') CALL HCDIR(CHWOLD,'R') CHDIR = ' ' CALL UHTOC(IQ(LCID+ZNCHRZ+1),4,CHDIR,NCHRZ) IF (CHDIR .NE. CWDRZ) THEN CALL HCDIR(CHDIR,' ') ENDIF ENDIF KEYS(1) = IDD KEYS(2) = 0 LBLOK = LQ(LCID-1) LCHAR = LQ(LCID-2) LINT = LQ(LCID-3) LREAL = LQ(LCID-4) 10 LNAME = LQ(LBLOK-1) IOFF = 0 NDIM = IQ(LBLOK+ZNDIM) DO 20 I = 1, NDIM LCIND = IQ(LNAME+IOFF+ZLCONT) LB = LQ(LBUF-LCIND) IF (LB .EQ. 0) GOTO 15 IF (JBIT(IQ(LB),1) .EQ. 0) GOTO 15 CALL SBIT0(IQ(LB),1) KEYS(2) = IQ(LNAME+IOFF+ZNRZB)*10000 + IQ(LNAME+IOFF+ZLCONT) IF (IQ(LCID+ZNPRIM) .GT. 0) THEN print*, '>>>>>> HRZOUT' ****** CALL HRZOUT(IHDIV,LB,KEYS,ICYCLE,'A') ELSE print*, '>>>>>> HRZOUT' ****** CALL HRZOUT(IHDIV,LB,KEYS,ICYCLE,'LA') ENDIF 15 IOFF = IOFF + ZNADDR 20 CONTINUE LBLOK = LQ(LBLOK) IF (LBLOK .NE. 0) GOTO 10 IF (KEYS(2) .NE. 0) CALL SBIT1(IQ(LQ(LCID-1)),1) IF (NCHRZ.NE.0.AND.CHDIR .NE. CWDRZ) THEN CALL HCDIR(CHWOLD,' ') IF (CHWOLD .NE. CWDRZ) THEN CALL RZCDIR(CWDRZ,' ') ENDIF ENDIF 99 RETURN END *------------------------------------------------------------------------------- SUBROUTINE HNHDWR(IDD) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) INTEGER ZBITS, ZNDIM, ZNOENT, ZNPRIM, ZNRZB, ZIFCON, + ZIFNAM, ZIFCHA, ZIFINT, ZIFREA, ZNWTIT, ZITIT1, + ZNCHRZ, ZDESC, ZLNAME, ZNAME, ZARIND, ZRANGE, ZNADDR, + ZIBLOK, ZNBLOK, ZLCONT, ZIFBIT, ZIBANK, ZIFTMP, ZITMP, + ZID, ZNTMP, ZNTMP1, ZLINK PARAMETER(ZBITS=1, ZNDIM=2, ZNOENT=3, ZNPRIM=4, ZLCONT=6, + ZNRZB=5, ZIFCON=7, ZIFNAM=4, ZIFCHA=5, ZIFINT=6, + ZIFREA=7, ZNWTIT=8, ZITIT1=9, ZNCHRZ=13, ZIFBIT=8, + ZDESC=1, ZLNAME=2, ZNAME=3, ZRANGE=4, ZNADDR=12, + ZARIND=11, ZIBLOK=8, ZNBLOK=10, ZIBANK=9, ZIFTMP=11, + ZID=12, ZITMP=10, ZNTMP=6, ZNTMP1=3, ZLINK=6) INTEGER ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV COMMON/HCFLAG/ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV CHARACTER*128 CHWOLD, CHDIR, CWDRZ INTEGER KEYS(2) IERR = 0 NCHRZ = IQ(LCID+ZNCHRZ) CALL RZCDIR(CWDRZ,'R') CALL HCDIR(CHWOLD,'R') CHDIR = ' ' CALL UHTOC(IQ(LCID+ZNCHRZ+1),4,CHDIR,NCHRZ) IF (CHDIR.NE.CWDRZ) THEN CALL HCDIR(CHDIR,' ') ENDIF LC = LQ(LCID-1) IF (JBIT(IQ(LC),1) .NE. 0) THEN CALL SBIT0(IQ(LC),1) CALL SBIT0(IQ(LC),2) KEYS(1) = IDD KEYS(2) = 0 print*, '>>>>>> HRZOUT' ****** CALL HRZOUT(IHDIV,LCID,KEYS,ICYCLE,' ') CALL RZSAVE ENDIF IF (CHDIR.NE.CWDRZ) THEN CALL HCDIR(CHWOLD,' ') IF (CHWOLD .NE. CWDRZ) THEN CALL RZCDIR(CWDRZ,' ') ENDIF ENDIF END *------------------------------------------------------------------------------- SUBROUTINE HLDIR(CHPATH,CHOPT) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) INTEGER LOUT,LERR,LINFIT COMMON/HCUNIT/LOUT,LERR,LINFIT PARAMETER (NLPATM=100, MXFILES=50, LENHFN=128) COMMON /HCDIRN/NLCDIR,NLNDIR,NLPAT,ICDIR,NCHTOP,ICHTOP(MXFILES) + ,ICHTYP(MXFILES),ICHLUN(MXFILES) CHARACTER*16 CHNDIR, CHCDIR, CHPAT ,CHTOP COMMON /HCDIRC/CHCDIR(NLPATM),CHNDIR(NLPATM),CHPAT(NLPATM) + ,CHTOP(NLPATM) CHARACTER*(LENHFN) HFNAME COMMON /HCFILE/HFNAME(MXFILES) CHARACTER*128 CHMAIL COMMON /HCMAIL/CHMAIL DIMENSION IPAWC(99) EQUIVALENCE (NWPAW,IPAWC(1)) COMMON/QUEST/IQUEST(100) CHARACTER*(*) CHPATH,CHOPT CHARACTER*128 CHWOLD DIMENSION LCUR(15),IOPT(5) EQUIVALENCE (IOPTT,IOPT(1)),(IOPTR,IOPT(2)),(IOPTN,IOPT(3)) EQUIVALENCE (IOPTI,IOPT(4)),(IOPTS,IOPT(5)) EXTERNAL HLDIRT IF(CHPATH.EQ.'//')THEN DO 10 I=1,NCHTOP CHMAIL=CHTOP(I)//HFNAME(I) NCH=LENOCC(CHMAIL) WRITE(LOUT,1000)CHMAIL(1:NCH) 10 CONTINUE 1000 FORMAT(' //',A) GO TO 99 ENDIF IF(LHBOOK.EQ.0)GO TO 99 CALL HUOPTC (CHOPT,'TRNIS',IOPT) CALL HPAFF(CHCDIR,NLCDIR,CHWOLD) LR2=LCDIR CALL HCDIR(CHPATH,' ') IF (IQUEST(1) .NE. 0) GOTO 40 IF(ICHTOP(ICDIR).NE.0)THEN IF(IOPTR.NE.0)THEN print*,'CALL HRZLD(...)' ****** CALL HRZLD(' ',CHOPT) ELSE IQUEST(88)=IOPTS IQUEST(89)=IOPTN IF(IOPTT.EQ.0)THEN CALL HLDIRT(CHPATH) ELSE CALL RZSCAN(' ',HLDIRT) ENDIF ENDIF GO TO 40 ENDIF NLPAT0=NLPAT LCUR(NLPAT)=LCDIR IF(IOPTS.NE.0)THEN print*,'>>>>>> CALL ZSORTI(IHDIV,LIDS,-5)' ****** CALL ZSORTI(IHDIV,LIDS,-5) ENDIF print*,'>>>>>> CALL HLDIR1(IOPTI,IOPTN,1)' ******CALL HLDIR1(IOPTI,IOPTN,1) 20 NLPAT=NLPAT+1 LCDIR=LQ(LCDIR-1) 30 LCUR(NLPAT)=LCDIR IF(LCDIR.EQ.0)THEN NLPAT=NLPAT-1 LCDIR=LCUR(NLPAT) IF(NLPAT.LE.NLPAT0)GO TO 40 LCDIR=LQ(LCDIR) GO TO 30 ENDIF CALL UHTOC(IQ(LCDIR+1),4,CHCDIR(NLPAT),16) LIDS=LQ(LCDIR-2) LTAB=LQ(LCDIR-3) IF(IOPTS.NE.0)THEN print*,'>>>>>> CALL ZSORTI(IHDIV,LIDS,-5)' ****** CALL ZSORTI(IHDIV,LIDS,-5) ENDIF print*,'>>>>>> CALL HLDIR1(IOPTI,IOPTN,IOPTT)' ******CALL HLDIR1(IOPTI,IOPTN,IOPTT) GO TO 20 40 CALL HCDIR(CHWOLD,' ') LCDIR = LR2 LIDS = LQ(LCDIR-2) LTAB = LQ(LCDIR-3) LBUFM = LQ(LCDIR-4) LTMPM = LQ(LCDIR-5) 99 RETURN END *------------------------------------------------------------------------------- SUBROUTINE HLDIRT(CHDIR) INTEGER NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU, LMAIN REAL FENC , HCV COMMON/PAWC/NWPAW,IXPAWC,IHDIV,IXHIGZ,IXKU,FENC(5),LMAIN, +HCV(4000000-11) INTEGER IQ ,LQ REAL Q DIMENSION IQ(2),Q(2),LQ(8000) EQUIVALENCE (LQ(1),LMAIN),(IQ(1),LQ(9)),(Q(1),IQ(1)) INTEGER HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM, +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN COMMON/HCBOOK/HVERSN,IHWORK,LHBOOK,LHPLOT,LGTIT,LHWORK, +LCDIR,LSDIR,LIDS,LTAB,LCID,LCONT,LSCAT,LPROX,LPROY,LSLIX, +LSLIY,LBANX,LBANY,LPRX,LPRY,LFIX,LLID,LR1,LR2,LNAME,LCHAR,LINT, +LREAL,LBLOK,LLBLK,LBUFM,LBUF,LTMPM,LTMP,LTMP1,LHPLIP,LHDUM(9), +LHFIT,LFUNC,LHFCO,LHFNA,LCIDN INTEGER KNCX ,KXMIN ,KXMAX ,KMIN1 ,KMAX1 ,KNORM , KTIT1, + KNCY ,KYMIN ,KYMAX ,KMIN2 ,KMAX2 ,KSCAL2 , KTIT2, + KNBIT ,KNOENT ,KSTAT1 ,KNSDIR ,KNRH , + KCON1 ,KCON2 ,KBITS ,KNTOT PARAMETER(KNCX=3,KXMIN=4,KXMAX=5,KMIN1=7,KMAX1=8,KNORM=9,KTIT1=10, + KNCY=7,KYMIN=8,KYMAX=9,KMIN2=6,KMAX2=10,KSCAL2=11, + KTIT2=12,KNBIT=1,KNOENT=2,KSTAT1=3,KNSDIR=5,KNRH=6, + KCON1=9,KCON2=3,KBITS=1,KNTOT=2) INTEGER ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV COMMON/HCFLAG/ID ,IDBADD,LID ,IDLAST,IDHOLD,NBIT ,NBITCH, + NCHAR ,NRHIST,IERR ,NV INTEGER LOUT,LERR,LINFIT COMMON/HCUNIT/LOUT,LERR,LINFIT INTEGER ZBITS, ZNDIM, ZNOENT, ZNPRIM, ZNRZB, ZIFCON, + ZIFNAM, ZIFCHA, ZIFINT, ZIFREA, ZNWTIT, ZITIT1, + ZNCHRZ, ZDESC, ZLNAME, ZNAME, ZARIND, ZRANGE, ZNADDR, + ZIBLOK, ZNBLOK, ZLCONT, ZIFBIT, ZIBANK, ZIFTMP, ZITMP, + ZID, ZNTMP, ZNTMP1, ZLINK PARAMETER(ZBITS=1, ZNDIM=2, ZNOENT=3, ZNPRIM=4, ZLCONT=6, + ZNRZB=5, ZIFCON=7, ZIFNAM=4, ZIFCHA=5, ZIFINT=6, + ZIFREA=7, ZNWTIT=8, ZITIT1=9, ZNCHRZ=13, ZIFBIT=8, + ZDESC=1, ZLNAME=2, ZNAME=3, ZRANGE=4, ZNADDR=12, + ZARIND=11, ZIBLOK=8, ZNBLOK=10, ZIBANK=9, ZIFTMP=11, + ZID=12, ZITMP=10, ZNTMP=6, ZNTMP1=3, ZLINK=6) CHARACTER*(*) CHDIR COMMON/QUEST/IQUEST(100) CHARACTER*1 HTYPE INTEGER KEYS(2) NCH=LENOCC(CHDIR) WRITE(LOUT,1000)CHDIR(1:NCH) IOPTS=IQUEST(88) IOPTN=IQUEST(89) IF(IOPTS.NE.0)THEN print*,'>>>>>> CALL HRSORT(...)' ****** CALL HRSORT('S') ENDIF KEYNUM = 1 KEYS(1) = KEYNUM KEYS(2) = 0 CALL HRZIN(IHWORK,0,0,KEYS,9999,'SC') IDN=IQUEST(21) IQ42=IQUEST(22) 10 IF (IDN .EQ. 0) GOTO 90 KEYS(1) = KEYNUM CALL HRZIN(IHWORK,0,0,KEYS,9999,'SNC') IF(IQUEST(1).NE.0)GO TO 90 IDN =IQUEST(21) IQ40=IQUEST(40) IQ41=IQUEST(41) IQ42=IQUEST(42) IF(IQ40.EQ.0) IQ41=0 NWORDS=IQUEST(12) IOPTA=JBIT(IQUEST(14),4) IF(IOPTA.NE.0)GO TO 40 CALL HSPACE(NWORDS+1000,'HLDIR ',IDN) IF(IERR.NE.0) GO TO 90 CALL HRZIN(IHWORK,LHWORK,1,KEYS,9999,'SND') IF(IQUEST(1).NE.0)THEN print*, 'Bad sequence for RZ','HLDIR',IDN GO TO 90 ENDIF IF(IQ(LHWORK-2).EQ.0)THEN WRITE(LOUT,2100)IDN ELSEIF(JBIT(IQ(LHWORK+KBITS),1).NE.0)THEN IF(IOPTN.EQ.0)THEN HTYPE='1' NWTITL=IQ(LHWORK-1)-KTIT1+1 WRITE(LOUT,2000)IDN,HTYPE,(IQ(LHWORK+KTIT1+I-1),I=1,NWTITL) ENDIF ELSEIF(JBYT(IQ(LHWORK+KBITS),2,2).NE.0)THEN IF(IOPTN.EQ.0)THEN HTYPE='2' NWTITL=IQ(LHWORK-1)-KTIT2+1 WRITE(LOUT,2000)IDN,HTYPE,(IQ(LHWORK+KTIT2+I-1),I=1,NWTITL) ENDIF ELSEIF(JBIT(IQ(LHWORK+KBITS),4).NE.0)THEN HTYPE='N' IF (IQ(LHWORK-2) .EQ. 2) THEN ITIT1=IQ(LHWORK+9) NWTITL=IQ(LHWORK+8) ELSE ITIT1=IQ(LHWORK+ZITIT1) NWTITL=IQ(LHWORK+ZNWTIT) ENDIF WRITE(LOUT,2000)IDN,HTYPE,(IQ(LHWORK+ITIT1+I-1),I=1,NWTITL) ENDIF CALL MZDROP(IHWORK,LHWORK,' ') 40 LHWORK=0 IF(IQ40.EQ.0)THEN CALL MZWIPE(IHWORK) GO TO 99 ENDIF KEYNUM=KEYNUM+1 IDN=IQ41 GO TO 10 90 CONTINUE 1000 FORMAT(//,' ===> Directory : ',A) 2000 FORMAT(1X,I10,1X,'(',A,')',3X,20A4) 2100 FORMAT(1X,I10,1X,'(A) Unnamed array') 99 RETURN END *------------------------------------------------------------------------------- SUBROUTINE HREND(CHDIR) PARAMETER (NLPATM=100, MXFILES=50, LENHFN=128) COMMON /HCDIRN/NLCDIR,NLNDIR,NLPAT,ICDIR,NCHTOP,ICHTOP(MXFILES) + ,ICHTYP(MXFILES),ICHLUN(MXFILES) CHARACTER*16 CHNDIR, CHCDIR, CHPAT ,CHTOP COMMON /HCDIRC/CHCDIR(NLPATM),CHNDIR(NLPATM),CHPAT(NLPATM) + ,CHTOP(NLPATM) CHARACTER*(LENHFN) HFNAME COMMON /HCFILE/HFNAME(MXFILES) CHARACTER*(*) CHDIR NCHMAX=NCHTOP DO 20 I=2,NCHMAX IF(CHTOP(I).EQ.CHDIR)THEN IF(ICHTOP(I).GT.0.AND.ICHTOP(I).LT.1000)THEN CALL RZEND(CHDIR) ****** CALL HBFREE(ICHTOP(I)) ENDIF ****** CALL HNTDEL(CHDIR) DO 10 J=I+1,NCHTOP ICHTOP(J-1)=ICHTOP(J) ICHLUN(J-1)=ICHLUN(J) ICHTYP(J-1)=ICHTYP(J) CHTOP(J-1)=CHTOP(J) HFNAME(J-1)=HFNAME(J) 10 CONTINUE NCHTOP=NCHTOP-1 ENDIF 20 CONTINUE CALL HCDIR('//PAWC',' ') END *------------------------------------------------------------------------------- SUBROUTINE HGNTF(IDD,IDNEVT,IERROR) print*,'>>>>>> Dummy HGNTF' END *-------------------------------------------------------------------------------