Analysis Software
Documentation for sPHENIX simulation software
 All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Friends Macros Groups Pages
luupda.f
Go to the documentation of this file. Or view the newest version in sPHENIX GitHub for file luupda.f
1 
2 C*********************************************************************
3 
4  SUBROUTINE luupda(MUPDA,LFN)
5 
6 C...Purpose: to facilitate the updating of particle and decay data.
7  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
8  SAVE /ludat1/
9  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
10  SAVE /ludat2/
11  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
12  SAVE /ludat3/
13  common/ludat4/chaf(500)
14  CHARACTER chaf*8
15  SAVE /ludat4/
16  CHARACTER chinl*80,chkc*4,chvar(19)*9,chlin*72,
17  &chblk(20)*72,chold*12,chtmp*12,chnew*12,chcom*12
18  DATA chvar/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','PMAS(I,1)',
19  &'PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)','MDCY(I,2)',
20  &'MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ','KFDP(I,1)',
21  &'KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)','CHAF(I) '/
22 
23 C...Write information on file for editing.
24  IF(mstu(12).GE.1) CALL lulist(0)
25  IF(mupda.EQ.1) THEN
26  DO 110 kc=1,mstu(6)
27  WRITE(lfn,1000) kc,chaf(kc),(kchg(kc,j1),j1=1,3),
28  & (pmas(kc,j2),j2=1,4),mdcy(kc,1)
29  DO 100 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
30  100 WRITE(lfn,1100) mdme(idc,1),mdme(idc,2),brat(idc),
31  & (kfdp(idc,j),j=1,5)
32  110 CONTINUE
33 
34 C...Reset variables and read information from edited file.
35  ELSEIF(mupda.EQ.2) THEN
36  DO 120 i=1,mstu(7)
37  mdme(i,1)=1
38  mdme(i,2)=0
39  brat(i)=0.
40  DO 120 j=1,5
41  120 kfdp(i,j)=0
42  kc=0
43  idc=0
44  ndc=0
45  130 READ(lfn,1200,end=140) chinl
46  IF(chinl(2:5).NE.' ') THEN
47  chkc=chinl(2:5)
48  IF(kc.NE.0) THEN
49  mdcy(kc,2)=0
50  IF(ndc.NE.0) mdcy(kc,2)=idc+1-ndc
51  mdcy(kc,3)=ndc
52  ENDIF
53  READ(chkc,1300) kc
54  IF(kc.LE.0.OR.kc.GT.mstu(6)) CALL luerrm(27,
55  & '(LUUPDA:) Read KC code illegal, KC ='//chkc)
56  READ(chinl,1000) kcr,chaf(kc),(kchg(kc,j1),j1=1,3),
57  & (pmas(kc,j2),j2=1,4),mdcy(kc,1)
58  ndc=0
59  ELSE
60  idc=idc+1
61  ndc=ndc+1
62  IF(idc.GE.mstu(7)) CALL luerrm(27,
63  & '(LUUPDA:) Decay data arrays full by KC ='//chkc)
64  READ(chinl,1100) mdme(idc,1),mdme(idc,2),brat(idc),
65  & (kfdp(idc,j),j=1,5)
66  ENDIF
67  goto 130
68  140 mdcy(kc,2)=0
69  IF(ndc.NE.0) mdcy(kc,2)=idc+1-ndc
70  mdcy(kc,3)=ndc
71 
72 C...Perform possible tests that new information is consistent.
73  mstj24=mstj(24)
74  mstj(24)=0
75  DO 170 kc=1,mstu(6)
76  WRITE(chkc,1300) kc
77  IF(min(pmas(kc,1),pmas(kc,2),pmas(kc,3),pmas(kc,1)-pmas(kc,3),
78  & pmas(kc,4)).LT.0..OR.mdcy(kc,3).LT.0) CALL luerrm(17,
79  & '(LUUPDA:) Mass/width/life/(# channels) wrong for KC ='//chkc)
80  brsum=0.
81  DO 160 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
82  IF(mdme(idc,2).GT.80) goto 160
83  kq=kchg(kc,1)
84  pms=pmas(kc,1)-pmas(kc,3)-parj(64)
85  merr=0
86  DO 150 j=1,5
87  kp=kfdp(idc,j)
88  IF(kp.EQ.0.OR.kp.EQ.81.OR.iabs(kp).EQ.82) THEN
89  ELSEIF(lucomp(kp).EQ.0) THEN
90  merr=3
91  ELSE
92  kq=kq-luchge(kp)
93  pms=pms-ulmass(kp)
94  ENDIF
95  150 CONTINUE
96  IF(kq.NE.0) merr=max(2,merr)
97  IF(kfdp(idc,2).NE.0.AND.(kc.LE.20.OR.kc.GT.40).AND.
98  & (kc.LE.80.OR.kc.GT.100).AND.mdme(idc,2).NE.34.AND.
99  & mdme(idc,2).NE.61.AND.pms.LT.0.) merr=max(1,merr)
100  IF(merr.EQ.3) CALL luerrm(17,
101  & '(LUUPDA:) Unknown particle code in decay of KC ='//chkc)
102  IF(merr.EQ.2) CALL luerrm(17,
103  & '(LUUPDA:) Charge not conserved in decay of KC ='//chkc)
104  IF(merr.EQ.1) CALL luerrm(7,
105  & '(LUUPDA:) Kinematically unallowed decay of KC ='//chkc)
106  brsum=brsum+brat(idc)
107  160 CONTINUE
108  WRITE(chtmp,1500) brsum
109  IF(abs(brsum).GT.0.0005.AND.abs(brsum-1.).GT.0.0005) CALL
110  & luerrm(7,'(LUUPDA:) Sum of branching ratios is '//chtmp(5:12)//
111  & ' for KC ='//chkc)
112  170 CONTINUE
113  mstj(24)=mstj24
114 
115 C...Initialize writing of DATA statements for inclusion in program.
116  ELSEIF(mupda.EQ.3) THEN
117  DO 240 ivar=1,19
118  ndim=mstu(6)
119  IF(ivar.GE.11.AND.ivar.LE.18) ndim=mstu(7)
120  nlin=1
121  chlin=' '
122  chlin(7:35)='DATA ('//chvar(ivar)//',I= 1, )/'
123  llin=35
124  chold='START'
125 
126 C...Loop through variables for conversion to characters.
127  DO 220 idim=1,ndim
128  IF(ivar.EQ.1) WRITE(chtmp,1400) kchg(idim,1)
129  IF(ivar.EQ.2) WRITE(chtmp,1400) kchg(idim,2)
130  IF(ivar.EQ.3) WRITE(chtmp,1400) kchg(idim,3)
131  IF(ivar.EQ.4) WRITE(chtmp,1500) pmas(idim,1)
132  IF(ivar.EQ.5) WRITE(chtmp,1500) pmas(idim,2)
133  IF(ivar.EQ.6) WRITE(chtmp,1500) pmas(idim,3)
134  IF(ivar.EQ.7) WRITE(chtmp,1500) pmas(idim,4)
135  IF(ivar.EQ.8) WRITE(chtmp,1400) mdcy(idim,1)
136  IF(ivar.EQ.9) WRITE(chtmp,1400) mdcy(idim,2)
137  IF(ivar.EQ.10) WRITE(chtmp,1400) mdcy(idim,3)
138  IF(ivar.EQ.11) WRITE(chtmp,1400) mdme(idim,1)
139  IF(ivar.EQ.12) WRITE(chtmp,1400) mdme(idim,2)
140  IF(ivar.EQ.13) WRITE(chtmp,1500) brat(idim)
141  IF(ivar.EQ.14) WRITE(chtmp,1400) kfdp(idim,1)
142  IF(ivar.EQ.15) WRITE(chtmp,1400) kfdp(idim,2)
143  IF(ivar.EQ.16) WRITE(chtmp,1400) kfdp(idim,3)
144  IF(ivar.EQ.17) WRITE(chtmp,1400) kfdp(idim,4)
145  IF(ivar.EQ.18) WRITE(chtmp,1400) kfdp(idim,5)
146  IF(ivar.EQ.19) chtmp=chaf(idim)
147 
148 C...Length of variable, trailing decimal zeros, quotation marks.
149  llow=1
150  lhig=1
151  DO 180 ll=1,12
152  IF(chtmp(13-ll:13-ll).NE.' ') llow=13-ll
153  180 IF(chtmp(ll:ll).NE.' ') lhig=ll
154  chnew=chtmp(llow:lhig)//' '
155  lnew=1+lhig-llow
156  IF((ivar.GE.4.AND.ivar.LE.7).OR.ivar.EQ.13) THEN
157  lnew=lnew+1
158  190 lnew=lnew-1
159  IF(chnew(lnew:lnew).EQ.'0') goto 190
160  IF(lnew.EQ.1) chnew(1:2)='0.'
161  IF(lnew.EQ.1) lnew=2
162  ELSEIF(ivar.EQ.19) THEN
163  DO 200 ll=lnew,1,-1
164  IF(chnew(ll:ll).EQ.'''') THEN
165  chtmp=chnew
166  chnew=chtmp(1:ll)//''''//chtmp(ll+1:11)
167  lnew=lnew+1
168  ENDIF
169  200 CONTINUE
170  chtmp=chnew
171  chnew(1:lnew+2)=''''//chtmp(1:lnew)//''''
172  lnew=lnew+2
173  ENDIF
174 
175 C...Form composite character string, often including repetition counter.
176  IF(chnew.NE.chold) THEN
177  nrpt=1
178  chold=chnew
179  chcom=chnew
180  lcom=lnew
181  ELSE
182  lrpt=lnew+1
183  IF(nrpt.GE.2) lrpt=lnew+3
184  IF(nrpt.GE.10) lrpt=lnew+4
185  IF(nrpt.GE.100) lrpt=lnew+5
186  IF(nrpt.GE.1000) lrpt=lnew+6
187  llin=llin-lrpt
188  nrpt=nrpt+1
189  WRITE(chtmp,1400) nrpt
190  lrpt=1
191  IF(nrpt.GE.10) lrpt=2
192  IF(nrpt.GE.100) lrpt=3
193  IF(nrpt.GE.1000) lrpt=4
194  chcom(1:lrpt+1+lnew)=chtmp(13-lrpt:12)//'*'//chnew(1:lnew)
195  lcom=lrpt+1+lnew
196  ENDIF
197 
198 C...Add characters to end of line, to new line (after storing old line),
199 C...or to new block of lines (after writing old block).
200  IF(llin+lcom.LE.70) THEN
201  chlin(llin+1:llin+lcom+1)=chcom(1:lcom)//','
202  llin=llin+lcom+1
203  ELSEIF(nlin.LE.19) THEN
204  chlin(llin+1:72)=' '
205  chblk(nlin)=chlin
206  nlin=nlin+1
207  chlin(6:6+lcom+1)='&'//chcom(1:lcom)//','
208  llin=6+lcom+1
209  ELSE
210  chlin(llin:72)='/'//' '
211  chblk(nlin)=chlin
212  WRITE(chtmp,1400) idim-nrpt
213  chblk(1)(30:33)=chtmp(9:12)
214  DO 210 ilin=1,nlin
215  210 WRITE(lfn,1600) chblk(ilin)
216  nlin=1
217  chlin=' '
218  chlin(7:35+lcom+1)='DATA ('//chvar(ivar)//',I= , )/'//
219  & chcom(1:lcom)//','
220  WRITE(chtmp,1400) idim-nrpt+1
221  chlin(25:28)=chtmp(9:12)
222  llin=35+lcom+1
223  ENDIF
224  220 CONTINUE
225 
226 C...Write final block of lines.
227  chlin(llin:72)='/'//' '
228  chblk(nlin)=chlin
229  WRITE(chtmp,1400) ndim
230  chblk(1)(30:33)=chtmp(9:12)
231  DO 230 ilin=1,nlin
232  230 WRITE(lfn,1600) chblk(ilin)
233  240 CONTINUE
234  ENDIF
235 
236 C...Formats for reading and writing particle data.
237  1000 FORMAT(1x,i4,2x,a8,3i3,3f12.5,2x,f12.5,i3)
238  1100 FORMAT(5x,2i5,f12.5,5i8)
239  1200 FORMAT(a80)
240  1300 FORMAT(i4)
241  1400 FORMAT(i12)
242  1500 FORMAT(f12.5)
243  1600 FORMAT(a72)
244 
245  RETURN
246  END