Geant4_10
hntvar2.f
Go to the documentation of this file.
1 *CMZ : 2.21/05 08/02/99 11.10.43 by Rene Brun
2 *CMZ : 0.90/10 09/12/96 17.08.32 by Rene Brun
3 *-- Author : Rene Brun 09/12/96
4  SUBROUTINE hntvar2(ID1,IVAR,CHTAG,CHFULL,BLOCK,NSUB,ITYPE,ISIZE
5  + ,ielem)
6 *.==========>
7 *.
8 *. Returns the tag, block, type, size and array length of the
9 *. variable with index IVAR in N-tuple ID1.
10 *. N-tuple must already be in memory.
11 *.
12 *. This routine is a modification of the HBOOK routine HNTVAR.
13 *.
14 *..=========> ( R.Brun, A.A.Rademakers )
15 *
16 *KEEP,HCNTPAR.
17  INTEGER zbits, zndim, znoent, znprim, znrzb, zifcon,
18  + zifnam, zifcha, zifint, zifrea, znwtit, zitit1,
19  + znchrz, zdesc, zlname, zname, zarind, zrange, znaddr,
20  + ziblok, znblok, zlcont, zifbit, zibank, ziftmp, zitmp,
21  + zid, zntmp, zntmp1, zlink
22  parameter(zbits=1, zndim=2, znoent=3, znprim=4, zlcont=6,
23  + znrzb=5, zifcon=7, zifnam=4, zifcha=5, zifint=6,
24  + zifrea=7, znwtit=8, zitit1=9, znchrz=13, zifbit=8,
25  + zdesc=1, zlname=2, zname=3, zrange=4, znaddr=12,
26  + zarind=11, ziblok=8, znblok=10, zibank=9, ziftmp=11,
27  + zid=12, zitmp=10, zntmp=6, zntmp1=3, zlink=6)
28 *
29 *KEEP,HCFLAG.
30  INTEGER id ,idbadd,lid ,idlast,idhold,nbit ,nbitch,
31  + nchar ,nrhist,ierr ,nv
32  common/hcflag/id ,idbadd,lid ,idlast,idhold,nbit ,nbitch,
33  + nchar ,nrhist,ierr ,nv
34 *
35 *KEEP,HCBOOK.
36  INTEGER nwpaw,ixpawc,ihdiv,ixhigz,ixku, lmain
37  REAL fenc , hcv
38  common/pawc/nwpaw,ixpawc,ihdiv,ixhigz,ixku,fenc(5),lmain,hcv(9989)
39  INTEGER iq ,lq
40  REAL q
41  dimension iq(2),q(2),lq(8000)
42  equivalence(lq(1),lmain),(iq(1),lq(9)),(q(1),iq(1))
43  INTEGER hversn,ihwork,lhbook,lhplot,lgtit,lhwork,
44  +lcdir,lsdir,lids,ltab,lcid,lcont,lscat,lprox,lproy,lslix,
45  +lsliy,lbanx,lbany,lprx,lpry,lfix,llid,lr1,lr2,lname,lchar,lint,
46  +lreal,lblok,llblk,lbufm,lbuf,ltmpm,ltmp,ltmp1,lhplip,lhdum,
47  +lhfit,lfunc,lhfco,lhfna,lcidn
48  common/hcbook/hversn,ihwork,lhbook,lhplot,lgtit,lhwork,
49  +lcdir,lsdir,lids,ltab,lcid,lcont,lscat,lprox,lproy,lslix,
50  +lsliy,lbanx,lbany,lprx,lpry,lfix,llid,lr1,lr2,lname,lchar,lint,
51  +lreal,lblok,llblk,lbufm,lbuf,ltmpm,ltmp,ltmp1,lhplip,lhdum(9),
52  +lhfit,lfunc,lhfco,lhfna,lcidn
53 *
54  INTEGER kncx ,kxmin ,kxmax ,kmin1 ,kmax1 ,knorm , ktit1,
55  + kncy ,kymin ,kymax ,kmin2 ,kmax2 ,kscal2 , ktit2,
56  + knbit ,knoent ,kstat1 ,knsdir ,knrh ,
57  + kcon1 ,kcon2 ,kbits ,kntot
58  parameter(kncx=3,kxmin=4,kxmax=5,kmin1=7,kmax1=8,knorm=9,ktit1=10,
59  + kncy=7,kymin=8,kymax=9,kmin2=6,kmax2=10,kscal2=11,
60  + ktit2=12,knbit=1,knoent=2,kstat1=3,knsdir=5,knrh=6,
61  + kcon1=9,kcon2=3,kbits=1,kntot=2)
62 *
63 *KEEP,HCBITS.
64  INTEGER i1, i2, i3, i4, i5, i6, i7, i8,
65  + i9, i10, i11, i12, i13, i14, i15, i16,
66  +i17, i18, i19, i20, i21, i22, i23, i24, i25, i26, i27,
67  +i28, i29, i30, i31, i32, i33, i34, i35, i123, i230
68  COMMON / hcbits / i1, i2, i3, i4, i5, i6, i7, i8,
69  + i9, i10, i11, i12, i13, i14, i15, i16,
70  +i17, i18, i19, i20, i21, i22, i23, i24, i25, i26, i27,
71  +i28, i29, i30, i31, i32, i33, i34, i35, i123, i230
72 *
73 *KEND.
74 *
75  CHARACTER*(*) chtag, chfull, block
76  CHARACTER*80 var
77  CHARACTER*32 name, subs
78  LOGICAL ldum
79 *
80  id = id1
81  idpos = locati(iq(ltab+1),iq(lcdir+knrh),id)
82  IF (idpos .LE. 0) THEN
83  CALL hbug('Unknown N-tuple','HNTVAR',id1)
84  RETURN
85  ENDIF
86  lcid = lq(ltab-idpos)
87 *
88  chtag = ' '
89  name = ' '
90  block = ' '
91  nsub = 0
92  itype = 0
93  isize = 0
94  ielem = 0
95 *
96  icnt = 0
97 *
98 *
99  IF (ivar .GT. iq(lcid+zndim)) RETURN
100 *
101  lblok = lq(lcid-1)
102  lchar = lq(lcid-2)
103  lint = lq(lcid-3)
104  lreal = lq(lcid-4)
105 *
106 *-- loop over all blocks
107 *
108  5 lname = lq(lblok-1)
109 *
110  ioff = 0
111  ndim = iq(lblok+zndim)
112 *
113  DO 10 i = 1, ndim
114  icnt = icnt + 1
115  IF (icnt .EQ. ivar) THEN
116 *
117  CALL hndesc(ioff, nsub, itype, isize, nbits, ldum)
118 *
119  ll = iq(lname+ioff+zlname)
120  lv = iq(lname+ioff+zname)
121  CALL uhtoc(iq(lchar+lv), 4, name, ll)
122  CALL uhtoc(iq(lblok+ziblok), 4, block, 8)
123 *
124  ielem = 1
125  IF (nsub .GT. 0) THEN
126  var = name(1:ll)//'['
127  DO 25 j = nsub,1,-1
128  lp = iq(lint+iq(lname+ioff+zarind)+(j-1))
129  IF (lp .LT. 0) THEN
130  ie = -lp
131  CALL hitoc(ie, subs, ll, ierr)
132  ELSE
133  ll = iq(lname+lp-1+zlname)
134  lv = iq(lname+lp-1+zname)
135  CALL uhtoc(iq(lchar+lv), 4, subs, ll)
136  ll1 = iq(lname+lp-1+zrange)
137  ie = iq(lint+ll1+1)
138  ENDIF
139  ielem = ielem*ie
140  IF (j .EQ. nsub) THEN
141  var = var(1:lenocc(var))//subs(1:ll)
142  ELSE
143  var = var(1:lenocc(var))//']['//subs(1:ll)
144  ENDIF
145  25 CONTINUE
146 *
147  var = var(1:lenocc(var))//']'
148  ELSE
149  var = name(1:ll)
150  ENDIF
151  chtag = name
152  chfull = var
153  RETURN
154 *
155  ENDIF
156 *
157  ioff = ioff + znaddr
158  10 CONTINUE
159 *
160  lblok = lq(lblok)
161  IF (lblok .NE. 0) goto 5
162 *
163  END
164 
const XML_Char * name
Definition: expat.h:151
subroutine hntvar2(ID1, IVAR, CHTAG, CHFULL, BLOCK, NSUB, ITYPE, ISIZE, IELEM)
Definition: hntvar2.f:4
REAL *8 function var(A, B, C, D)
Definition: dpm25nuc1.f:4649