hbook.f

Go to the documentation of this file.

*-------------------------------------------------------------------------------
*
* 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*, .LT.'>>>>>> HRIN: ICHTOP(ICDIR)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*, .GT.'>>>>>> HCDIR: ICHTOP(I)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
 
*-------------------------------------------------------------------------------