hntvar2.f

Go to the documentation of this file.

*CMZ :  2.21/05 08/02/99  11.10.43  by  Rene Brun
*CMZ :  0.90/10 09/12/96  17.08.32  by  Rene Brun
*-- Author :    Rene Brun   09/12/96
      SUBROUTINE hntvar2(ID1,IVAR,CHTAG,CHFULL,BLOCK,NSUB,ITYPE,ISIZE
     +                  ,ielem)
*.==========>
*.
*.           Returns the tag, block, type, size and array length of the
*.           variable with index IVAR in N-tuple ID1.
*.           N-tuple must already be in memory.
*.
*.           This routine is a modification of the HBOOK routine HNTVAR.
*.
*..=========> ( R.Brun, A.A.Rademakers )
*
*KEEP,HCNTPAR.
      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)
*
*KEEP,HCFLAG.
      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
*
*KEEP,HCBOOK.
      INTEGER     nwpaw,ixpawc,ihdiv,ixhigz,ixku,        lmain
      REAL                                       fenc   ,      hcv
      common/pawc/nwpaw,ixpawc,ihdiv,ixhigz,ixku,fenc(5),lmain,hcv(9989)
      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)
*
*KEEP,HCBITS.
      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
*
*KEND.
*
      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
         CALL hbug('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)
*
*-- loop over all blocks
*
  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