Geant4.10
 All Data Structures Namespaces Files Functions Variables Typedefs Enumerations Enumerator Friends Macros Groups Pages
dpm25hadri.f
Go to the documentation of this file.
1 *-- Author :
2 C
3 C--------------------------------------------------------------------
4  SUBROUTINE fhad(IPRMOD,IPRO,PLAB,ELAB,CX,CY,CZ,
5  * ithkk,itta,ieline,irejfh)
6  IMPLICIT DOUBLE PRECISION (a-h,o-z)
7 C
8 C MODIFIED VERSION OF FERHAD / FROM FLUKA86.S (DESY)
9 C 01/02/90
10 C
11 C--------------------------------------------------
12 C*** COLLISION OF HADRON IPRO WITH NUCLEON ITHKK FROM /HKKEVT/
13 C (IPRO, ITTA - CONVENTIONAL PARTICLE NUMBERING FROM FLUKA)
14 C IPRO HAS LAB-ENERGY ELAB, MOMENTUM PLAB, DIRECTIONS CX,CY,CZ
15 C
16 C IELINI=0 INELASTIC HADRIN COLLISIONS
17 C IELINE=1 ELASTIC ELHAIN COLLISIONS
18 C IELINE= ... ...
19 C***
20 C*** ITHKK TAKES THE FERMI-MOMENTUM FROM /HKKEVT/
21 C
22 C*** CONSERVED IS THE ENERGY, THE MOMENTUM, ELECTRIC AND BARYON. CHARGE
23 C*** AND STRANGENESS
24 C--------------------------------------------------
25 *KEEP,HKKEVT.
26 c INCLUDE (HKKEVT)
27  parameter(nmxhkk= 89998)
28 c PARAMETER (NMXHKK=25000)
29  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
30  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
31  +(4,nmxhkk)
32 C
33 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
34 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
35 C THE POSITIONS OF THE PROJECTILE NUCLEONS
36 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
37 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
38 C COMPLETELY CONSISTENT. THE TIMES IN THE
39 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
40 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
41 C
42 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
43 C
44 C NMXHKK: maximum numbers of entries (partons/particles) that can be
45 C stored in the commonblock.
46 C
47 C NHKK: the actual number of entries stored in current event. These are
48 C found in the first NHKK positions of the respective arrays below.
49 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
50 C entry.
51 C
52 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
53 C = 0 : null entry.
54 C = 1 : an existing entry, which has not decayed or fragmented.
55 C This is the main class of entries which represents the
56 C "final state" given by the generator.
57 C = 2 : an entry which has decayed or fragmented and therefore
58 C is not appearing in the final state, but is retained for
59 C event history information.
60 C = 3 : a documentation line, defined separately from the event
61 C history. (incoming reacting
62 C particles, etc.)
63 C = 4 - 10 : undefined, but reserved for future standards.
64 C = 11 - 20 : at the disposal of each model builder for constructs
65 C specific to his program, but equivalent to a null line in the
66 C context of any other program. One example is the cone defining
67 C vector of HERWIG, another cluster or event axes of the JETSET
68 C analysis routines.
69 C = 21 - : at the disposal of users, in particular for event tracking
70 C in the detector.
71 C
72 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
73 C standard.
74 C
75 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
76 C The value is 0 for initial entries.
77 C
78 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
79 C one mother exist, in which case the value 0 is used. In cluster
80 C fragmentation models, the two mothers would correspond to the q
81 C and qbar which join to form a cluster. In string fragmentation,
82 C the two mothers of a particle produced in the fragmentation would
83 C be the two endpoints of the string (with the range in between
84 C implied).
85 C
86 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
87 C entry has not decayed, this is 0.
88 C
89 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
90 C entry has not decayed, this is 0. It is assumed that the daughters
91 C of a particle (or cluster or string) are stored sequentially, so
92 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
93 C daughters. Even in cases where only one daughter is defined (e.g.
94 C K0 -> K0S) both values should be defined, to make for a uniform
95 C approach in terms of loop constructions.
96 C
97 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
98 C
99 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
100 C
101 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
102 C
103 C PHKK(4,IHKK) : energy, in GeV.
104 C
105 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
106 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
107 C
108 C VHKK(1,IHKK) : production vertex x position, in mm.
109 C
110 C VHKK(2,IHKK) : production vertex y position, in mm.
111 C
112 C VHKK(3,IHKK) : production vertex z position, in mm.
113 C
114 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
115 C********************************************************************
116 *KEEP,HADTHR.
117  COMMON /hadthr/ ehadth,inthad
118 *KEEP,DFINLS.
119  parameter(maxfin=10)
120  COMMON /dfinls/ itrh(maxfin),cxrh(maxfin),cyrh(maxfin), czrh
121  +(maxfin),elrh(maxfin),plrh(maxfin),irh
122 *KEEP,DPAR.
123 C /DPAR/ CONTAINS PARTICLE PROPERTIES
124 C ANAME = LITERAL NAME OF THE PARTICLE
125 C AAM = PARTICLE MASS IN GEV
126 C GA = DECAY WIDTH
127 C TAU = LIFE TIME OF INSTABLE PARTICLES
128 C IICH = ELECTRIC CHARGE OF THE PARTICLE
129 C IIBAR = BARYON NUMBER
130 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
131 C
132  CHARACTER*8 aname
133  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
134  +iibar(210),k1(210),k2(210)
135 C------------------
136 *KEEP,PROJK.
137  COMMON /projk/ iprojk
138 *KEEP,DPRIN.
139  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
140 *KEND.
141  zero=0
142  irejfh=0
143 C---------------------------------------------------------------
144 C TEST OPTION: FORCE TYPE OF INTERACTION IF DESIRED
145  IF(inthad.EQ.1) THEN
146  iielin=0
147  ELSEIF(inthad.EQ.2) THEN
148  iielin=1
149  ELSE
150  iielin=ieline
151  ENDIF
152 C--------------------------------------------------
153 C*** COLLISION KINEMATICS
154 C*** LORENTZ-TRANSFORMATION INTO TARGET-NUCLEON-REST-SYSTEM
155 C--------------------------------------------------
156  amtar=phkk(5,ithkk)
157 C RECALCULATE MOMENTA FOR KINEMATICAL
158 C CONSISTENCY OF LORENTZ-TRANSFORMATION
159  pptar=sqrt(phkk(1,ithkk)**2 + phkk(2,ithkk)**2 + phkk(3,ithkk)**2)
160  pptarm=sqrt(abs(phkk(4,ithkk)-amtar)*(phkk(4,ithkk)+amtar))
161 C
162  bgx=phkk(1,ithkk)/amtar
163  bgy=phkk(2,ithkk)/amtar
164  bgz=phkk(3,ithkk)/amtar
165  IF(pptar.GT.zero) THEN
166  bgx=bgx*pptarm/pptar
167  bgy=bgy*pptarm/pptar
168  bgz=bgz*pptarm/pptar
169  ENDIF
170 C
171  pplab=plab
172  gam=phkk(4,ithkk)/amtar
173  pxpro=cx*pplab
174  pypro=cy*pplab
175  pzpro=cz*pplab
176 C
177  etes = elab + phkk(4,ithkk)
178  pxtes= pxpro + phkk(1,ithkk)
179  pytes= pypro + phkk(2,ithkk)
180  pztes= pzpro + phkk(3,ithkk)
181 C
182  CALL daltra(gam,-bgx,-bgy,-bgz, pxpro,pypro,pzpro,elab, pprof,
183  +pxprof,pyprof,pzprof,eprof)
184  IF(ipev.GT.3) THEN
185  WRITE(6,'(2A/A,4E12.5/A,5E12.5/A,4E12.5/A,4E12.5/A,4I4)')
186  & ' FHAD: projectile after LT into target',
187  & ' nucleon rest system',
188  & ' GAM,BGX,BGY,BGZ ', gam,bgx,bgy,bgz,
189  & ' PHKK(target):', (phkk(ik,ithkk),ik=1,5),
190  & ' PX/Y/Z/PRO, ELAB:', pxpro,pypro,pzpro,elab,
191  & ' Proj. after LT:', pxprof,pyprof,pzprof,eprof,
192  & ' IPRO, ITTA, ITHKK, IELINE:', ipro,itta,ithkk,ieline
193  ENDIF
194  IF(eprof.LE.aam(ipro)) THEN
195  WRITE(6,'(2A/A,5E12.5/A,4E12.5/A,4E12.5/A,4I4)')
196  & ' FHAD: inconsistent projectile after LT into target',
197  & ' nucleon rest system',
198  & ' PHKK(target):', (phkk(ik,ithkk),ik=1,5),
199  & ' PX/Y/Z/PRO, ELAB:', pxpro,pypro,pzpro,elab,
200  & ' Proj. after LT:', pxprof,pyprof,pzprof,eprof,
201  & ' IPRO, ITTA, ITHKK, IELINE:', ipro,itta,ithkk,ieline
202  irejfh=1
203  RETURN
204  ENDIF
205 C CONSISTENCY TEST OF LOR. TRSF.
206 C INTO TARGET REST SYSTEM
207  IF(ipaupr.GT.5) THEN
208  CALL daltra(gam,-bgx,-bgy,-bgz, phkk(1,ithkk),phkk(2,ithkk),phkk
209  + (3,ithkk),phkk(4,ithkk), pptar,pxtarf,pytarf,pztarf,etarf)
210 
211  WRITE(6,'(A)') 'FHAD: TARGET MOM. BEFORE/AFTER LORENTZ TRANSF.'
212  WRITE(6,'(3X,A,5(1PE12.4))') ' PHKK(1-4,ITHKK)', (phkk
213  + (jj,ithkk),jj=1,4)
214  WRITE(6,'(3X,A,5(1PE12.4))') ' PXTARF,PYTARF,PZTARF,ETARF',
215  + pxtarf,pytarf,pztarf,etarf
216  WRITE(6,'(A)') 'FHAD: PROJ. MOM. BEFORE/AFTER LORENTZ TRANSF.'
217  WRITE(6,'(3X,A,5(1PE12.4))') ' PXPRO,PYPRO,PZPRO,ELAB', pxpro,
218  + pypro,pzpro,elab
219  WRITE(6,'(3X,A,5(1PE12.4))') ' PXPROF,PYPROF,PZPROF,EPROF',
220  + pxprof,pyprof,pzprof,eprof
221  ENDIF
222 C
223 C--------------------------------------------------
224 C*** FOR PARTICLES OF THE H-N-COLLISION, STORE THE KINEM.VARIABLES IN
225 C*** COMMON /FINLSP/
226 C--------------------------------------------------
227  cxf=pxprof/pprof
228  cyf=pyprof/pprof
229  czf=pzprof/pprof
230  irej=0
231  IF (iielin.EQ.0)THEN
232  CALL dhadri(ipro,pprof,eprof,cxf,cyf,czf,itta)
233  IF(irh.EQ.1) irej=1
234  IF (ipaupr.GT.2)WRITE(6,1000)ipro,pprof,eprof,cxf,cyf,czf,itta
235  1000 FORMAT (' FHAD IPRO,PPROF,EPROF,CXF,CYF,CZF,ITTA',i5,5f10.2,i5)
236  ELSEIF(iielin.EQ.1) THEN
237  CALL elhain(ipro,pprof,eprof,cxf,cyf,czf,itta,irej)
238  ENDIF
239  IF(irej.EQ.1) THEN
240 C RETURN ORIGINAL MOMENTA (SEE ELHAIN)
241  irh=2
242  itrh(1)=ipro
243  cxrh(1)=cx
244  cyrh(1)=cy
245  czrh(1)=cz
246  elrh(1)=elab
247  plrh(1)=plab
248  itrh(2)=itta
249  cxrh(2)=phkk(1,ithkk)/pptar
250  cyrh(2)=phkk(2,ithkk)/pptar
251  czrh(2)=phkk(3,ithkk)/pptar
252  elrh(2)=phkk(4,ithkk)
253  plrh(2)=pptar
254  RETURN
255  ENDIF
256 C
257 C--------------------------------------------------
258 C*** LORENTZ-TRANSFORM FROM TRS INTO LS
259 C--------------------------------------------------
260  DO 10 iii=1,irh
261  crsum=cxrh(iii)**2 + cyrh(iii)**2 + czrh(iii)**2
262  IF(abs(crsum-1.0).GT.1e-4) THEN
263  WRITE(6,'(A,I3,1PE12.4)')
264  + ' FHAD: INCORRECT NORM. OF DIRECTION COSINES - III,CRSUM',
265  + iii,crsum
266  rcrsum=sqrt(crsum)
267  cxrh(iii)=cxrh(iii)/rcrsum
268  cyrh(iii)=cyrh(iii)/rcrsum
269  czrh(iii)=czrh(iii)/rcrsum
270  ENDIF
271  ami=aam(itrh(iii))
272 C? PPS=SQRT(ABS((ELRH(III)-AMI)*(ELRH(III)+AMI))+1.E-6)
273  pps=plrh(iii)
274  psx=cxrh(iii)*pps
275  psy=cyrh(iii)*pps
276  psz=czrh(iii)*pps
277  IF(ipaupr.GT.7) THEN
278  WRITE(6,'(A,I3,6(1PE12.4))')
279  + ' FHAD: ITRH(I), AMI,ELR,PPS,PSX,PSY,PSZ', itrh(iii),ami,elrh
280  + (iii),pps,psx,psy,psz
281  ENDIF
282  CALL daltra(gam,bgx,bgy,bgz, psx,psy,psz,elrh(iii), ppps,ppsx,
283  + ppsy,ppsz,elrh(iii))
284  IF(elrh(iii).LT.(ppps-1d-4)) THEN
285  WRITE(6,'(2A/3I3,6(1PE12.4))')
286  + ' FHAD: INCONSISTENT KINEMATICS AFTER ALTRA: ',
287  + ' IIELIN,III,ITRH(III),ELRH(III),PPPS,PSX,PSY,PSZ,AMI',iielin,
288  + iii,itrh(iii),elrh(iii),ppps,psx,psy,psz,ami
289  elrh(iii)=sqrt(ppps**2 + ami**2)
290  WRITE(6,'(A,1PE12.4)') ' CORRECTED ENERGY ELRH:',elrh(iii)
291  WRITE(6,'(2A/2I5,5(1PE12.4))')
292  + ' FHAD: 4-MOM. OF TARGET NUCLEON -',
293  + ' ITHKK, IDHKK , PHKK(1-4)', ithkk, idhkk(ithkk), (phkk
294  + (k,ithkk),k=1,5)
295  ENDIF
296  cxrh(iii)=ppsx/ppps
297  cyrh(iii)=ppsy/ppps
298  czrh(iii)=ppsz/ppps
299  plrh(iii)=ppps
300  etes = etes - elrh(iii)
301  pxtes= pxtes- ppsx
302  pytes= pytes- ppsy
303  pztes= pztes- ppsz
304  10 CONTINUE
305 C
306  IF(abs(etes).GT.0.001d0) THEN
307 C IF(ABS(ETES).GT.0.1041D0) THEN
308  IF(ipri.GE.1) THEN
309  WRITE(6,'(A,I5)') ' FHAD: TEST OF E-P CONSERVATION IELINE=',
310  + iielin
311  WRITE(6,'(3X,A,5(1PE12.4))') ' ETES,PXTES,PYTES,PZTES', etes,
312  + pxtes,pytes,pztes
313  WRITE(6,1000)ipro,pprof,eprof,cxf,cyf,czf,itta
314  ENDIF
315  DO 20 iii=1,irh
316  ami=aam(itrh(iii))
317  pps=sqrt((elrh(iii)-ami)*(elrh(iii)+ami))
318  psx=cxrh(iii)*pps
319  psy=cyrh(iii)*pps
320  psz=czrh(iii)*pps
321  IF(ipri.GE.1) THEN
322  WRITE(6,'(A,I3,6(1PE12.4))')
323  + ' FHAD: ITRH(I), AMI,ELRH,PPS,PSX,PSY,PSZ', itrh(iii),ami,
324  + elrh(iii),pps,psx,psy,psz
325  ENDIF
326  20 CONTINUE
327  ENDIF
328 C
329  RETURN
330  END
331 **sr 19-11-95: ELHAIN replaced
332 *
333 *===elhain=============================================================*
334 *
335  SUBROUTINE elhain(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
336 
337 ************************************************************************
338 * Elastic hadron-hadron scattering. *
339 * This is a revised version of the original. *
340 * This version dated 26.10.95 is written by S. Roesler *
341 ************************************************************************
342 
343  IMPLICIT DOUBLE PRECISION (a-h,o-z)
344  SAVE
345  parameter(lout=6,llook=9)
346  parameter(two=2.0d0,one=1.0d0,ohalf=0.5d0,zero=0.0d0,
347  & tiny10=1.0d-10)
348 
349  parameter(ennthr = 3.5d0)
350  parameter(plowh=0.01d0,phih=9.0d0,
351  & blowb=0.05d0,bhib=0.2d0,
352  & blowm=0.1d0, bhim=2.0d0)
353 
354  CHARACTER*8 aname
355  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),
356  & iich(210),iibar(210),k1(210),k2(210)
357 
358  parameter(maxfin=10)
359  COMMON /dfinls/ itrh(maxfin),cxrh(maxfin),cyrh(maxfin),
360  & czrh(maxfin),elrh(maxfin),plrh(maxfin),irh
361 
362 C DATA TSLOPE /10.0D0/
363 
364  irej = 0
365 
366  plab = sqrt( (elab-aam(ip))*(elab+aam(ip)) )
367  ekin = elab-aam(ip)
368 * kinematical quantities in cms of the hadrons
369  amp2 = aam(ip)**2
370  amt2 = aam(it)**2
371  s = amp2+amt2+two*elab*aam(it)
372  ecm = sqrt(s)
373  ecmp = ohalf*ecm+(amp2-amt2)/(two*ecm)
374  pcm = sqrt( (ecmp-aam(ip))*(ecmp+aam(ip)) )
375 
376 * nucleon-nucleon scattering at E_kin<3.5: use TSAMCS (HETC-KFA)
377  IF ( ((ip.EQ.1).OR.(ip.EQ.8)).AND.
378  & ((it.EQ.1).OR.(it.EQ.8)).AND.(ekin.LT.ennthr) ) THEN
379 * TSAMCS treats pp and np only, therefore change pn into np and
380 * nn into pp
381  IF (it.EQ.1) THEN
382  kproj = ip
383  ELSE
384  kproj = 8
385  IF (ip.EQ.8) kproj = 1
386  ENDIF
387  CALL tsamcs(kproj,ekin,ctcms)
388  t = two*pcm**2*(ctcms-one)
389 
390 * very crude treatment otherwise: sample t from exponential dist.
391  ELSE
392 * momentum transfer t
393  tmax = two*two*pcm**2
394  rr = (plab-plowh)/(phih-plowh)
395  IF (iibar(ip).NE.0) THEN
396  tslope = blowb+rr*(bhib-blowb)
397  ELSE
398  tslope = blowm+rr*(bhim-blowm)
399  ENDIF
400  fmax = exp(-tslope*tmax)-one
401  r = rndm(v)
402  t = log(one+r*fmax+tiny10)/tslope
403  IF (t.GT.zero) t = log(one+r*fmax)/tslope
404  ENDIF
405 
406 * target hadron in Lab after scattering
407  elrh(2) = (two*amt2-t)/(two*aam(it))
408  plrh(2) = sqrt( (elrh(2)-aam(it))*(elrh(2)+aam(it)) )
409 * projectile hadron in Lab after scattering
410  elrh(1) = elab+aam(it)-elrh(2)
411  plrh(1) = sqrt( (elrh(1)-aam(ip))*(elrh(1)+aam(ip)) )
412 * scattering angle of projectile in Lab
413  ctlabp = (t-two*amp2+two*elab*elrh(1))/(two*plab*plrh(1))
414  stlabp = sqrt( (one-ctlabp)*(one+ctlabp) )
415  CALL dsfecf(splabp,cplabp)
416 * direction cosines of projectile in Lab
417 **sr mod. for DPMJET: STTRAN-->DRTRAN
418  CALL drtran(cx,cy,cz,ctlabp,stlabp,splabp,cplabp,
419  & cxrh(1),cyrh(1),czrh(1))
420 * scattering angle of target in Lab
421  pllabt = plab-ctlabp*plrh(1)
422  ctlabt = pllabt/plrh(2)
423  stlabt = sqrt( (one-ctlabt)*(one+ctlabt) )
424 * direction cosines of target in Lab
425 **sr mod. for DPMJET: STTRAN-->DRTRAN
426  CALL drtran(cx,cy,cz,ctlabt,stlabt,-splabp,-cplabp,
427  & cxrh(2),cyrh(2),czrh(2))
428 * fill /DFINLS/
429  irh = 2
430  itrh(1) = ip
431  itrh(2) = it
432 
433  RETURN
434  END
435 
436 *-- Author :
437 C
438 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
439 C
440 C**************************************************
441 C
442 C ELASTIC CROSS SECTION SUBROUTINES FOR HKK89
443 C
444 C HJM 10/89
445 C
446 C******************************************************
447 C
448  SUBROUTINE sihnel(IPROJ,ITAR,POO,SIEL)
449  IMPLICIT DOUBLE PRECISION (a-h,o-z)
450 C********************************************************************
451 C VERSION BY HJM 10/89
452 C LAST CHANGES HJM 30/08/90
453 C - assignment for several particle types
454 C - low-energy parametrization for K+/-, PBAR - P
455 C
456 C USES SIGEL (NEEDS: SIHNIN, SHPTOT, SIHAEL)
457 C
458 C NOTE: TO BE RENEWED URGENTLY!!!!!!!!!!!!!!!!!!!!!!!!!!
459 C
460 C INPUT VARIABLES:
461 C IPROJ = INCIENT PARTICLE TYPE
462 C ITAR = TARGET NUCLEON TYPE
463 C POO = PARTICLE MOMENTUM IN GEV/C
464 C
465 C OUTPUT VARIABLES:
466 C SIEL = ELASTIC CROSS SECTION IN MB
467 C
468 C
469 C CONVENTION: ISOSPIN INVARIANCE FOR
470 C NUCLEON-NUCLEON CROSSS SECTIONS
471 C PI+/- NUCLEON
472 C K+/- NUCLEON
473 C TO USE THE IMPROVED LOW-ENERGY CROSS SECTIONS
474 C FROM SIHAEL
475 C********************************************************************
476 C
477  dimension sikpp(8),sikmp(8),siapp(8),p(8)
478  DATA p /0.3d0,0.4d0,0.5d0,0.6d0,0.8d0,1.d0,1.5d0,2.d0/
479  DATA sikpp / 12.0d0, 12.5d0, 13.0d0, 13.0d0, 12.7d0,
480  + 12.0d0, 10.2d0, 6.82d0/
481  DATA sikmp / 42.0d0, 33.0d0, 21.0d0, 16.0d0, 19.0d0,
482  + 22.0d0, 9.0d0, 7.5d0 /
483  DATA siapp / 73.0d0, 70.0d0, 62.0d0, 53.0d0, 48.0d0,
484  + 43.0d0, 38.0d0, 33.0d0/
485 C-----------------------------------------------------------------------
486  zero=0
487  oneone=1
488  aa=oneone
489  ppoo=poo
490  ippr=iproj
491 C
492  IF(itar.EQ.8) THEN
493  IF(iproj.EQ.13) THEN
494  ippr=14
495  ELSEIF(iproj.EQ.14) THEN
496  ippr=13
497  ELSEIF(iproj.EQ.1) THEN
498  ippr=8
499  ELSEIF(iproj.EQ.8) THEN
500  ippr=1
501  ELSEIF(iproj.EQ.15) THEN
502  ippr=16
503  ELSEIF(iproj.EQ.16) THEN
504  ippr=15
505  ELSEIF(iproj.EQ.24) THEN
506  ippr=25
507  ELSEIF(iproj.EQ.25) THEN
508  ippr=24
509  ENDIF
510  ENDIF
511 C
512  IF(ippr.EQ.9) THEN
513  ippr=2
514  ELSEIF(ippr.EQ.17) THEN
515  ippr=1
516  ELSEIF(ippr.EQ.18) THEN
517  ippr=2
518  ELSEIF(ippr.EQ.24) THEN
519  ippr=15
520  ELSEIF(ippr.EQ.25) THEN
521  ippr=16
522  ELSEIF(ippr.GE.20.AND.ippr.LE.22) THEN
523  ippr=1
524  ENDIF
525 C-----------------------------------------------------------------
526 C K+/-, PBAR - P
527 C Plab < 10 GeV/c
528  IF(ippr.EQ.15.OR.ippr.EQ.16.OR.ippr.EQ.2) THEN
529 C***
530  IF(ppoo.LE.2.0) THEN
531 C
532 C CALCULATE THE MOMENTUM INDEX K FOR INTERPOLATION
533 C
534  DO 10 jk=1,8
535  IF(ppoo.LE.p(jk)) THEN
536  k=jk
537  goto 20
538  ENDIF
539  10 CONTINUE
540  k=8
541  20 CONTINUE
542  kk=k-1
543  IF(k.EQ.1) kk=1
544 C*
545  IF(ippr.EQ.15) THEN
546 C K+ - P
547  s1=sikpp(kk)
548  s2=sikpp(k)
549  ELSEIF(ippr.EQ.16) THEN
550 C K- - P
551  s1=sikmp(kk)
552  s2=sikmp(k)
553  ELSEIF(ippr.EQ.2) THEN
554 C PBAR - P
555  s1=siapp(kk)
556  s2=siapp(k)
557  ELSE
558  WRITE(6,'(A)')
559  + ' LOGICAL ERROR IN SIHNEL - EXECUTION STOPPED'
560  stop
561  ENDIF
562  siel=s1 + (s2-s1)*(ppoo-p(kk))/(p(k)-p(kk)+1d-7)
563  RETURN
564 C***
565  ELSEIF(ppoo.LE.10.0d0) THEN
566  IF(ippr.EQ.15) THEN
567 C K+ - P
568  a1=5.84
569  a2=17.2
570  an=-3.06
571  a3=0.206
572  a4=-1.71
573  ELSEIF(ippr.EQ.16) THEN
574 C K- - P
575  a1=7.24
576  a2=46.0
577  an=-4.71
578  a3=0.279
579  a4=-2.35
580  ELSEIF(ippr.EQ.2) THEN
581 C PBAR - P
582  a1=10.6
583  a2=53.1
584  an=-1.19
585  a3=0.136
586  a4=-1.41
587  ENDIF
588 C
589  alp=log(ppoo)
590  siel=a1 + a2*ppoo**an + a3*alp**2 + a4*alp
591  RETURN
592 C***
593  ELSE
594  goto 30
595  ENDIF
596  ENDIF
597 C-----------------------------------------------------------------
598  30 CONTINUE
599  CALL dsige(ippr,aa,ppoo,siel,zlel)
600  RETURN
601  END
602 *-- Author :
603 C
604 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
605 C
606  SUBROUTINE dsige(IT,AA,POO,SEL,ZL)
607  IMPLICIT DOUBLE PRECISION (a-h,o-z)
608 C********************************************************************
609 C VERSION BY J. RANFT
610 C LEIPZIG
611 C LAST CHANGE 01. MAY 84 BY HJM
612 C LEIPZIG
613 C !! LAST CHANGE 30/08/90 HJM:
614 C !! NIZL replaced by SIHNIN, i.e. only useful
615 C !! for hadron-proton scattering in DTUNUC
616 C
617 C
618 C
619 C INPUT VARIABLES:
620 C IT = PARTICLE TYPE
621 C AA = ATOMIC WEIGHT OF THE NUCLEUS
622 C POO = PARTICLE MOMENTUM IN GEV/C
623 C
624 C OUTPUT VARIABLES:
625 C SI = ELASTIC CROSS SECTION IN MB
626 C ZL = INTERACTION LENGTH IN G/CM**2
627 C
628 C OTHER IMPORTANT VARIABLES:
629 C SIG = PROTON/NUCLEI CROSS SECTIONS
630 C SEG = PION/NUCLEI CROSS SECTIONS
631 C P = MOMENTUMS FOR WHICH THE CROSS SECTIONS ARE GIVEN IN
632 C SIG AND SEG
633 C A = NUCLEI FOR WHICH THE CROSS SECTIONS ARE GIVEN IN
634 C SIG AND SEG
635 C PLAB = MOMENTUMS FOR WHICH THE TOTAL CROSS SECTIONS ARE
636 C GIVEN IN SITO
637 C SITO = TOTAL HADRON NUCLEON CROSS SECTIONS FOR NUCLEONS,
638 C PIONS, KAONS AND ANTI-NUCLEONS.
639 C ALP = EXPONENT OF THE PARAMETRIZATION FOR ANTI-PROTONS,
640 C RANTI-NEUTRONS AND KAONS
641 C BET = MULTIPLIER OF PARAMETRIZATION FOR ANTI-PROTONS,
642 C ANTI-NEUTRONS AND KAONS
643 C
644 C NOTE1: PRESENTLY CROSS SECTIONS ARE ASSUMED TO BE CONSTANT
645 C ABOVE 10.0 GEV/C FOR ALL PARTICLES AND
646 C BELOW 0.3 GEV/C FOR NUCLEONS AND BELOW 0.13 GEV/C FOR PIONS
647 C
648 C NOTE2: FOR HADRONS OTHER THAN (1=PROTON,2=ANTI PROTON,8=
649 C NEUTRON,9=ANTI NEUTRON,13=POSITIVE PION,14=NEGATIVE PION,15=
650 C POSITIVE KAON,16=NEGATIVE KAON,24=NEUTRAL KAON,25=NEUTRAL ANTI
651 C KAON) SEE TABLE ITT TO SEE THE CORRESPONDANCE
652 C
653 C NOTE3: FOR LEPTONS AND PHOTONS PRACTICALLY ZERO CROSS SECTION
654 C IS RETURNED.
655 C
656 C********************************************************************
657 C
658 *KEEP,DPAR.
659 C /DPAR/ CONTAINS PARTICLE PROPERTIES
660 C ANAME = LITERAL NAME OF THE PARTICLE
661 C AAM = PARTICLE MASS IN GEV
662 C GA = DECAY WIDTH
663 C TAU = LIFE TIME OF INSTABLE PARTICLES
664 C IICH = ELECTRIC CHARGE OF THE PARTICLE
665 C IIBAR = BARYON NUMBER
666 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
667 C
668  CHARACTER*8 aname
669  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
670  +iibar(210),k1(210),k2(210)
671 C------------------
672 *KEND.
673 C--------------------------------------------------------------
674 C--------------------------------------------------------------------
675  dimension sig(13,9),seg(16,9),p(16),a(9),itt(39)
676  dimension plab(19),sito(19,4),alp(3),bet(3)
677  dimension rea(9,9),stot(9)
678  SAVE a, p, sig, seg, itt, sito, plab, alp, bet, stot, rea
679  DATA a/9.d0,12.d0,27.d0,47.9d0,55.9d0,63.5d0,112.4d0,
680  &207.2d0,238.1d0/
681  DATA p/.13d0,.19d0,.25d0,.3d0,.4d0,.5d0,.6d0,.8d0,1.d0,
682  &1.5d0,2.d0,3.d0,4.d0,5.d0,6.d0,10.d0/
683  DATA sig/ 485.d0,223.d0,112.d0,82.d0,66.d0,78.d0,96.d0,102.d0,
684  &100.d0,98.d0,95.d0,90.d0,79.d0,
685  (680.d0,348.d0,175.d0,103.d0,84.d0,87.d0,106.d0,112.d0,111.d0,
686  &108.d0,107.d0,105.d0,101.d0,
687  (1200.d0,738.d0,387.d0,196.d0,191.d0,200.d0,248.d0,264.d0,
688  &264.d0,257.d0,252.d0,247.d0,228.d0,
689  (1658.d0,1110.d0,635.d0,364.d0,332.d0,356.d0,404.d0,408.d0,
690  &407.d0,404.d0,398.d0,396.d0,384.d0,
691  (1730.d0,1270.d0,725.d0,400.d0,375.d0,412.d0,495.d0,505.d0,
692  &495.d0,492.d0,487.d0,485.d0,475.d0,
693  (1875.d0,1470.d0,835.d0,480.d0,450.d0,450.d0,535.d0,
694  &580.d0,555.d0,540.d0,535.d0,530.d0,
695  (525.d0,2040.d0,2160.d0,1335.d0,850.d0,740.d0,760.d0,880.d0,
696  &905.d0,860.d0,840.d0,820.d0,815.d0,800.d0,
697  (2340.d0,2980.d0,2270.d0,1450.d0,1230.d0,1230.d0,
698  &1380.d0,1420.d0,1410.d0,1380.d0,1360.d0,
699  (1350.d0,1320.d0,2680.d0,3220.d0,2530.d0,1630.d0,1420.d0,1450.d0,
700  &1570.d0,1600.d0,1590.d0,1575.d0,1560.d0,1550.d0,1540.d0/
701  DATA seg/24.d0,128.d0,249.d0,256.d0,202.d0,124.d0,73.d0,60.d0,
702  &64.d0,69.d0,62.d0,50.d0,44.d0,42.d0,42.d0,41.d0,21.d0,156.d0,
703  (273.d0,280.d0,220.d0,212.d0,94.d0,80.d0,82.d0,85.d0,80.d0,73.d0,
704  (69.d0,67.d0,66.d0,64.d0,56.d0,296.d0,560.d0,574.d0,467.d0,350.d0,
705  &235.d0,210.d0,210.d0,200.d0,190.d0,183.d0,176.d0,170.d0,165.d0,
706  (155.d0,100.d0,500.d0,895.d0,880.d0,690.d0,520.d0,378.d0,
707  (355.d0,384.d0,373.d0,352.d0,320.d0,300.d0,288.d0,280.d0,
708  &262.d0,75.d0,500.d0,965.d0,990.d0,775.d0,525.d0,410.d0,410.d0,
709  (433.d0,440.d0,425.d0,395.d0,374.d0,355.d0,340.d0,303.d0,125.d0,
710  (570.d0,1025.d0,1100.d0,825.d0,575.d0,418.d0,458.d0,500.d0,
711  &480.d0,460.d0,440.d0,422.d0,400.d0,384.d0,355.d0,300.d0,880.d0,
712  (1480.d0,1550.d0,1380.d0,940.d0,710.d0,720.d0,810.d0,760.d0,
713  (740.d0,700.d0,665.d0,645.d0,620.d0,570.d0,550.d0,1475.d0,
714  &2250.d0,2350.d0,1850.d0,1500.d0,
715  (1120.d0,1210.d0,1480.d0,1440.d0,1400.d0,1320.d0,
716  &1250.d0,1210.d0,1170.d0,1065.d0,540.d0,
717  (1300.d0,2220.d0,2560.d0,1980.d0,1650.d0,1160.d0,
718  &1360.d0,1600.d0,1560.d0,1510.d0,1410.d0,
719  (1350.d0,1300.d0,1270.d0,1200.d0/
720 C DATA ITT/1,7,0,0,0,0,0,2,8,0,0,9,3,4,6,5,1,2,9,1,1,1,3,9,10,
721  DATA itt/1,7,0,0,0,0,0,2,8,0,0,9,3,4,6,5,2,8,9,1,1,2,3,9,10,
722  & 3,0,0,0,0,7,2,7,2,8,1,7,1,7/
723  DATA plab/.3d0,.4d0,.5d0,.6d0,.7d0,.8d0,.9d0,1.d0,1.1d0,
724  &1.2d0,1.3d0,1.4d0,1.5d0,2.d0,3.d0,4.d0,
725  *5.d0,6.d0,10.d0/
726  DATA sito/66.8d0,63.6d0,40.35d0,31.25d0,31.1d0,
727  *35.1d0,36.7d0,44.15d0,38.3d0,33.25d0,
728  *29.75d0,29.3d0,29.95d0,26.55d0,24.6d0,22.95d0,
729  *22.75d0,22.95d0,21.55d0,
730  *12.5d0,14.1d0,13.5d0,12.75d0,12.85d0,13.9d0,15.6d0,
731  *17.25d0,18.9d0,19.5d0,18.95d0,18.85d0,
732  *18.45d0,18.2d0,17.5d0,17.7d0,17.5d0,17.25d0,17.4d0,
733  *39.65d0,38.75d0,26.9d0,22.d0,22.d0,24.5d0,26.15d0,30.7d0,28.6d0,
734  &26.4d0,24.35d0,24.1d0,24.2d0
735  (,22.4d0,21.05d0,20.3d0,20.1d0,20.1d0,19.5d0,
736  (280.d0,199.7d0,171.1d0,154.3d0,140.d0,130.d0,116.8d0,117.4d0,
737  &111.6d0,109.d0,106.5d0,
738  (102.8d0,100.d0,90.2d0,76.7d0,68.d0,62.8d0,60.7d0,56.d0/
739  DATA alp/0.823d0,0.843d0,0.630d0/
740  DATA bet/1.26d0,1.31d0,0.90d0/
741  DATA stot /15.d0,20.d0,30.d0,40.d0,60.d0,80.d0,
742  &100.d0,150.d0,200.d0/
743  DATA rea / .20d0,.23d0,.27d0,.30d0,.35d0,.40d0,.47d0,.55d0,.60d0,
744  2 .22d0,.26d0,.31d0,.35d0,.40d0,.45d0,.51d0,.59d0,.63d0,
745  3 .24d0,.29d0,.36d0,.42d0,.50d0,.56d0,.60d0,.66d0,.68d0,
746  4 .26d0,.32d0,.42d0,.49d0,.58d0,.63d0,.66d0,.71d0,.72d0,
747  5 .27d0,.33d0,.44d0,.51d0,.61d0,.65d0,.68d0,.72d0,.74d0,
748  6 .28d0,.35d0,.46d0,.53d0,.63d0,.66d0,.69d0,.73d0,.745d0,
749  7 .35d0,.42d0,.53d0,.62d0,.69d0,.72d0,.74d0,.77d0,.78d0,
750  8 .42d0,.51d0,.62d0,.69d0,.75d0,.77d0,.79d0,.81d0,.82d0,
751  9 .44d0,.53d0,.64d0,.70d0,.76d0,.78d0,.80d0,.81d0,.82d0 /
752 C
753 C
754 C
755 C-------------------------------------------------------------
756  sel=1.0d-20
757  zl=1.0d+20
758  IF(aa.LT.0.99)RETURN
759  ipol=0
760  po=poo
761  iit=itt(it)
762  IF(it.GT.25)iit=0
763  IF(iit.EQ.0)RETURN
764 C---------------------------------------------------------
765 C** ELASTIC SCATTERING ON PROTONS
766 C HJM 10/88 REASONABLE FOR P, N, PI+/-
767 C**
768  ipr=it
769  IF(it.EQ.23) ipr=13
770  IF((aa.LT.1.5).AND. (ipr.EQ.1.OR.ipr.EQ.8.OR.ipr.EQ.13.OR.ipr.EQ.
771  +14)) THEN
772  eke=sqrt(po**2+aam(ipr)**2) - aam(ipr)
773  CALL dsihae(ipr,eke,po,aa,sel)
774  goto 220
775  ENDIF
776 C**
777 C NEUTRON-NUCLEUS ELASTIC SCATTERING
778 C DATA FROM HETKFA2 FOR EKIN .GT. 15 MEV
779 C FOR PLOTS SEE
780 C P. CLOTH ET AL.,
781 C HERMES - A MC PROGRAM SYSTEM ...
782 C JUEL-2203 (MAY 1988)
783 C
784  IF(it.EQ.8.AND.po.LT.20.0d0) THEN
785  IF(po.GT.10) THEN
786  ipol=1
787  po=10.0
788  ENDIF
789  eke=sqrt(po**2+aam(it)**2) - aam(it)
790  CALL dsihae(it,eke,po,aa,sel)
791  IF(ipol.EQ.1) goto 240
792  goto 220
793  ENDIF
794 C-----------------------------------------------------------
795 C
796 C
797 C********************************************************************
798 C CALCULATE THE NEW PARTICLE NUMBER IIT: 1=P,2=N,3=PI+,4=PI-,
799 C 5=K-,6=K+,7=P BAR,8=N BAR,9=K ZERO ,10=K ZERO BAR
800 C********************************************************************
801 C
802  IF((iit.EQ.7).OR.(iit.EQ.8)) goto 250
803  IF (po.GT.20.d0) goto 250
804  IF(po.LE.10.d0) goto 10
805  po=10.
806  ipol=1
807  10 CONTINUE
808  IF(iit.LE.4) go to 40
809 C
810 C********************************************************************
811 C MOMENTUM INDEX K FOR KAONS ANTI KAONS AND ANTI NUCLEONS
812 C********************************************************************
813 C
814  DO 20 k=1,19
815  IF(po.LE.plab(k)) go to 30
816  20 CONTINUE
817  k=19
818  30 go to 90
819 C
820 C********************************************************************
821 C CALCULATE THE MOMENTUM INDEX K FOR NUCLEONS AND PIONS
822 C CALCULATE THE MASS INDEX J OF THE NUCLEUS
823 C********************************************************************
824 C
825  40 CONTINUE
826  DO 50 k=1,16
827  IF(po.LE.p(k)) go to 60
828  50 CONTINUE
829  k=16
830  60 CONTINUE
831  DO 80 i=2,8
832  IF(aa.LE.a(i)) go to 70
833  go to 80
834  70 CONTINUE
835  j=i-1
836  go to 90
837  80 CONTINUE
838  j=8
839 C
840 C********************************************************************
841 C SELECT THE FORMULEI TO BE USED FOR DIFFERENT PARTICLE TYPES
842 C********************************************************************
843 C
844  90 CONTINUE
845 C P , N ,PI+,PI-,K- ,K+ ,AP ,AN ,K0 ,AK0
846  go to(100,100,110,110,120,130,140,150,130,120),iit
847 C******************** PROTONS,NEUTRONS,OTHERS
848  100 k=k-3
849  IF(k.LT.1) k=1
850  aloga=log(a(j+1)/a(j))
851  aaa=aa/a(j)
852  si1=sig(k,j)* aaa **(log(sig(k,j+1)/sig(k,j))/aloga)
853  IF(k.EQ.1) go to 230
854  kk=k-1
855  si2=sig(kk,j)* aaa **(log(sig(kk,j+1)/sig(kk,j))/aloga)
856  k=k+3
857  kk=kk+3
858  si=si1+(po-p(k))*(si2-si1)/(p(kk)-p(k))
859 C
860  sel=si
861 C
862  go to 210
863 C******************** CHARGED PIONS
864  110 CONTINUE
865  aloga=log(a(j+1)/a(j))
866  aaa=aa/a(j)
867  si1=seg(k,j)* aaa **(log(seg(k,j+1)/seg(k,j))/aloga)
868  IF(k.EQ.1) go to 230
869  kk=k-1
870  si2=seg(kk,j)* aaa **(log(seg(kk,j+1)/seg(kk,j))/aloga)
871  si=si1+(po-p(k))*(si2-si1)/(p(kk)-p(k))
872 C
873  sel=si
874 C
875  go to 210
876 C******************** K-,K ZERO BAR
877  120 CONTINUE
878  ia=1
879  is=1
880  go to 160
881 C******************** K+, K ZERO
882  130 CONTINUE
883  ia=2
884  is=2
885  go to 160
886 C******************** P BAR
887  140 CONTINUE
888 C******************** N BAR
889  150 CONTINUE
890 C
891  po=poo
892  goto 250
893 C
894 C
895 C********************************************************************
896 C KAONS, ANTI KAONS
897 C********************************************************************
898 C
899  160 kk=k-1
900  IF(k.EQ.1) go to 170
901  pkk=plab(kk)
902  sikk=sito(kk,is)
903  si=(sito(k,is)-sikk)*(po-pkk)/(plab(k)-pkk)+sikk
904  go to 180
905  170 si=sito(k,is)
906  180 si1=si
907  si=bet(ia)*si*aa**alp(ia)
908  iv=it
909  IF(iv.NE.24) go to 190
910  iv=15
911  si=si*2.06
912  go to 200
913  190 IF(iv.EQ.25) iv=16
914 C*** 151 CALL NIZL(IV,AA,PO,SINEL,ZLIN) *** 30/08/90
915  200 CALL sihnin(iv,1,po,sinel)
916 C
917  sel=si-sinel
918  IF(ipol.EQ.1) goto 240
919  goto 210
920 C
921 C********************************************************************
922 C AND NOW THE SCATTERING LENGTH IN G/CM**2
923 C********************************************************************
924 C
925  210 CONTINUE
926  IF(ipol.EQ.1) goto 240
927  220 CONTINUE
928 C
929  IF(sel.LT.1.d-15) sel=1.d-15
930  zl=10000.d0*aa/(6.022*sel)
931  RETURN
932 C
933 C********************************************************************
934 C WE ARE IN THE LOWEST MOMENTUM BIN
935 C********************************************************************
936 C
937  230 si=si1
938  sel=si
939  go to 210
940 C***
941 C ENTRY FOR SMOOTHING OF SIGEL BETWEEN 10. AND 20. GEV/C
942 C***
943  240 CONTINUE
944  po=20.
945 C***
946 C APPROXIMATION FOR HIGH ENERGIES
947 C***
948  250 CONTINUE
949 C
950  it1=it
951  IF((it.EQ.2).OR.(it.EQ.9)) it1=1
952 C
953  sto=dshpto(it1,po)
954 C
955 C MASS NUMBER INDEX
956 C***
957  DO 260 ia=2,8
958  IF(aa.GT.a(ia)) goto 260
959  ja=ia-1
960  goto 270
961  260 CONTINUE
962  ja=8
963  270 CONTINUE
964 C***
965 C SIGTOT INDEX
966 C***
967  DO 280 is=2,8
968  IF(sto.GT.stot(is)) goto 280
969  js=is-1
970  goto 290
971  280 CONTINUE
972  js=8
973  290 CONTINUE
974 C
975  da1=a(ja+1)-a(ja)
976  da2=aa - a(ja)
977  rr=rea(js,ja)
978  r1=rr + da2*(rea(js,ja+1)-rr)/da1
979  rr=rea(js+1,ja)
980  r2=rr + da2*(rea(js+1,ja+1)-rr)/da1
981  ract=r1 + (sto-stot(js))*(r2-r1)/(stot(js+1)-stot(js))
982 C
983 C*** CALL NIZL(IT,AA,PO,SINEL1,ZLIN) *** 30/08/90
984  CALL sihnin(it,1,po,sinel1)
985  sel1=ract*sinel1
986  IF(ipol.EQ.1) goto 300
987  sel=sel1
988  goto 220
989 C
990  300 CONTINUE
991  sel=sel + (sel1-sel)*(poo-10.)/10.
992  goto 220
993 C
994 C
995 C********************************************************************
996 C FORMATS
997 C********************************************************************
998 C
999  1000 FORMAT(' WARNING AT CALL SIGEL ',i5)
1000  END
1001 *-- Author :
1002 C
1003 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1004 C
1005  SUBROUTINE dsihae(KPROJ,EKIN,PLAB,ANUC,SIGELA)
1006  IMPLICIT DOUBLE PRECISION (a-h,o-z)
1007 C***
1008 C HJM 22/10/88
1009 C HJM 29/08/90 :
1010 C correction of pi- proton data (Plab < 1.8 GeV/c)
1011 C
1012 C CROSS SECTIONS FOR ELASTIC SCATTERING
1013 C
1014 C INCLUDING - PION/NUCLEON PROTON DATA FROM BERTINI (HETKFA2)
1015 C
1016 C - ... HIGH-ENERGY APPROXIMATION:
1017 C SIGEL/SIGTOT = CONST
1018 C
1019 C - NUCLEON-NUCLEUS DATA FROM HETKFA2
1020 C***
1021 *KEEP,DPAR.
1022 C /DPAR/ CONTAINS PARTICLE PROPERTIES
1023 C ANAME = LITERAL NAME OF THE PARTICLE
1024 C AAM = PARTICLE MASS IN GEV
1025 C GA = DECAY WIDTH
1026 C TAU = LIFE TIME OF INSTABLE PARTICLES
1027 C IICH = ELECTRIC CHARGE OF THE PARTICLE
1028 C IIBAR = BARYON NUMBER
1029 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
1030 C
1031  CHARACTER*8 aname
1032  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
1033  +iibar(210),k1(210),k2(210)
1034 C------------------
1035 *KEND.
1036  parameter(nen=106)
1037  parameter(nea=23)
1038  parameter(nnaa=10)
1039  dimension ekihn(nen),ekiha(nea),amass(nnaa)
1040  dimension sepimp(nen),sepipp(nen),sepp(nen),senp(nen)
1041  dimension sena(nea,nnaa),sepa(nea,nnaa)
1042  dimension tsig(2)
1043  dimension relto(14)
1044 C*************************************************************8*
1045 * *
1046 *=== dblprc ==========================================================*
1047 * *
1048 *---------------------------------------------------------------------*
1049 * *
1050 * Dblprc: included in any routine *
1051 * *
1052 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
1053 * !!!! O N M A C H I N E S W H E R E T H E D O U B L E !!!! *
1054 * !!!! P R E C I S I O N I S N O T R E Q U I R E D R E -!!!! *
1055 * !!!! M O V E T H E D O U B L E P R E C I S I O N !!!! *
1056 * !!!! S T A T E M E N T, S E T K A L G N M = 1 A N D !!!! *
1057 * !!!! C H A N G E A L L N U M E R I C A L C O N S - !!!! *
1058 * !!!! T A N T S T O S I N G L E P R E C I S I O N !!!! *
1059 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
1060 * *
1061 * Kalgnm = real address alignment, 2 for double precision, *
1062 * 1 for single precision *
1063 * Anglgb = this parameter should be set equal to the machine *
1064 * "zero" with respect to unit *
1065 * Anglsq = this parameter should be set equal to the square *
1066 * of Anglgb *
1067 * Axcssv = this parameter should be set equal to the number *
1068 * for which unity is negligible for the machine *
1069 * accuracy *
1070 * Andrfl = "underflow" of the machine for floating point *
1071 * operation *
1072 * Avrflw = "overflow" of the machine for floating point *
1073 * operation *
1074 * Ainfnt = code "infinite" *
1075 * Azrzrz = code "zero" *
1076 * Einfnt = natural logarithm of the code "infinite" *
1077 * Ezrzrz = natural logarithm of the code "zero" *
1078 * Onemns = 1- of the machine, it is 1 - 2 x Anglgb *
1079 * Onepls = 1+ of the machine, it is 1 + 2 x Anglgb *
1080 * Csnnrm = maximum tolerable error on cosine normalization, *
1081 * u**2+v**2+w**2: assuming a typical anglgb relative *
1082 * error on each component we would get 2xanglgb: use *
1083 * 4xanglgb to avoid too many normalizations *
1084 * Dmxtrn = "infinite" distance for transport (cm) *
1085 * *
1086 *---------------------------------------------------------------------*
1087 * *
1088  parameter( kalgnm = 2 )
1089  parameter( anglgb = 5.0d-16 )
1090  parameter( anglsq = 2.5d-31 )
1091  parameter( axcssv = 0.2d+16 )
1092  parameter( andrfl = 1.0d-38 )
1093  parameter( avrflw = 1.0d+38 )
1094  parameter( ainfnt = 1.0d+30 )
1095  parameter( azrzrz = 1.0d-30 )
1096  parameter( einfnt = +69.07755278982137 d+00 )
1097  parameter( ezrzrz = -69.07755278982137 d+00 )
1098  parameter( onemns = 0.999999999999999 d+00 )
1099  parameter( onepls = 1.000000000000001 d+00 )
1100  parameter( csnnrm = 2.0d-15 )
1101  parameter( dmxtrn = 1.0d+08 )
1102 *
1103 *======================================================================*
1104 *======================================================================*
1105 *========= ==========*
1106 *========= M A T H E M A T I C A L C O N S T A N T S ==========*
1107 *========= ==========*
1108 *======================================================================*
1109 *======================================================================*
1110 * *
1111 * Numerical constants: *
1112 * *
1113 * Zerzer = 0 *
1114 * Oneone = 1 *
1115 * Twotwo = 2 *
1116 * Thrthr = 3 *
1117 * Foufou = 4 *
1118 * Fivfiv = 5 *
1119 * Sixsix = 6 *
1120 * Sevsev = 7 *
1121 * Eigeig = 8 *
1122 * Aninen = 9 *
1123 * Tenten = 10 *
1124 * Hlfhlf = 1/2 *
1125 * Onethi = 1/3 *
1126 * Twothi = 2/3 *
1127 * Pipipi = Circumference / diameter *
1128 * Eneper = "e", base of natural logarithm *
1129 * Sqrent = square root of "e" *
1130 * *
1131 *----------------------------------------------------------------------*
1132 *
1133  parameter( zerzer = 0.d+00 )
1134  parameter( oneone = 1.d+00 )
1135  parameter( twotwo = 2.d+00 )
1136  parameter( thrthr = 3.d+00 )
1137  parameter( foufou = 4.d+00 )
1138  parameter( fivfiv = 5.d+00 )
1139  parameter( sixsix = 6.d+00 )
1140  parameter( sevsev = 7.d+00 )
1141  parameter( eigeig = 8.d+00 )
1142  parameter( aninen = 9.d+00 )
1143  parameter( tenten = 10.d+00 )
1144  parameter( hlfhlf = 0.5d+00 )
1145  parameter( onethi = oneone / thrthr )
1146  parameter( twothi = twotwo / thrthr )
1147  parameter( pipipi = 3.1415926535897932270 d+00 )
1148  parameter( eneper = 2.7182818284590452354 d+00 )
1149  parameter( sqrent = 1.6487212707001281468 d+00 )
1150 *
1151 *======================================================================*
1152 *======================================================================*
1153 *========= ==========*
1154 *========= P H Y S I C A L C O N S T A N T S ==========*
1155 *========= ==========*
1156 *======================================================================*
1157 *======================================================================*
1158 * *
1159 * Primary constants: *
1160 * *
1161 * Clight = speed of light in cm s-1 *
1162 * Avogad = Avogadro number *
1163 * Amelgr = electron mass (g) *
1164 * Plckbr = reduced Planck constant (erg s) *
1165 * Elccgs = elementary charge (CGS unit) *
1166 * Elcmks = elementary charge (MKS unit) *
1167 * Amugrm = Atomic mass unit (g) *
1168 * Ammumu = Muon mass (amu) *
1169 * *
1170 * Derived constants: *
1171 * *
1172 * Alpfsc = Fine structure constant = e^2/(hbar c) *
1173 * Amelct = Electron mass (GeV) = 10^-16Amelgr Clight^2 / Elcmks*
1174 * Amugev = Atomic mass unit (GeV) = 10^-16Amelgr Clight^2 *
1175 * / Elcmks *
1176 * Ammuon = Muon mass (GeV) = Ammumu * Amugev *
1177 * Fscto2 = (Fine structure constant)^2 *
1178 * Fscto3 = (Fine structure constant)^3 *
1179 * Fscto4 = (Fine structure constant)^4 *
1180 * Plabrc = Reduced Planck constant times the light velocity *
1181 * expressed in GeV fm *
1182 * Rclsel = Classical electron radius (cm) = e^2 / (m_e c^2) *
1183 * Conversion constants: *
1184 * GeVMeV = from GeV to MeV *
1185 * eMVGeV = from MeV to GeV *
1186 * Raddeg = from radians to degrees *
1187 * Degrad = from degrees to radians *
1188 * *
1189 *----------------------------------------------------------------------*
1190 *
1191  parameter( clight = 2.99792458 d+10 )
1192  parameter( avogad = 6.0221367 d+23 )
1193  parameter( amelgr = 9.1093897 d-28 )
1194  parameter( plckbr = 1.05457266 d-27 )
1195  parameter( elccgs = 4.8032068 d-10 )
1196  parameter( elcmks = 1.60217733 d-19 )
1197  parameter( amugrm = 1.6605402 d-24 )
1198  parameter( ammumu = 0.113428913 d+00 )
1199 * PARAMETER ( ALPFSC = 1.D+00 / 137.035989561D+00 )
1200 * PARAMETER ( FSCTO2 = ALPFSC * ALPFSC )
1201 * PARAMETER ( FSCTO3 = FSCTO2 * ALPFSC )
1202 * PARAMETER ( FSCTO4 = FSCTO3 * ALPFSC )
1203 * It is important to set the electron mass exactly with the same
1204 * rounding as in the mass tables, so use the explicit expression
1205 * PARAMETER ( AMELCT = 1.D-16 * AMELGR * CLIGHT * CLIGHT / ELCMKS )
1206 * It is important to set the amu mass exactly with the same
1207 * rounding as in the mass tables, so use the explicit expression
1208 * PARAMETER ( AMUGEV = 1.D-16 * AMUGRM * CLIGHT * CLIGHT / ELCMKS )
1209 * It is important to set the muon mass exactly with the same
1210 * rounding as in the mass tables, so use the explicit expression
1211 * PARAMETER ( AMMUON = AMMUMU * AMUGEV ELCMKS )
1212 * PARAMETER ( RCLSEL = ELCCGS * ELCCGS / CLIGHT / CLIGHT / AMELGR )
1213  parameter( alpfsc = 7.2973530791728595 d-03 )
1214  parameter( fscto2 = 5.3251361962113614 d-05 )
1215  parameter( fscto3 = 3.8859399018437826 d-07 )
1216  parameter( fscto4 = 2.8357075508200407 d-09 )
1217  parameter( plabrc = 0.197327053 d+00 )
1218  parameter( amelct = 0.51099906 d-03 )
1219  parameter( amugev = 0.93149432 d+00 )
1220  parameter( ammuon = 0.105658389 d+00 )
1221  parameter( rclsel = 2.8179409183694872 d-13 )
1222  parameter( gevmev = 1.0 d+03 )
1223  parameter( emvgev = 1.0 d-03 )
1224  parameter( raddeg = 180.d+00 / pipipi )
1225  parameter( degrad = pipipi / 180.d+00 )
1226 
1227 *$ CREATE IOUNIT.ADD
1228 *COPY IOUNIT
1229 * *
1230 *=== iounit ==========================================================*
1231 * *
1232 *---------------------------------------------------------------------*
1233 * *
1234 * Iounit: included in any routine *
1235 * *
1236 * lunin = standard input unit *
1237 * lunout = standard output unit *
1238 * lunerr = standard error unit *
1239 * lunber = input file for bertini nuclear data *
1240 * lunech = echo file for pegs dat *
1241 * lunflu = input file for photoelectric edges and X-ray fluo- *
1242 * rescence data *
1243 * lungeo = scratch file for combinatorial geometry *
1244 * lunpgs = input file for pegs material data *
1245 * lunran = output file for the final random number seed *
1246 * lunxsc = input file for low energy neutron cross sections *
1247 * lunrdb = unit number for reading (extra) auxiliary external *
1248 * files to be closed just after reading *
1249 * *
1250 *---------------------------------------------------------------------*
1251 * *
1252  parameter( lunin = 5 )
1253  parameter( lunout = 6 )
1254  parameter( lunerr = 66 )
1255  parameter( lunber = 14 )
1256  parameter( lunech = 8 )
1257  parameter( lunflu = 86 )
1258  parameter( lungeo = 16 )
1259  parameter( lunpgs = 12 )
1260  parameter( lunran = 2 )
1261  parameter( lunxsc = 81 )
1262  parameter( lunrdb = 1 )
1263 
1264 *$ CREATE DIMPAR.ADD
1265 *COPY DIMPAR
1266 * *
1267 *=== dimpar ==========================================================*
1268 * *
1269 *---------------------------------------------------------------------*
1270 * *
1271 * DIMPAR: included in any routine *
1272 * *
1273 * Mxxrgn = maximum number of regions *
1274 * Mxxmdf = maximum number of media in Fluka *
1275 * Mxxmde = maximum number of media in Emf *
1276 * Mfstck = stack dimension in Fluka *
1277 * Mestck = stack dimension in Emf *
1278 * Nallwp = number of allowed particles *
1279 * Mpdpdx = number of particle types for which EM dE/dx pro- *
1280 * cesses (ion,pair,bremss) have to be computed *
1281 * Icomax = maximum number of materials for compounds (equal *
1282 * to the sum of the number of materials for every *
1283 * compound ) *
1284 * Nstbis = number of stable isotopes recorded in common iso- *
1285 * top *
1286 * Idmaxp = number of particles/resonances defined in common *
1287 * part *
1288 * *
1289 *---------------------------------------------------------------------*
1290 * *
1291  parameter( mxxrgn = 500 )
1292  parameter( mxxmdf = 56 )
1293  parameter( mxxmde = 50 )
1294  parameter( mfstck = 1000 )
1295  parameter( mestck = 100 )
1296  parameter( nallwp = 39 )
1297  parameter( mpdpdx = 8 )
1298  parameter( icomax = 180 )
1299  parameter( nstbis = 304 )
1300  parameter( idmaxp = 210 )
1301 
1302 
1303 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1304 *
1305  SAVE ekihn, ekiha, amass, sepimp, sepipp, sepp, senp, sena, sepa,
1306  & tsig , relto
1307 * Statement functions: A.Ferrari 28-4-93
1308  sigmlw(e) = 3.d+03 * pipipi
1309  & / ( 1.206d+03 * e + ( -1.86d+00
1310  & + 0.09415d+03 * e + 0.0001306d+06 * e**2
1311  & )**2 ) + 1.d+03 * pipipi / ( 1.206d+03 * e
1312  & + ( 0.4223d+00 + 0.13d+03 * e )**2 )
1313  sigmpn(betapr) = 34.10d+00 / betapr**2 - 82.2d+00 / betapr
1314  & + 82.2d+00
1315  sigmpp(betapr) = 10.63d+00 / betapr**2 - 29.92d+00 / betapr
1316  & + 42.9d+00
1317 C***
1318 C KINETIC ENERGIES FOR TABLE LOOK-UP
1319 
1320  DATA ekihn /
1321  & 0.00d0, 0.02d0, 0.04d0, 0.06d0, 0.08d0, 0.10d0, 0.12d0, 0.14d0,
1322  & 0.16d0, 0.18d0, 0.20d0, 0.22d0, 0.24d0, 0.26d0, 0.28d0, 0.30d0,
1323  & 0.32d0, 0.34d0, 0.36d0, 0.38d0, 0.40d0, 0.42d0, 0.44d0, 0.46d0,
1324  & 0.48d0, 0.50d0, 0.52d0, 0.54d0, 0.56d0, 0.58d0, 0.60d0, 0.62d0,
1325  & 0.64d0, 0.66d0, 0.68d0, 0.70d0, 0.72d0, 0.74d0, 0.76d0, 0.78d0,
1326  & 0.80d0, 0.82d0, 0.84d0, 0.86d0, 0.88d0, 0.90d0, 0.92d0, 0.94d0,
1327  & 0.96d0, 0.98d0, 1.00d0, 1.02d0, 1.04d0, 1.06d0, 1.08d0, 1.10d0,
1328  & 1.12d0, 1.14d0, 1.16d0, 1.18d0, 1.20d0, 1.22d0, 1.24d0, 1.26d0,
1329  & 1.28d0, 1.30d0, 1.32d0, 1.34d0, 1.36d0, 1.38d0, 1.40d0, 1.42d0,
1330  & 1.44d0, 1.46d0, 1.48d0, 1.50d0, 1.52d0, 1.54d0, 1.56d0, 1.58d0,
1331  & 1.60d0, 1.62d0, 1.64d0, 1.66d0, 1.68d0, 1.70d0, 1.72d0, 1.74d0,
1332  & 1.76d0, 1.78d0, 1.80d0, 1.82d0, 1.84d0, 1.86d0, 1.88d0, 1.90d0,
1333  & 1.92d0, 1.94d0, 1.96d0, 1.98d0, 2.00d0, 2.5d0, 3.0d0, 3.5d0,
1334  & 5.0d0, 10.0d0/
1335  DATA ekiha /
1336  & 0.015d0, 0.02d0, 0.025d0, 0.03d0, 0.04d0, 0.05d0, 0.06d0,
1337  & 0.08d0, 0.10d0, 0.125d0, 0.15d0, 0.175d0, 0.20d0, 0.225d0,
1338  & 0.25d0, 0.3d0, 0.4d0, 0.6d0, 1.0d0, 2.0d0, 5.0d0,
1339  & 10.0d0, 22.5d0/
1340  DATA amass /
1341  & 4.d0, 9.d0, 12.d0, 27.d0, 47.9d0, 55.9d0, 63.5d0, 112.4d0,
1342  & 207.2d0, 238.1d0/
1343 C-------------------------------------------------------------------
1344 C
1345 C*** PI(-)-P ELASTIC CROSS SECTION DATA
1346  DATA (sepimp(ie),ie=1,50) /
1347  * 1.250d+00, 1.500d+00, 1.750d+00, 2.450d+00, 3.800d+00,
1348  * 6.000d+00, 9.700d+00, 1.500d+01, 2.140d+01, 2.310d+01,
1349  * 2.295d+01, 2.070d+01, 1.795d+01, 1.550d+01, 1.360d+01,
1350  * 1.230d+01, 1.130d+01, 1.070d+01, 1.050d+01, 1.070d+01,
1351  * 1.120d+01, 1.175d+01, 1.235d+01, 1.300d+01, 1.400d+01,
1352  * 1.500d+01, 1.600d+01, 1.700d+01, 1.835d+01, 1.970d+01,
1353  * 2.050d+01, 1.915d+01, 1.770d+01, 1.650d+01, 1.570d+01,
1354  * 1.520d+01, 1.510d+01, 1.525d+01, 1.550d+01, 1.600d+01,
1355  * 1.685d+01, 1.800d+01, 2.000d+01, 2.230d+01, 2.475d+01,
1356  * 2.635d+01, 2.510d+01, 2.300d+01, 2.140d+01, 2.000d+01/
1357  DATA (sepimp(ie),ie=51,106) /
1358  * 1.870d+01, 1.750d+01, 1.670d+01, 1.585d+01, 1.505d+01,
1359  * 1.440d+01, 1.395d+01, 1.340d+01, 1.299d+01, 1.260d+01,
1360  * 1.215d+01, 1.175d+01, 1.140d+01, 1.099d+01, 1.060d+01,
1361  * 1.040d+01, 1.010d+01, 9.990d+00, 9.900d+00, 9.750d+00,
1362  * 9.600d+00, 9.550d+00, 9.450d+00, 9.350d+00, 9.250d+00,
1363  * 9.250d+00, 9.350d+00, 9.650d+00, 9.850d+00, 1.000d+01,
1364  * 1.015d+01, 1.030d+01, 1.060d+01, 1.080d+01, 1.095d+01,
1365  * 1.100d+01, 1.095d+01, 1.090d+01, 1.070d+01, 1.035d+01,
1366  * 1.000d+01, 9.600d+00, 9.050d+00, 8.550d+00, 8.200d+00,
1367  * 8.000d+00, 7.850d+00, 7.800d+00, 7.750d+00, 7.700d+00,
1368  * 7.650d+00,
1369  * 7.600d+00, 7.240d+00, 6.770d+00, 5.840d+00, 4.570d+00/
1370 * *** The previous 5 points have been substituted to the erroneous
1371 * *** ones from H.J. Mohring by A. Ferrari
1372 C---------------------------------------------------------------------
1373 C
1374 C*** PI(+)-P ELASTIC CROSS SECTION DATA
1375  DATA (sepipp(ie),ie=1,50) /
1376  * 1.800d+00, 4.000d+00, 9.900d+00, 2.170d+01, 4.000d+01,
1377  * 6.580d+01, 9.680d+01, 1.392d+02, 1.800d+02, 2.000d+02,
1378  * 1.655d+02, 1.420d+02, 1.225d+02, 1.032d+02, 8.400d+01,
1379  * 6.725d+01, 5.510d+01, 4.725d+01, 4.130d+01, 3.690d+01,
1380  * 3.230d+01, 2.885d+01, 2.600d+01, 2.300d+01, 2.090d+01,
1381  * 1.875d+01, 1.675d+01, 1.500d+01, 1.340d+01, 1.200d+01,
1382  * 1.100d+01, 9.980d+00, 9.200d+00, 8.600d+00, 8.200d+00,
1383  * 8.100d+00, 8.100d+00, 8.250d+00, 8.500d+00, 8.750d+00,
1384  * 9.000d+00, 9.400d+00, 9.750d+00, 1.000d+01, 1.030d+01,
1385  * 1.075d+01, 1.130d+01, 1.200d+01, 1.275d+01, 1.330d+01/
1386  DATA (sepipp(ie),ie=51,106) /
1387  * 1.350d+01, 1.335d+01, 1.330d+01, 1.330d+01, 1.345d+01,
1388  * 1.355d+01, 1.380d+01, 1.400d+01, 1.460d+01, 1.500d+01,
1389  * 1.555d+01, 1.625d+01, 1.700d+01, 1.800d+01, 1.875d+01,
1390  * 1.920d+01, 1.925d+01, 1.890d+01, 1.830d+01, 1.790d+01,
1391  * 1.725d+01, 1.690d+01, 1.640d+01, 1.600d+01, 1.550d+01,
1392  * 1.505d+01, 1.475d+01, 1.430d+01, 1.400d+01, 1.365d+01,
1393  * 1.335d+01, 1.300d+01, 1.280d+01, 1.250d+01, 1.225d+01,
1394  * 1.205d+01, 1.195d+01, 1.175d+01, 1.150d+01, 1.135d+01,
1395  * 1.105d+01, 1.095d+01, 1.080d+01, 1.060d+01, 1.030d+01,
1396  * 1.020d+01, 1.005d+01, 9.900d+00, 9.800d+00, 9.700d+00,
1397  * 9.600d+00,
1398  * 7.350d+00, 7.200d+00, 7.000d+00, 5.800d+00, 4.800d+00/
1399 C---------------------------------------------------------------------
1400 C
1401 C*** P-P ELASTIC CROSS SECTION DATA
1402  DATA (sepp(ie),ie=1,50) /
1403  * 6.750d+02, 1.550d+02, 6.750d+01, 4.420d+01, 3.230d+01,
1404  * 2.800d+01, 2.520d+01, 2.370d+01, 2.300d+01, 2.275d+01,
1405  * 2.260d+01, 2.260d+01, 2.260d+01, 2.260d+01, 2.270d+01,
1406  * 2.280d+01, 2.295d+01, 2.300d+01, 2.310d+01, 2.330d+01,
1407  * 2.350d+01, 2.380d+01, 2.395d+01, 2.420d+01, 2.460d+01,
1408  * 2.485d+01, 2.500d+01, 2.530d+01, 2.565d+01, 2.600d+01,
1409  * 2.620d+01, 2.640d+01, 2.660d+01, 2.675d+01, 2.690d+01,
1410  * 2.700d+01, 2.705d+01, 2.710d+01, 2.715d+01, 2.720d+01,
1411  * 2.725d+01, 2.725d+01, 2.720d+01, 2.715d+01, 2.710d+01,
1412  * 2.700d+01, 2.695d+01, 2.680d+01, 2.670d+01, 2.660d+01/
1413  DATA (sepp(ie),ie=51,106) /
1414  * 2.640d+01, 2.625d+01, 2.605d+01, 2.590d+01, 2.570d+01,
1415  * 2.545d+01, 2.525d+01, 2.500d+01, 2.480d+01, 2.470d+01,
1416  * 2.450d+01, 2.430d+01, 2.410d+01, 2.395d+01, 2.370d+01,
1417  * 2.360d+01, 2.340d+01, 2.325d+01, 2.305d+01, 2.290d+01,
1418  * 2.275d+01, 2.270d+01, 2.260d+01, 2.250d+01, 2.230d+01,
1419  * 2.225d+01, 2.210d+01, 2.200d+01, 2.195d+01, 2.190d+01,
1420  * 2.175d+01, 2.165d+01, 2.150d+01, 2.140d+01, 2.125d+01,
1421  * 2.120d+01, 2.105d+01, 2.100d+01, 2.090d+01, 2.075d+01,
1422  * 2.065d+01, 2.055d+01, 2.045d+01, 2.030d+01, 2.020d+01,
1423  * 2.005d+01, 2.000d+01, 1.995d+01, 1.980d+01, 1.975d+01,
1424  * 1.965d+01,
1425  * 17.15d+00, 14.45d+00, 13.00d+00, 11.50d+00, 10.50d+00/
1426 C--------------------------------------------------------------------
1427 C
1428 C*** N-P ELASTIC CROSS SECTION DATA
1429  DATA (senp(ie),ie=1,50) /
1430  * 1.965d+03, 4.750d+02, 2.200d+02, 1.300d+02, 9.180d+01,
1431  * 7.300d+01, 6.030d+01, 5.180d+01, 4.680d+01, 4.320d+01,
1432  * 4.080d+01, 3.910d+01, 3.760d+01, 3.650d+01, 3.550d+01,
1433  * 3.480d+01, 3.415d+01, 3.370d+01, 3.325d+01, 3.290d+01,
1434  * 3.275d+01, 3.250d+01, 3.255d+01, 3.275d+01, 3.285d+01,
1435  * 3.275d+01, 3.220d+01, 3.150d+01, 3.075d+01, 2.990d+01,
1436  * 2.875d+01, 2.775d+01, 2.695d+01, 2.630d+01, 2.590d+01,
1437  * 2.565d+01, 2.560d+01, 2.560d+01, 2.560d+01, 2.565d+01,
1438  * 2.570d+01, 2.575d+01, 2.578d+01, 2.580d+01, 2.585d+01,
1439  * 2.580d+01, 2.575d+01, 2.560d+01, 2.540d+01, 2.505d+01/
1440  DATA (senp(ie),ie=51,106) /
1441  * 2.470d+01, 2.425d+01, 2.375d+01, 2.315d+01, 2.275d+01,
1442  * 2.230d+01, 2.200d+01, 2.175d+01, 2.155d+01, 2.145d+01,
1443  * 2.130d+01, 2.125d+01, 2.115d+01, 2.105d+01, 2.100d+01,
1444  * 2.095d+01, 2.090d+01, 2.080d+01, 2.070d+01, 2.060d+01,
1445  * 2.050d+01, 2.045d+01, 2.040d+01, 2.030d+01, 2.025d+01,
1446  * 2.020d+01, 2.015d+01, 2.010d+01, 2.005d+01, 2.002d+01,
1447  * 2.000d+01, 1.999d+01, 1.990d+01, 1.985d+01, 1.975d+01,
1448  * 1.970d+01, 1.965d+01, 1.960d+01, 1.950d+01, 1.945d+01,
1449  * 1.940d+01, 1.925d+01, 1.920d+01, 1.915d+01, 1.910d+01,
1450  * 1.900d+01, 1.898d+01, 1.895d+01, 1.890d+01, 1.880d+01,
1451  * 1.875d+01,
1452  * 17.00d+00, 14.40d+00, 12.00d+00, 11.00d+00, 10.00d+00/
1453 C---------------------------------------------------------------------
1454 C
1455 C*** N-A ELASTIC CROSS SECTION DATA
1456 C* NEUTRON - HELIUM
1457  DATA (sena(ie,1),ie=1,nea) /
1458  * 5.103d-01, 5.157d-01, 5.103d-01, 4.777d-01, 4.072d-01,
1459  * 3.420d-01, 2.714d-01, 1.683d-01, 6.700d-02, 6.100d-02,
1460  * 5.800d-02, 4.900d-02, 3.800d-02, 3.300d-02, 3.000d-02,
1461  * 2.400d-02, 2.300d-02, 2.900d-02, 3.600d-02, 4.100d-02,
1462  * 4.000d-02, 3.700d-02, 3.400d-02/
1463 C
1464 C* NEUTRON - BERYLLIUM
1465  DATA (sena(ie,2),ie=1,nea) /
1466  * 8.762d-01, 8.856d-01, 8.762d-01, 8.203d-01, 6.991d-01,
1467  * 5.873d-01, 4.661d-01, 2.890d-01, 1.401d-01, 1.305d-01,
1468  * 1.238d-01, 1.069d-01, 8.495d-02, 7.480d-02, 6.750d-02,
1469  * 5.565d-02, 5.230d-02, 6.470d-02, 7.765d-02, 8.722d-02,
1470  * 8.440d-02, 7.821d-02, 7.259d-02/
1471 C
1472 C* NEUTRON - CARBON
1473  DATA (sena(ie,3),ie=1,nea) /
1474  * 9.200d-01, 9.500d-01, 9.400d-01, 8.800d-01, 7.500d-01,
1475  * 6.100d-01, 5.000d-01, 3.700d-01, 1.820d-01, 1.710d-01,
1476  * 1.620d-01, 1.410d-01, 1.130d-01, 1.000d-01, 9.000d-02,
1477  * 7.500d-02, 7.000d-02, 8.600d-02, 1.020d-01, 1.140d-01,
1478  * 1.100d-01, 1.020d-01, 9.500d-02/
1479 C
1480 C* NEUTRON - ALUMINUM
1481  DATA (sena(ie,4),ie=1,nea) /
1482  * 1.090d+00, 1.180d+00, 1.240d+00, 1.280d+00, 1.260d+00,
1483  * 1.160d+00, 9.300d-01, 6.300d-01, 3.580d-01, 3.450d-01,
1484  * 3.350d-01, 2.990d-01, 2.480d-01, 2.220d-01, 2.020d-01,
1485  * 1.730d-01, 1.610d-01, 1.920d-01, 2.200d-01, 2.420d-01,
1486  * 2.370d-01, 2.220d-01, 2.060d-01/
1487 C
1488 C* NEUTRON - TITANIUM
1489  DATA (sena(ie,5),ie=1,nea) /
1490  * 1.029d+00, 9.469d-01, 1.091d+00, 1.284d+00, 1.591d+00,
1491  * 1.691d+00, 1.258d+00, 9.241d-01, 5.620d-01, 5.493d-01,
1492  * 5.375d-01, 4.907d-01, 4.182d-01, 3.800d-01, 3.484d-01,
1493  * 3.038d-01, 2.823d-01, 3.307d-01, 3.720d-01, 4.040d-01,
1494  * 3.959d-01, 3.743d-01, 3.517d-01/
1495 C
1496 C* NEUTRON - IRON
1497  DATA (sena(ie,6),ie=1,nea) /
1498  * 1.178d+00, 9.793d-01, 1.090d+00, 1.271d+00, 1.650d+00,
1499  * 1.799d+00, 1.339d+00, 1.009d+00, 6.223d-01, 6.132d-01,
1500  * 6.042d-01, 5.572d-01, 4.812d-01, 4.402d-01, 4.053d-01,
1501  * 3.554d-01, 3.304d-01, 3.814d-01, 4.244d-01, 4.603d-01,
1502  * 4.523d-01, 4.293d-01, 4.053d-01/
1503 C
1504 C* NEUTRON - COPPER
1505  DATA (sena(ie,7),ie=1,nea) /
1506  * 1.386d+00, 1.050d+00, 1.134d+00, 1.302d+00, 1.722d+00,
1507  * 1.922d+00, 1.449d+00, 1.103d+00, 6.762d-01, 6.686d-01,
1508  * 6.602d-01, 6.131d-01, 5.344d-01, 4.912d-01, 4.541d-01,
1509  * 4.004d-01, 3.728d-01, 4.273d-01, 4.725d-01, 5.103d-01,
1510  * 5.022d-01, 4.781d-01, 4.524d-01/
1511 C
1512 C* NEUTRON - CADMIUM
1513  DATA (sena(ie,8),ie=1,nea) /
1514  * 2.029d+00, 1.537d+00, 1.660d+00, 1.906d+00, 2.520d+00,
1515  * 2.812d+00, 2.121d+00, 1.614d+00, 1.014d+00, 1.012d+00,
1516  * 1.006d+00, 9.557d-01, 8.607d-01, 8.038d-01, 7.541d-01,
1517  * 6.775d-01, 6.334d-01, 7.080d-01, 7.669d-01, 8.156d-01,
1518  * 8.074d-01, 7.769d-01, 7.404d-01/
1519 C
1520 C* NEUTRON - LEAD
1521  DATA (sena(ie,9),ie=1,nea) /
1522  * 3.050d+00, 2.310d+00, 2.495d+00, 2.865d+00, 3.789d+00,
1523  * 4.228d+00, 3.188d+00, 2.426d+00, 1.536d+00, 1.538d+00,
1524  * 1.536d+00, 1.488d+00, 1.384d+00, 1.317d+00, 1.256d+00,
1525  * 1.153d+00, 1.089d+00, 1.185d+00, 1.255d+00, 1.315d+00,
1526  * 1.307d+00, 1.269d+00, 1.224d+00/
1527 C
1528 C* NEUTRON - URANIUM
1529  DATA (sena(ie,10),ie=1,nea) /
1530  * 3.346d+00, 2.535d+00, 2.738d+00, 3.143d+00, 4.157d+00,
1531  * 4.639d+00, 3.498d+00, 2.662d+00, 1.685d+00, 1.687d+00,
1532  * 1.685d+00, 1.632d+00, 1.518d+00, 1.445d+00, 1.378d+00,
1533  * 1.265d+00, 1.194d+00, 1.300d+00, 1.377d+00, 1.443d+00,
1534  * 1.434d+00, 1.392d+00, 1.343d+00/
1535 C---------------------------------------------------------------------
1536 C p-A data changed by A.Ferrari: corresponding n-A data are used at
1537 C low energies since this is a much better approximation than
1538 C neglecting "tout court" the elastic scattering
1539 C*** P-A ELASTIC CROSS SECTION DATA
1540 C* PROTON - HELIUM
1541  DATA (sepa(ie,1),ie=1,nea) /
1542 * * 8*0.000D+00, 6.700D-02, 6.100D-02,
1543  * 5.103d-01, 5.157d-01, 5.103d-01, 4.777d-01, 4.072d-01,
1544  * 3.420d-01, 2.714d-01, 1.683d-01, 6.700d-02, 6.100d-02,
1545  * 5.800d-02, 4.900d-02, 3.800d-02, 3.300d-02, 3.000d-02,
1546  * 2.400d-02, 2.300d-02, 2.900d-02, 3.600d-02, 4.100d-02,
1547  * 4.000d-02, 3.700d-02, 3.400d-02/
1548 C
1549 C* PROTON - BERYLLIUM
1550  DATA (sepa(ie,2),ie=1,nea) /
1551 * * 8*0.000D+00, 1.401D-01, 1.305D-01,
1552  * 8.762d-01, 8.856d-01, 8.762d-01, 8.203d-01, 6.991d-01,
1553  * 5.873d-01, 4.661d-01, 2.890d-01, 1.401d-01, 1.305d-01,
1554  * 1.238d-01, 1.069d-01, 8.495d-02, 7.480d-02, 6.750d-02,
1555  * 5.565d-02, 5.230d-02, 6.470d-02, 7.765d-02, 8.722d-02,
1556  * 8.440d-02, 7.821d-02, 7.259d-02/
1557 C
1558 C* PROTON - CARBON
1559  DATA (sepa(ie,3),ie=1,nea) /
1560 * * 8*0.000D+00, 1.820D-01, 1.710D-01,
1561  * 9.200d-01, 9.500d-01, 9.400d-01, 8.800d-01, 7.500d-01,
1562  * 6.100d-01, 5.000d-01, 3.700d-01, 1.820d-01, 1.710d-01,
1563  * 1.620d-01, 1.410d-01, 1.130d-01, 1.000d-01, 9.000d-02,
1564  * 7.500d-02, 7.000d-02, 8.600d-02, 1.020d-01, 1.140d-01,
1565  * 1.100d-01, 1.020d-01, 9.500d-02/
1566 C
1567 C* PROTON - ALUMINUM
1568  DATA (sepa(ie,4),ie=1,nea) /
1569 * * 8*0.000D+00, 3.650D-01, 3.540D-01,
1570  * 1.090d+00, 1.180d+00, 1.240d+00, 1.280d+00, 1.260d+00,
1571  * 1.160d+00, 9.300d-01, 6.300d-01, 3.650d-01, 3.540d-01,
1572  * 3.420d-01, 3.060d-01, 2.530d-01, 2.260d-01, 2.040d-01,
1573  * 1.750d-01, 1.610d-01, 1.900d-01, 2.200d-01, 2.430d-01,
1574  * 2.370d-01, 2.220d-01, 2.070d-01/
1575 C
1576 C* PROTON - TITANIUM
1577  DATA (sepa(ie,5),ie=1,nea) /
1578 * * 8*0.000D+00, 5.828D-01, 5.726D-01,
1579  * 1.029d+00, 9.469d-01, 1.091d+00, 1.284d+00, 1.591d+00,
1580  * 1.691d+00, 1.258d+00, 9.241d-01, 5.828d-01, 5.726d-01,
1581  * 5.594d-01, 5.100d-01, 4.310d-01, 3.897d-01, 3.561d-01,
1582  * 3.084d-01, 2.829d-01, 3.262d-01, 3.714d-01, 4.066d-01,
1583  * 3.985d-01, 3.764d-01, 3.517d-01/
1584 C
1585 C* PROTON - IRON
1586  DATA (sepa(ie,6),ie=1,nea) /
1587 * * 8*0.000D+00, 6.383D-01, 6.313D-01,
1588  * 1.178d+00, 9.793d-01, 1.090d+00, 1.271d+00, 1.650d+00,
1589  * 1.799d+00, 1.339d+00, 1.009d+00, 6.383d-01, 6.313d-01,
1590  * 6.212d-01, 5.732d-01, 4.913d-01, 4.483d-01, 4.113d-01,
1591  * 3.594d-01, 3.304d-01, 3.764d-01, 4.243d-01, 4.623d-01,
1592  * 4.543d-01, 4.313d-01, 4.053d-01/
1593 C
1594 C* PROTON - COPPER
1595  DATA (sepa(ie,7),ie=1,nea) /
1596 * * 8*0.000D+00, 6.950D-01, 6.895D-01,
1597  * 1.386d+00, 1.050d+00, 1.134d+00, 1.302d+00, 1.722d+00,
1598  * 1.922d+00, 1.449d+00, 1.103d+00, 6.950d-01, 6.895d-01,
1599  * 6.803d-01, 6.322d-01, 5.471d-01, 5.014d-01, 4.619d-01,
1600  * 4.048d-01, 3.728d-01, 4.211d-01, 4.722d-01, 5.135d-01,
1601  * 5.051d-01, 4.804d-01, 4.527d-01/
1602 C
1603 C* PROTON - CADMIUM
1604  DATA (sepa(ie,8),ie=1,nea) /
1605 * * 8*0.000D+00, 1.045D+00, 1.043D+00,
1606  * 2.029d+00, 1.537d+00, 1.660d+00, 1.906d+00, 2.520d+00,
1607  * 2.812d+00, 2.121d+00, 1.614d+00, 1.045d+00, 1.043d+00,
1608  * 1.036d+00, 9.718d-01, 8.822d-01, 8.211d-01, 7.679d-01,
1609  * 6.828d-01, 6.325d-01, 6.951d-01, 7.647d-01, 8.232d-01,
1610  * 8.138d-01, 7.935d-01, 7.415d-01/
1611 C
1612 C* PROTON - LEAD
1613  DATA (sepa(ie,9),ie=1,nea) /
1614 * * 8*0.000D+00, 1.589D+00, 1.584D+00,
1615  * 3.050d+00, 2.310d+00, 2.495d+00, 2.865d+00, 3.789d+00,
1616  * 4.228d+00, 3.188d+00, 2.426d+00, 1.589d+00, 1.584d+00,
1617  * 1.577d+00, 1.528d+00, 1.417d+00, 1.345d+00, 1.277d+00,
1618  * 1.159d+00, 1.086d+00, 1.159d+00, 1.252d+00, 1.331d+00,
1619  * 1.320d+00, 1.278d+00, 1.256d+00/
1620 C
1621 C* PROTON - URANIUM
1622  DATA (sepa(ie,10),ie=1,nea) /
1623 * * 8*0.000D+00, 1.743D+00, 1.738D+00,
1624  * 3.346d+00, 2.535d+00, 2.738d+00, 3.143d+00, 4.157d+00,
1625  * 4.639d+00, 3.498d+00, 2.662d+00, 1.743d+00, 1.738d+00,
1626  * 1.730d+00, 1.676d+00, 1.554d+00, 1.475d+00, 1.401d+00,
1627  * 1.271d+00, 1.191d+00, 1.271d+00, 1.373d+00, 1.460d+00,
1628  * 1.448d+00, 1.402d+00, 1.378d+00/
1629 C
1630  DATA relto / 0.175d+00, 6*0.d+00, 0.175d+00, 4*0.d+00, 0.14d+00,
1631  * 0.14 d+00/
1632 C
1633 C--------------------------------------------------------------------
1634 
1635 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1636 C--------------------------------------------------------------------
1637 C
1638  IF(anuc.LT.1.5d0) THEN
1639 C HADRON-PROTON ELASTIC CROSS SECTIONS
1640  ipol=0
1641  ek1=ekin
1642  IF(ekin.GT.20.0d0) THEN
1643  sigela=relto(kproj)*dshpto(kproj,plab)
1644  RETURN
1645  ELSEIF(ekin.GT.10.0d0) THEN
1646  ipol=1
1647  po2=20.0
1648  ek2=sqrt(po2**2+aam(kproj)**2) - aam(kproj)
1649  sel2=relto(kproj)*dshpto(kproj,po2)
1650  ek1=10.0
1651 C
1652  ELSE IF ( ekin .LT. 0.06d+00 ) THEN
1653  IF ( kproj .EQ. 1 ) THEN
1654  IF ( ekin .LT. 0.02d+00 ) THEN
1655  sigela = onethi * sigmlw(ekin)
1656  ELSE
1657  betapr = plab / ( ekin + aam(kproj) )
1658  sigela = sigmpp(betapr)
1659  END IF
1660  RETURN
1661  ELSE IF ( kproj .EQ. 8 ) THEN
1662  IF ( ekin .LT. 0.04d+00 ) THEN
1663  sigela = sigmlw(ekin)
1664  ELSE
1665  betapr = plab / ( ekin + aam(kproj) )
1666  sigela = sigmpn(betapr)
1667  END IF
1668  RETURN
1669  END IF
1670 
1671  ENDIF
1672 C
1673  DO 10 ie=1,nen
1674  IF(ek1.LT.ekihn(ie)) THEN
1675  je1=ie-1
1676  je2=ie
1677 C WRITE (6,'(F12.8,I5,F12.8,I5,F12.8)')EK1,IE,
1678 C * EKIHN(IE),KPROJ,EKIN
1679  ddee=ekihn(je2) - ekihn(je1)
1680  goto 20
1681  ENDIF
1682  10 CONTINUE
1683  je1=nen
1684  je2=nen
1685  ddee=1.
1686  20 CONTINUE
1687 C****
1688 C PROTON-PROTON
1689  IF(kproj.EQ.1) THEN
1690  s1=sepp(je1)
1691  s2=sepp(je2)
1692 C NEUTRON-PROTON
1693  ELSEIF(kproj.EQ.8) THEN
1694  s1=senp(je1)
1695  s2=senp(je2)
1696 C PI(+)-PROTON
1697  ELSEIF(kproj.EQ.13) THEN
1698  s1=sepipp(je1)
1699  s2=sepipp(je2)
1700 C PI(-)-PROTON
1701  ELSEIF(kproj.EQ.14) THEN
1702  s1=sepimp(je1)
1703  s2=sepimp(je2)
1704 C UNDEFINED ENTRY CONDITIONS
1705  ELSE
1706  sigela=0.
1707  RETURN
1708  ENDIF
1709 C
1710  sigela=s1 + (s2-s1)*(ek1-ekihn(je1))/ddee
1711 C
1712 C INTERPOLATION BETWEEN 10/20 GEV
1713  IF(ipol.EQ.1) THEN
1714  sel1=sigela
1715  sigela=sel1 + (sel2-sel1)*(ekin-ek1)/(ek2-ek1)
1716  ENDIF
1717 C
1718  RETURN
1719 C
1720  ENDIF
1721 C***************************************
1722 C HADRON-NUCLEUS ELASTIC CROSS SECTIONS
1723  DO 30 ie=1,nea
1724  IF(ekin.LT.ekiha(ie)) THEN
1725  je=ie - 1
1726  goto 40
1727  ENDIF
1728  30 CONTINUE
1729  IF(ekin.EQ.ekiha(nea)) THEN
1730  je=nea - 1
1731  ELSE
1732  je=-1
1733  ENDIF
1734  40 CONTINUE
1735 C
1736  DO 50 ia=1,nnaa
1737  IF(anuc.LT.amass(ia)) THEN
1738  ja=ia - 1
1739  goto 60
1740  ENDIF
1741  50 CONTINUE
1742  IF(anuc.EQ.amass(nnaa)) THEN
1743  ja=nnaa - 1
1744  ELSE
1745  ja=-1
1746  ENDIF
1747  60 CONTINUE
1748 C
1749  IF (ja) 140,110,70
1750  70 IF (je) 190,150,80
1751  80 temp1=anuc/amass(ja)
1752  temp2=log(amass(ja+1)/amass(ja))
1753  ke=je
1754  DO 90 i=1,2
1755  IF(kproj.EQ.8) THEN
1756  slow=sena(ke,ja)
1757  power=log(sena(ke,ja+1)/slow)/temp2
1758  ELSE
1759  slow=sepa(ke,ja)
1760  power=log(sepa(ke,ja+1)/slow)/temp2
1761  ENDIF
1762  tsig(i)=slow*temp1**power
1763  ke=ke+1
1764  90 CONTINUE
1765 C
1766  100 sigela=tsig(1) + (ekin-ekiha(je))*(tsig(2)-tsig(1)) /(ekiha(je+1)
1767  +-ekiha(je))
1768 
1769  sigela=sigela * 1d3
1770  RETURN
1771 C*
1772 C A IS LESS THAN A MIN
1773  110 ja=1
1774  temp1= (anuc/amass(ja)) **0.66667d0
1775  120 IF (je) 200,170,130
1776  130 IF(kproj.EQ.8) THEN
1777  tsig(1) = sena(je,ja) * temp1
1778  tsig(2) = sena(je+1,ja) *temp1
1779  ELSE
1780  tsig(1) = sepa(je,ja) * temp1
1781  tsig(2) = sepa(je+1,ja) *temp1
1782  ENDIF
1783  go to 100
1784 C*
1785 C A IS GREATER THAN A MAX
1786  140 ja=nnaa
1787  temp1= (anuc/amass(ja))**.66667
1788  go to 120
1789 C*
1790 C EKIN LT. EMIN
1791  150 je=1
1792  160 temp1=anuc/amass(ja)
1793  temp2=log(amass(ja+1)/amass(ja))
1794  IF(kproj.EQ.8) THEN
1795  slow=sena(je,ja)
1796  power=log(sena(je,ja+1)/slow)/temp2
1797  ELSE
1798  slow=sepa(je,ja)
1799  power=log(sepa(je,ja+1)/slow)/temp2
1800  ENDIF
1801  sigela=slow*temp1**power
1802  sigela=sigela * 1d3
1803  RETURN
1804 C
1805  170 je=1
1806  180 IF(kproj.EQ.8) THEN
1807  sigela=sena(je,ja)*temp1
1808  ELSE
1809  sigela=sepa(je,ja)*temp1
1810  ENDIF
1811  sigela=sigela * 1d3
1812  RETURN
1813 C*
1814 C EKIN GT. EMAX
1815  190 je=nea
1816  go to 160
1817  200 je=nea
1818  go to 180
1819  END
1820 *-- Author :
1821 C
1822 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1823 C
1824  DOUBLE PRECISION FUNCTION dshpto(IT,PO)
1825  IMPLICIT DOUBLE PRECISION (a-h,o-z)
1826 C-----------------------------------------------------
1827 C TOTAL HADRON-PROTON CROSS SECTIONS
1828 C Version based on DSHNTO
1829 C in d4diff.f
1830 C used after October 1993
1831 CC++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1832 *KEEP,DPAR.
1833 C /DPAR/ CONTAINS PARTICLE PROPERTIES
1834 C ANAME = LITERAL NAME OF THE PARTICLE
1835 C AAM = PARTICLE MASS IN GEV
1836 C GA = DECAY WIDTH
1837 C TAU = LIFE TIME OF INSTABLE PARTICLES
1838 C IICH = ELECTRIC CHARGE OF THE PARTICLE
1839 C IIBAR = BARYON NUMBER
1840 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
1841 C
1842  CHARACTER*8 aname
1843  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
1844  +iibar(210),k1(210),k2(210)
1845 C------------------
1846 *KEND.
1847  amit2=aam(it)**2
1848  umo2=amit2 + aam(1)**2 + 2.*aam(1)*(po+0.5*amit2/po)
1849  umo=sqrt(umo2)
1850  dshpto=dshnto(it,1,umo)
1851 C
1852  RETURN
1853  END
1854 C*******************************************************************
1855  DOUBLE PRECISION FUNCTION xshpto(IT,PO)
1856  IMPLICIT DOUBLE PRECISION (a-h,o-z)
1857 C-----------------------------------------------------
1858 C TOTAL HADRON-PROTON CROSS SECTIONS
1859 C PLAB.GE.10 GEV
1860 C This is the version used before
1861 C October 1993
1862 C PARAMETRZATION OF HJM 1982
1863 C CORRECTION FOR ANTIPARTICLES 16/08/90 HJM
1864 C
1865 C extension below 10 GeV/c 29/08/90 HJM
1866 C - Plab > 4 GeV/c : Fit from REv. of Part. Prop.
1867 C - Plab < 4 GeV/c : SIG(el) + SIG(inel) = SIHNEL + SIHNIN
1868 C----------------------------------------------------
1869 *KEEP,DPAR.
1870 C /DPAR/ CONTAINS PARTICLE PROPERTIES
1871 C ANAME = LITERAL NAME OF THE PARTICLE
1872 C AAM = PARTICLE MASS IN GEV
1873 C GA = DECAY WIDTH
1874 C TAU = LIFE TIME OF INSTABLE PARTICLES
1875 C IICH = ELECTRIC CHARGE OF THE PARTICLE
1876 C IIBAR = BARYON NUMBER
1877 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
1878 C
1879  CHARACTER*8 aname
1880  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
1881  +iibar(210),k1(210),k2(210)
1882 C------------------
1883 *KEND.
1884 C---------
1885  poo=po
1886  kpro=it
1887  IF(poo.LT.4.0) THEN
1888  CALL sihnel(kpro,1,poo,siel)
1889  CALL sihnin(kpro,1,poo,siin)
1890  xshpto=siel + siin
1891  RETURN
1892  ENDIF
1893 C-----------------------------------------------------
1894 C J.R.10.2.91
1895 C SPECIAL TREATMENT OF P-P CROSS-SECTIONS
1896  IF (it.EQ.1)THEN
1897  IF (poo.LT.2100.)THEN
1898  xshpto=45.6+219.*poo**(-4.23)+0.41*log(poo)**2-3.41*log(poo)
1899  RETURN
1900  ELSEIF(poo.LE.432000.) THEN
1901  xshpto=41.1+77.2*poo**(-0.68)+0.293*log(poo)**2-1.82*log(poo)
1902  RETURN
1903  ELSE
1904  amit2=aam(1)**2
1905  umo2=amit2 + aam(1)**2 + 2.*aam(1)*(po+0.5*amit2/po)
1906  umo=sqrt(umo2)
1907  IF (umo.LT.1800.) THEN
1908  xshpto=61.65+(umo-900.)*6.6/900.
1909  RETURN
1910  ELSEIF(umo.LT.16000.)THEN
1911  xshpto=68.3+(umo-1800.)*25./14200.
1912  RETURN
1913  ELSE
1914  xshpto=93.3+(umo-16000.)*12.5/24000.
1915  RETURN
1916  ENDIF
1917  ENDIF
1918  ENDIF
1919 C------------------------------------------------------
1920  a4=0.
1921  a5=0.
1922  a6=0.
1923  itt=it
1924 C
1925  IF(poo.LT.10.0) THEN
1926  ipio=0
1927  goto(10,20,260,260,260,260,260,30,40,260,260,50,60,70,80,90,
1928  + 100,20,50, 10,10,10,110,120,130), itt
1929 C***
1930  10 CONTINUE
1931 C P - P
1932 C SIGMA - P
1933  a1=45.6
1934  a2=219.
1935  a3=-4.23
1936  a4=0.410
1937  a5=-3.41
1938  goto 140
1939 C***
1940  20 CONTINUE
1941 C PBAR - P
1942 C LAMBDA-BAR - P
1943  a1=41.1
1944  a2=77.2
1945  a3=-0.68
1946  a4=0.293
1947  a5=-1.82
1948  goto 140
1949 C***
1950  30 CONTINUE
1951 C N - P
1952  a1=47.7
1953  a2=100.
1954  a3=-4.57
1955  a4=0.512
1956  a5=-4.29
1957  goto 140
1958 C***
1959  40 CONTINUE
1960 C NBAR - P = PBAR - N
1961  a1=41.9
1962  a2=96.2
1963  a3=-0.99
1964  a4=-0.154
1965  a5=0.0
1966  goto 140
1967 C***
1968  50 CONTINUE
1969 C KLONG - P = KSHORT - P
1970  IF(rndm(v).GE.0.5) goto 80
1971  goto 90
1972 C***
1973  60 CONTINUE
1974 C PI+ - P
1975  a1=32.1
1976  a2=48700.
1977  a3=-7.85
1978  a4=0.540
1979  a5=-4.41
1980  goto 140
1981 C***
1982  70 CONTINUE
1983 C PI- P
1984  a1=33.1
1985  a2=15.0
1986  a3=-1.41
1987  a4=0.458
1988  a5=-4.06
1989  goto 140
1990 C***
1991  80 CONTINUE
1992 C K+ - P
1993  a1=17.1
1994  a2=5.54
1995  a3=-2.67
1996  a4=0.139
1997  a5=-0.270
1998  goto 140
1999 C***
2000  90 CONTINUE
2001 C K- P
2002  a1=-21.1
2003  a2=56.2
2004  a3=-0.27
2005  a4=-0.155
2006  a5=6.24
2007  goto 140
2008 C***
2009  100 CONTINUE
2010 C LAMBDA - P
2011  a1=18.0
2012  a2=0.121
2013  a3=-3.92
2014  a4=6.38
2015  a5=0.0
2016  goto 140
2017 C***
2018  110 CONTINUE
2019 C PIZERO - P
2020 C PRESENTLY PI0 = PI+
2021 C could be 0.5 (PI+ & PI-) with IPIO=1
2022  ipio=0
2023  goto 60
2024 C***
2025  120 CONTINUE
2026 C K0 - P = K+ - P
2027  goto 80
2028 C K0 - P = K+ - N
2029 C A1=18.4
2030 C A2=175
2031 C A3=-7.85
2032 C A4=0.198
2033 C A5=-0.753
2034 C GOTO 200
2035 C***
2036  130 CONTINUE
2037 C K0BAR - P = K- - P
2038  goto 90
2039 C K0BAR - P = K- - N
2040 C A1=-1040.
2041 C A2=1060.
2042 C A3=-0.03
2043 C A4=0.0
2044 C A5=27.8
2045 C***
2046  140 CONTINUE
2047  alp=log(poo)
2048  xshpto=a1 + a2*poo**a3 + a4*alp**2 + a5*alp
2049  IF(ipio.EQ.1) THEN
2050  s1=xshpto
2051  ipio=2
2052  goto 70
2053  ELSEIF(ipio.EQ.2) THEN
2054  xshpto=0.5*(xshpto+s1)
2055  ENDIF
2056  RETURN
2057  ENDIF
2058 C
2059  f1=1.
2060  amit2=aam(itt)**2
2061  umo2=amit2 + aam(1)**2 + 2.*aam(1)*(po+0.5*amit2/po)
2062  umo=sqrt(umo2)
2063 C
2064  goto(150,150,260,260,260,260,260,160,160,260,260,210,170,170,190,
2065  +190,240,240,210,240,240,240,250,220,230), itt
2066 C
2067  150 CONTINUE
2068 C P-P
2069  a1=38.4
2070  a2=0.46
2071  a3=125.
2072  IF(itt.EQ.1) goto 270
2073 C PBAR-P
2074  a5=84.1
2075  a6=-0.57
2076  goto 270
2077 C
2078  160 CONTINUE
2079 C N-P = P-N
2080  a1=38.5
2081  a2=0.46
2082  a3=125.
2083  a4=15.
2084  IF(itt.EQ.8) goto 270
2085 C NBAR-P = PBAR-N
2086  a5=77.43
2087  a6=-0.60
2088  goto 270
2089 C
2090  170 CONTINUE
2091  IF(umo.LT.47.0) goto 180
2092  f1=0.6667
2093  itt=1
2094  goto 150
2095  180 CONTINUE
2096 C (PI-) - P
2097  a1=24.0
2098  a2=0.60
2099  a3=160.
2100  IF(itt.EQ.14) goto 270
2101 C (PI+) - P
2102  a5=-7.9
2103  a6=-0.46
2104  goto 270
2105 C
2106  190 CONTINUE
2107  IF(umo.LT.110.) goto 200
2108  f1=0.6667
2109  itt=1
2110  goto 150
2111  200 CONTINUE
2112 C (K-) - P
2113  a1=20.3
2114  a2=0.59
2115  a3=140.
2116  IF(itt.EQ.16) goto 270
2117 C (K+) - P
2118  a5=-30.13
2119  a6=-0.58
2120  goto 270
2121 C
2122  210 CONTINUE
2123  itt=15
2124  IF(rndm(v).LT.0.5) itt=16
2125  goto 190
2126 C
2127  220 CONTINUE
2128 C***
2129 C K-ZERO: SET EQUAL TO K+/PROTON
2130 C (SHOULD BE K+/NEUTRON)
2131 C***
2132  itt=15
2133  goto 190
2134 C
2135  230 CONTINUE
2136 C***
2137 C K-ZERO BAR: SET EQUAL TO K-/PROTON
2138 C (SHOULD BE K-/NEUTRON)
2139 C***
2140  itt=16
2141  goto 190
2142 C
2143  240 CONTINUE
2144 C***
2145 C SIGMA +/-/0 AND LAMBDA/LAMBDA BAR: SET EQUAL TO P-P
2146 C***
2147  itt=1
2148  goto 150
2149 C
2150  250 CONTINUE
2151 C***
2152 C PI0: SET EQUAL TO PI+
2153 C***
2154  itt=13
2155  goto 170
2156 C
2157  260 CONTINUE
2158 C***
2159 C LEPTONS AND PI0
2160 C***
2161  xshpto=1.e-10
2162  RETURN
2163 C
2164  270 CONTINUE
2165 C
2166  xshpto=a1 + a2*(log(umo2/a3))** 2+ a4/umo2 + a5*umo2**a6
2167 
2168  xshpto=f1*xshpto
2169 C
2170  RETURN
2171  END
2172 *-- Author :
2173 C
2174 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2175 C
2176  SUBROUTINE sihnin(IPROJ,ITAR,PO,SIIN)
2177  IMPLICIT DOUBLE PRECISION (a-h,o-z)
2178 C********************************************************************
2179 C VERSION OCTOBER 89 BY H. MOEHRING
2180 C LEIPZIG
2181 C LAST CHANGE 30/08/90 BY HJM: modification of SIG(pi+ p) = SEGP
2182 C
2183 C
2184 C SEE: H.J. MOEHRING, HADRON-NUCLEUS INELASTIC CROSS-SECTIONS FOR
2185 C USE IN HADRON-CASCADE CALCULATIONS AT HIGH ENERGIES,
2186 C TIS DIVISION REPORT 14. OCTOBER 1983, TIS-RP/116, CERN GENEVA
2187 C
2188 C INPUT VARIABLES:
2189 C IPROJ = TYPE OF THE PROJECTILE
2190 C ITAR = TYPE OF THE TARGET
2191 C PO = PARTICLE MOMENTUM IN GEV/C
2192 C
2193 C OUTPUT VARIABLES:
2194 C SIIN = INTERPOLATED INELASTIC CROSS SECTION IN MILLIBARNS
2195 C
2196 C
2197 C OTHER IMPORTANT VARIABLES:
2198 C SIG = PROTON/NUCLEI CROSS SECTIONS
2199 C SEG = PION-/NUCLEI CROSS SECTIONS ABOVE 0.3 GEV/C
2200 C SEGP = PION+/NUCLEI CROSS SECTIONS ABOVE 0.3 GEV/C
2201 C SIGKM = K+ AND K0/NUCLEI CROSS SECTIONS ABOVE 3.0 GEV/C
2202 C SIGKP = K+ AND K0 BAR/NUCLEI CROSS SECTIONS ABOVE 3.0 GEV/C
2203 C SIGAP = ANTINUCLEON/NUCLEI CROSS SECTIONS ABOVE 3.0 GEV/C
2204 C SEEG = PION/NUCLEI CROSS SECTIONS BELOW 0.3 GEV/C
2205 C P = MOMENTA FOR WHICH THE CROSS SECTIONS ARE GIVEN IN
2206 C SIG, SEG, SEGP, SIGKM, SIGKP AND SIGAP
2207 C PEE = MOMENTA FOR WHICH THE CROSS SECTIONS ARE GIVEN IN
2208 C SEEG
2209 C A = NUCLEI FOR WHICH THE CROSS SECTIONS ARE GIVEN IN
2210 C SIG, SEG, SEGP, SIGKM, SIGKP, SIGAP AND SEEG
2211 C PLAB = MOMENTA FOR WHICH THE TOTAL CROSS SECTIONS ARE
2212 C GIVEN IN TOTCRS
2213 C TOTCRS = TOTAL CROSS SECTIONS AS A FUNCTION OF MOMENTUM
2214 C TOTCRS(K,I) WHERE K=MOMENTUM INDEX,I=REACTION TYPE
2215 C I=1:NEGATIVE KAON-PROTON = KAON ZERO BAR-NEUTRON
2216 C I=2:NEGATIVE KAON-NEUTRON = KAON ZERO BAR-PROTON
2217 C I=3:POSITIVE KAON-PROTON = KAON ZERO NEUTRON
2218 C I=4:POSITIVE KAON-NEUTRON = KAON ZERO-PROTON
2219 C I=5:ANTI NUCLEON-NUCLEON
2220 C
2221 C
2222 C NOTE1: PRESENTLY CROSS SECTIONS ARE ASSUMED TO BE CONSTANT
2223 C ABOVE 10000.0 GEV/C FOR ALL PARTICLES AND
2224 C BELOW 0.13 GEV/C FOR PIONS AND BELOW 0.3 GEV/C FOR OTHERS
2225 C
2226 C NOTE2: SEE TABLE ITT TO FIND OUT HOW DIFFERENT HADRONS
2227 C ARE TREATED. ALL PARTICLES WITH PARTICLE NUMBER BIGGER THAN
2228 C 25 ARE TREATED AS PROTONS.
2229 C
2230 C NOTE3: FOR LEPTONS AND PHOTONS PRACTICALLY ZERO CROSS SECTION
2231 C IS RETURNED.
2232 C********************************************************************
2233 C
2234 *KEEP,DPRIN.
2235  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
2236 *KEND.
2237  dimension seeg(4),pee(4),sigkp(20),sigkm(20),sigap(20)
2238  dimension seg(20),sig(20),segp(20),p(20)
2239 C
2240  DATA p/0.3d0,0.4d0,0.5d0,0.6d0,0.8d0,1.d0,
2241  +1.5d0,2.d0,3.d0,4.d0,5.d0,6.d0,10.d0,
2242  *20.d0,50.d0,100.d0,200.d0,400.d0,1000.d0,10000.d0/
2243 C
2244  DATA seeg/0.1d0,16.d0,35.d0,42.d0/
2245  DATA pee /0.13d0,0.19d0,0.25d0,0.30d0/
2246 C
2247  DATA (sig(ie),ie=1,20) / 3*0.0001d0,0.1d0,1.d0,4.d0,
2248  +24.5d0,25.d0,27.2d0,27.8d0,
2249  +28.5d0,29.2d0,29.7d0, 30.5d0,31.5d0,
2250  +31.7d0,32.1d0,32.9d0,34.5d0,41.2d0/
2251 
2252 C
2253  DATA (seg(ie),ie=1,20) / 42.d0,19.d0,16.1d0,17.d0,
2254  +22.7d0,32.5d0,24.6d0,26.2d0,
2255  +25.0d0,23.7d0,23.0d0,22.5d0,22.d0,
2256  + 21.2d0,20.8d0,20.7d0,21.d0,21.9d0,23.8d0,28.4d0/
2257 
2258 C
2259  DATA (segp(ie),ie=1,20) / 0.1d0,0.1d0,0.1d0,0.1d0,
2260  +11.d0,12.5d0,22.d0,19.2d0,21.5d0,
2261  +21.4d0,20.8d0,20.6d0,20.2d0, 19.8d0,19.9d0,
2262  +20.d0,20.5d0,21.5d0,23.5d0,32.2d0/
2263 
2264 C
2265  DATA sigap/ 164.d0,126.d0,114.d0,98.d0,86.d0,
2266  +72.4d0,59.d0,57.d0,53.d0,52.d0,48.d0,45.5d0,
2267  +43.5d0, 40.4d0,36.5d0,35.2d0,34.5d0,34.5d0,
2268  +35.4d0,41.5d0/
2269 
2270 C
2271  DATA sigkm/ 38.d0,43.d0,23.d0,18.5d0,20.d0,
2272  +29.d0,25.d0,23.d0,22.5d0,21.d0,20.5d0,20.d0,
2273  +19.2d0, 18.5d0,17.8d0,17.8d0,18.3d0,19.2d0,
2274  +21.2d0,28.9d0/
2275 
2276 C
2277  DATA sigkp/ 0.001d0,0.001d0,0.001d0,0.001d0,
2278  +0.2d0,4.5d0,8.9d0,11.6d0,12.2d0,13.4d0,
2279  +13.6d0, 13.7d0,13.7d0,14.9d0,15.9d0,16.5d0,
2280  +17.4d0,18.6d0,20.9d0,28.8d0/
2281 
2282 C
2283 C---------------------------------------------------------------------
2284 C
2285  siin=1.0d-20
2286  IF(itar.NE.1.AND.itar.NE.8) THEN
2287  IF(ipri.GE.1) WRITE(6,'(A/A,2I5,2(1PE15.6))')
2288  + ' WRONG CALL OF SIHNIN/ITAR',
2289  + ' IPROJ,ITAR,PO,SIIN :', iproj,itar,po,siin
2290 
2291  RETURN
2292  ENDIF
2293 C
2294  IF(iproj.GE.3.AND.iproj.LE.7) RETURN
2295 C
2296  iipp=iproj
2297  IF(iproj.EQ.23) iipp=13
2298  iitt=itar
2299 C-----------------------------------------------------------------------
2300 C NEUTRON TARGET TO BE IMPLEMENTED!
2301  IF(iitt.EQ.8) iitt=1
2302 C-----------------------------------------------------------------------
2303  IF(iproj.EQ.19.OR.iproj.EQ.12) THEN
2304  iipp=24
2305  rnd=rndm(v)
2306  IF(rnd.GT.0.5) iipp=25
2307  END IF
2308 C
2309 C********************************************************************
2310 C
2311 C CALCULATE THE MOMENTUM INDEX K
2312 C
2313  DO 10 jk=1,20
2314  IF(po.LE.p(jk)) THEN
2315  k=jk
2316  kk=k-1
2317  go to 20
2318  ENDIF
2319  10 CONTINUE
2320  k=21
2321  20 CONTINUE
2322 C
2323 C*******************************************************************
2324 C
2325  IF(iitt.EQ.1) THEN
2326 C PROTON TARGET
2327  IF(iipp.EQ.1.OR.iipp.EQ. 8.OR.iipp.EQ.17.OR.(iipp.GE.20.and
2328  + .iipp.LE.22)) THEN
2329 C PROTON/NEUTRON
2330 C LAMBDA/ALL SIGMAS
2331  IF(k.EQ.1) THEN
2332  siin=sig(k)
2333  goto 70
2334  ELSEIF(k.EQ.21) THEN
2335  siin=sig(20)
2336  goto 70
2337  ELSE
2338  si1=sig(k)
2339  si2=sig(kk)
2340  ENDIF
2341  ELSEIF(iipp.EQ.14) THEN
2342 C PI -
2343  IF(k.EQ.1) THEN
2344 C LOW ENERGY PI- (<0.3GEV/C)
2345  DO 30 jk=1,4
2346  IF(po.LE.pee(jk)) THEN
2347  kkk=jk
2348  goto 40
2349  ENDIF
2350  30 CONTINUE
2351  kkk=4
2352  40 CONTINUE
2353  kk=kkk-1
2354  IF(kkk.EQ.1) THEN
2355  siin=seeg(kkk)
2356  goto 70
2357  ENDIF
2358  si1=seeg(kkk)
2359  si2=seeg(kk)
2360 C INTERPOLATE LINEARLY WITH RESPECT TO MOMENTUM
2361 C
2362  siin=si1 + (po-pee(kkk))*(si2-si1)/(pee(kk)-pee(kkk))
2363  goto 70
2364  ELSEIF(k.EQ.21) THEN
2365  siin=seg(20)
2366  goto 70
2367  ELSE
2368  si1=seg(k)
2369  si2=seg(kk)
2370  ENDIF
2371 C PI +
2372  ELSEIF(iipp.EQ.13) THEN
2373  50 CONTINUE
2374  IF(k.EQ.1) THEN
2375  siin=segp(k)
2376  goto 70
2377  ELSEIF(k.EQ.21) THEN
2378  siin=segp(20)
2379  goto 70
2380  ENDIF
2381  si1=segp(k)
2382  si2=segp(kk)
2383 C K - AND K0 BAR
2384  ELSEIF(iipp.EQ.16.OR.iipp.EQ.25) THEN
2385  IF(k.EQ.1) THEN
2386  siin=sigkm(k)
2387  goto 70
2388  ELSEIF(k.EQ.21) THEN
2389  siin=sigkm(20)
2390  goto 70
2391  ENDIF
2392  si1=sigkm(k)
2393  si2=sigkm(kk)
2394 C K + AND K0
2395  ELSEIF(iipp.EQ.15.OR.iipp.EQ.24) THEN
2396  IF(k.EQ.1) THEN
2397  siin=sigkp(k)
2398  goto 70
2399  ELSEIF(k.EQ.21) THEN
2400  siin=sigkp(20)
2401  goto 70
2402  ENDIF
2403  si1=sigkp(k)
2404  si2=sigkp(kk)
2405 C ANTI-NUCLEONS
2406 C ANTI-LAMBDA
2407  ELSEIF(iipp.EQ.2.OR.iipp.EQ.9.OR.iipp.EQ.18) THEN
2408  IF(k.EQ.1) THEN
2409  siin=sigap(k)
2410  goto 70
2411  ELSEIF(k.EQ.21) THEN
2412  siin=sigap(20)
2413  goto 70
2414  ENDIF
2415  si1=sigap(k)
2416  si2=sigap(kk)
2417  ENDIF
2418  ENDIF
2419 C
2420 C********************************************************************
2421 C INTERPOLATE LINEARLY WITH RESPECT TO MOMENTUM
2422 C
2423  60 siin=si1 + (po-p(k))*(si1-si2)/(p(k)-p(kk))
2424 C
2425  70 CONTINUE
2426 C ZL=10000.D0*AA/(6.022D0*SIIN)
2427  RETURN
2428  END
2429 *-- Author :
2430 C
2431 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2432 C
2433  SUBROUTINE dhadri(N,PLAB,ELAB,CX,CY,CZ,ITTA)
2434  IMPLICIT DOUBLE PRECISION (a-h,o-z)
2435 C
2436 C-----------------------------
2437 C*** INPUT VARIABLES LIST:
2438 C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
2439 C*** GEV/C LABORATORY MOMENTUM REGION
2440 C*** N - PROJECTILE HADRON INDEX
2441 C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
2442 C*** ELAB - LABORATORY ENERGY OF N (GEV)
2443 C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
2444 C*** ITTA - TARGET NUCLEON INDEX
2445 C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
2446 C IR COUNTS THE NUMBER OF PRODUCED PARTICLES
2447 C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
2448 C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
2449 C*** RESPECT., UNITS (GEV/C AND GEV)
2450 C----------------------------
2451  COMMON /dgamre/ redu,amo,amm(15 )
2452  COMMON /dredve/ thresh(268), irii(17),ikii(17),ieii(17)
2453  common/dreac/umo(296),plabf(296),siin(296),wk(5184),
2454  *nrk(2,268),nure(30,2)
2455  COMMON /dablti/ amh(110),gah(110),tauh(110),ichh(110),ibarh(110),
2456  +k1h(110),k2h(110)
2457  COMMON /dspli/nzk(460,3),wt(460)
2458  COMMON /dmetls/ cxs(149),cys(149),
2459  +czs(149),els(149),pls(149),
2460  +is,its(149)
2461  COMMON /drun/ runtes,eftes
2462 *KEEP,DPAR.
2463 C /DPAR/ CONTAINS PARTICLE PROPERTIES
2464 C ANAME = LITERAL NAME OF THE PARTICLE
2465 C AAM = PARTICLE MASS IN GEV
2466 C GA = DECAY WIDTH
2467 C TAU = LIFE TIME OF INSTABLE PARTICLES
2468 C IICH = ELECTRIC CHARGE OF THE PARTICLE
2469 C IIBAR = BARYON NUMBER
2470 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
2471 C
2472  CHARACTER*8 aname
2473  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
2474  +iibar(210),k1(210),k2(210)
2475 C------------------
2476 *KEEP,DFINLS.
2477  parameter(maxfin=10)
2478  COMMON /dfinls/ itrh(maxfin),cxrh(maxfin),cyrh(maxfin), czrh
2479  +(maxfin),elrh(maxfin),plrh(maxfin),irh
2480 *KEEP,DPRIN.
2481  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
2482 *KEND.
2483  dimension itprf(110)
2484  DATA nnn/0/
2485  DATA umoda/0./
2486  DATA itprf/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
2487  lowp=0
2488  IF (n.LE.0.OR.n.GE.111)n=1
2489  IF (itprf( n ).GT.0 .OR. itta.GT.8) THEN
2490  goto 280
2491 * WRITE (6,1000)
2492 * + ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
2493 * STOP
2494 *1000 FORMAT (3(5H ****/),A,2I4,3(5H ****/))
2495 * + 45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
2496  ENDIF
2497  iatmpt=0
2498  IF (abs(plab-5.).LT.4.99999d0) go to 20
2499  IF(ipri.GE.1) WRITE (6,1010) plab
2500 C STOP
2501  1010 FORMAT ( ' PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
2502  + ALLOWED REGION, PLAB=',1e15.5)
2503 
2504  20 CONTINUE
2505  umodat=n*1.11111d0+itta*2.19291d0
2506  IF(umodat.NE.umoda) CALL dcalum(n,itta)
2507  umoda=umodat
2508  30 iatmpt=0
2509  lowp=lowp+1
2510  40 CONTINUE
2511  imach=0
2512  redu=2.
2513  IF (lowp.GT.20) go to 280
2514  nnn=n
2515  IF (nnn.EQ.n) go to 50
2516  runtes=0.
2517  eftes=0.
2518  50 CONTINUE
2519  is=1
2520  irh=0
2521  ist=1
2522  nstab=23
2523  ire=nure(n,1)
2524  IF(itta.GT.1) ire=nure(n,2)
2525 C
2526 C-----------------------------
2527 C*** IE,AMT,ECM,SI DETERMINATION
2528 C----------------------------
2529  CALL dsigin(ire,plab,n,ie,amt ,amn,ecm,si,itta)
2530  ianth=-1
2531  IF (amh(1).NE.0.9383d0) ianth=1
2532  IF (ianth.GE.0) si=1.
2533  ecmmh=ecm
2534 C
2535 C-----------------------------
2536 C ENERGY INDEX
2537 C IRE CHARACTERIZES THE REACTION
2538 C IE IS THE ENERGY INDEX
2539 C----------------------------
2540  IF (si.LT.1.d-6) go to 280
2541  IF (n.LE.nstab) go to 60
2542  runtes=runtes+1.
2543  IF (runtes.LT.20.d0) WRITE(6,1020)n
2544  1020 FORMAT(3h n=,i10,30h the proektile is a resonance )
2545  IF(ibarh(n).EQ.1) n=8
2546  IF(ibarh(n).EQ.-1) n=9
2547  60 CONTINUE
2548  imach=imach+1
2549  IF (imach.GT.10) go to 280
2550  ecm =ecmmh
2551  amn2=amn**2
2552  amt2=amt**2
2553  ecmn=(ecm**2+amn2-amt2)/(2.*ecm )
2554  IF(ecmn.LE.amn) ecmn=amn
2555  pcmn=sqrt(ecmn**2-amn2)
2556  gam=(elab+amt)/ecm
2557  bgam=plab/ecm
2558  IF (ianth.GE.0) ecm=2.1
2559 C
2560 C-----------------------------
2561 C*** RANDOM CHOICE OF REACTION CHANNEL
2562 C----------------------------
2563  ist=0
2564  CALL
2565  *drandm(vv)
2566  vv=vv-1.d-17
2567 C
2568 C-----------------------------
2569 C*** PLACE REDUCED VERSION
2570 C----------------------------
2571  iiei=ieii(ire)
2572  idwk=ieii(ire+1)-iiei
2573  iiwk=irii(ire)
2574  iiki=ikii(ire)
2575 C
2576 C-----------------------------
2577 C*** SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
2578 C----------------------------
2579  hecm=ecm
2580  humo=2.*umo(iiei+idwk)-umo(iiei+idwk-1)
2581  IF (humo.LT.ecm) ecm=humo
2582 C
2583 C-----------------------------
2584 C*** INTERPOLATION PREPARATION
2585 C----------------------------
2586  ecmo=umo(ie)
2587  ecm1=umo(ie-1)
2588  decm=ecmo-ecm1
2589  dec=ecmo-ecm
2590 C
2591 C-----------------------------
2592 C*** RANDOM LOOP
2593 C----------------------------
2594  ik=0
2595  wkk=0.
2596  wicor=0.
2597  70 ik=ik+1
2598  iwk=iiwk+(ik-1)*idwk+ie-iiei
2599  wok=wk(iwk)
2600  wdk=wok-wk(iwk-1)
2601 C
2602 C-----------------------------
2603 C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
2604 C GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
2605 C CONTRIBUTE
2606 C----------------------------
2607  IF (plab.LT.plabf(iiei+2)) wdk=0.
2608  wico=wok*1.23459876d0+wdk*1.735218469d0
2609  IF (wico.EQ.wicor) go to 70
2610  IF (umo(iiei+idwk).LT.hecm) wdk=0.
2611  wicor=wico
2612 C
2613 C-----------------------------
2614 C*** INTERPOLATION IN CHANNEL WEIGHTS
2615 C----------------------------
2616  eklim=-thresh(iiki+ik)
2617  ielim=iefund(eklim,ire)
2618  delim=umo(ielim)+eklim
2619  *+1.e-16
2620  dete=(ecm-(ecmo-eklim)*.5)*2.
2621  IF (delim*delim-dete*dete) 90,90,80
2622  80 decc=delim
2623  go to 100
2624  90 decc=decm
2625  100 CONTINUE
2626  wkk=wok-wdk*dec/(decc+1.d-9)
2627 C
2628 C-----------------------------
2629 C*** RANDOM CHOICE
2630 C----------------------------
2631 C
2632  IF (vv.GT.wkk) go to 70
2633 C
2634 C***IK IS THE REACTION CHANNEL
2635 C----------------------------
2636  inrk=ikii(ire)+ik
2637  ecm=hecm
2638  i1001 =0
2639 C
2640  110 CONTINUE
2641  it1=nrk(1,inrk)
2642  am1=damg(it1)
2643  it2=nrk(2,inrk)
2644  am2=damg(it2)
2645  ams=am1+am2
2646  i1001=i1001+1
2647  IF (i1001.GT.50) go to 60
2648 C
2649  IF (it2*ams.GT.it2*ecm) go to 110
2650  it11=it1
2651  it22=it2
2652  IF (ianth.GE.0) ecm=elab+amt+0.00001d0
2653  am11=am1
2654  am22=am2
2655  IF (it2.GT.0) go to 120
2656 C
2657 C-----------------------------
2658 C INCLUSION OF DIRECT RESONANCES
2659 C RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE IT1
2660 C------------------------
2661  kz1=k1h(it1)
2662  ist=ist+1
2663  ieco=0
2664  eco=ecm
2665  gam=(elab+amt)/eco
2666  bgam=plab/eco
2667  cxs(1)=cx
2668  cys(1)=cy
2669  czs(1)=cz
2670  go to 170
2671  120 CONTINUE
2672  CALL drandm(ww)
2673  IF(ww.LT. 0.5d0) go to 130
2674  it1=it22
2675  it2=it11
2676  am1=am22
2677  am2=am11
2678  130 CONTINUE
2679 C
2680 C-----------------------------
2681 C THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
2682  ibn=ibarh(n)
2683  ib1=ibarh(it1)
2684  it11=it1
2685  it22=it2
2686  am11=am1
2687  am22=am2
2688  IF(ib1.EQ.ibn) go to 140
2689  it1=it22
2690  it2=it11
2691  am1=am22
2692  am2=am11
2693  140 CONTINUE
2694 C-----------------------------
2695 C***IT1,IT2 ARE THE CREATED PARTICLES
2696 C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
2697 C------------------------
2698  CALL dtwopa(ecm1,ecm2,pcm1,pcm2,cod1,cod2,cof1,cof2,sif1,sif2,
2699  *it1,it2,ecm,ecmn,pcmn,n,am1,am2)
2700  ist=ist+1
2701  its(ist)=it1
2702  amm(ist)=am1
2703 C
2704 C-----------------------------
2705 C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
2706 C----------------------------
2707  CALL dtrafo(gam,bgam,cx,cy,cz,cod1,cof1,sif1,pcm1,ecm1,pls(ist),
2708  *cxs(ist),cys(ist),czs(ist),els(ist))
2709  ist=ist+1
2710  its(ist)=it2
2711  amm(ist)=am2
2712  CALL dtrafo(gam,bgam,cx,cy,cz,cod2,cof2,sif2,
2713  *pcm2,ecm2,pls(ist),cxs(ist),cys(ist),czs(ist),els(ist))
2714  150 CONTINUE
2715 C
2716 C-----------------------------
2717 C***TEST STABLE OR UNSTABLE
2718 C----------------------------
2719  IF(its(ist).GT.nstab) go to 160
2720  irh=irh+1
2721 C
2722 C-----------------------------
2723 C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
2724 C----------------------------
2725 C* IF (REDU.LT.0.D0) GO TO 1009
2726  itrh(irh)=its(ist)
2727  plrh(irh)=pls(ist)
2728  cxrh(irh)=cxs(ist)
2729  cyrh(irh)=cys(ist)
2730  czrh(irh)=czs(ist)
2731  elrh(irh)=els(ist)
2732  ist=ist-1
2733  IF(ist.GE.1) go to 150
2734  go to 260
2735  160 CONTINUE
2736 C
2737 C RANDOM CHOICE OF DECAY CHANNELS
2738 C----------------------------
2739 C
2740  it=its(ist)
2741  eco=amm(ist)
2742  gam=els(ist)/eco
2743  bgam=pls(ist)/eco
2744  ieco=0
2745  kz1=k1h(it)
2746  170 CONTINUE
2747  ieco=ieco+1
2748  CALL drandm(vv)
2749  vv=vv-1.d-17
2750  iik=kz1-1
2751  180 iik=iik+1
2752  IF (vv.GT.wt(iik)) go to 180
2753 C
2754 C IIK IS THE DECAY CHANNEL
2755 C----------------------------
2756  it1=nzk(iik,1)
2757  i310=0
2758  190 CONTINUE
2759  i310=i310+1
2760  am1=damg(it1)
2761  it2=nzk(iik,2)
2762  am2=damg(it2)
2763  IF (it2-1.LT.0) go to 240
2764  it3=nzk(iik,3)
2765  am3=damg(it3)
2766  ams=am1+am2+am3
2767 C
2768 C IF IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
2769 C----------------------------
2770  IF (ieco.LE.10) go to 200
2771  iatmpt=iatmpt+1
2772  IF(iatmpt.GT.3) go to 280
2773  go to 40
2774  200 CONTINUE
2775  IF (i310.GT.50) go to 170
2776  IF (ams.GT.eco) go to 190
2777 C
2778 C FOR THE DECAY CHANNEL
2779 C IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM IT
2780 C----------------------------
2781  IF (redu.LT.0.d0) go to 30
2782  itwthc=0
2783  redu=2.
2784  IF(it3.EQ.0) go to 220
2785  210 CONTINUE
2786  itwth=1
2787  CALL dthrep(eco,ecm1,ecm2,ecm3,pcm1,pcm2,pcm3,cod1,cof1,sif1,
2788  *cod2,cof2,sif2,cod3,cof3,sif3,am1,am2,am3)
2789  go to 230
2790  220 CALL dtwopd(eco,ecm1,ecm2,pcm1,pcm2,cod1,cof1,sif1,cod2,cof2,sif2,
2791  +am1,am2)
2792  itwth=-1
2793  it3=0
2794  230 CONTINUE
2795  itwthc=itwthc+1
2796  IF (redu.GT.0.d0) go to 240
2797  redu=2.
2798  IF (itwthc.GT.100) go to 30
2799  IF (itwth) 220,220,210
2800  240 CONTINUE
2801  its(ist )=it1
2802  IF (it2-1.LT.0) go to 250
2803  its(ist+1) =it2
2804  its(ist+2)=it3
2805  rx=cxs(ist)
2806  ry=cys(ist)
2807  rz=czs(ist)
2808  amm(ist)=am1
2809  CALL dtrafo(gam,bgam,rx,ry,rz,cod1,cof1,sif1,pcm1,ecm1,
2810  *pls(ist),cxs(ist),cys(ist),czs(ist),els(ist))
2811  ist=ist+1
2812  amm(ist)=am2
2813  CALL dtrafo(gam,bgam,rx,ry,rz,cod2,cof2,sif2,pcm2,ecm2,
2814  *pls(ist),cxs(ist),cys(ist),czs(ist),els(ist))
2815  IF (it3.LE.0) go to 250
2816  ist=ist+1
2817  amm(ist)=am3
2818  CALL dtrafo(gam,bgam,rx,ry,rz,cod3,cof3,sif3,pcm3,ecm3,
2819  *pls(ist),cxs(ist),cys(ist),czs(ist),els(ist))
2820  250 CONTINUE
2821  go to 150
2822  260 CONTINUE
2823  270 CONTINUE
2824  RETURN
2825  280 CONTINUE
2826 C
2827 C----------------------------
2828 C
2829 C ZERO CROSS SECTION CASE
2830 C----------------------------
2831 C
2832  irh=1
2833  itrh(1)=n
2834  cxrh(1)=cx
2835  cyrh(1)=cy
2836  czrh(1)=cz
2837  elrh(1)=elab
2838  plrh(1)=plab
2839  RETURN
2840  END
2841 *-- Author :
2842 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2843  BLOCK DATA runtt
2844  IMPLICIT DOUBLE PRECISION (a-h,o-z)
2845  common/drun/runt(2)
2846  DATA runt/100.d0,100.d0/
2847  END
2848 *-- Author :
2849  DOUBLE PRECISION FUNCTION rexp(W)
2850  IMPLICIT DOUBLE PRECISION (a-h,o-z)
2851 C*****EXPONENTIELL VERTEILTE ZUFALLSZAHL, VERTEILUNG F=EXP(-W*X)
2852  a=-1.
2853  10 CALL drandm(xo)
2854  a=a+1.
2855  b=0.
2856  n=0
2857  CALL drandm(v)
2858  20 b=b+v
2859  n=n+1
2860  IF(b-xo) 20,20,30
2861  30 nn=n/2
2862  IF(n.EQ.2*nn) go to 10
2863  rexp=(a+xo)/w
2864  RETURN
2865  END
2866 *-- Author :
2867 c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2868  BLOCK DATA noname
2869  IMPLICIT DOUBLE PRECISION (a-h,o-z)
2870 C***** BLOCK DATA WITHOUT NAMES
2871 C INTEGER * 2 IEII,IKII
2872  COMMON /dslope/ ambmbb(75)
2873  COMMON /dredve/ thresh(268), irii(17),ikii(17),ieii(17)
2874 C DATAS DATAS DATAS DATAS DATAS
2875 C****** *********
2876  DATA ikii/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
2877  & 207, 224, 241, 252, 268 /
2878  DATA ieii/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
2879  & 220, 241, 262, 279, 296 /
2880  DATA irii/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
2881  & 3364, 3507, 4011, 4368, 4725, 4912, 5184/
2882 
2883 C
2884 C MASSES FOR THE SLOPE B(M) IN GEV
2885 C SLOPE B(M) FOR AN MESONIC SYSTEM
2886 C SLOPE B(M) FOR A BARYONIC SYSTEM
2887 
2888 *
2889  DATA ambmbb/ 0.8d0, 0.85d0, 0.9d0, 0.95d0, 1.d0,
2890  & 1.05d0, 1.1d0, 1.15d0, 1.2d0, 1.25d0,
2891  & 1.3d0, 1.35d0, 1.4d0, 1.45d0, 1.5d0,
2892  & 1.55d0, 1.6d0, 1.65d0, 1.7d0, 1.75d0,
2893  & 1.8d0, 1.85d0, 1.9d0, 1.95d0, 2.d0,
2894  & 15.6d0, 14.95d0, 14.3d0, 13.65d0, 13.d0,
2895  & 12.35d0, 11.7d0, 10.85d0, 10.d0, 9.15d0,
2896  & 8.3d0, 7.8d0, 7.3d0, 7.25d0, 7.2d0,
2897  & 6.95d0, 6.7d0, 6.6d0, 6.5d0, 6.3d0,
2898  & 6.1d0, 5.85d0, 5.6d0, 5.35d0, 5.1d0,
2899  & 15.d0, 15.d0, 15.d0, 15.d0, 15.d0, 15.d0, 15.d0,
2900  & 14.2d0, 13.4d0, 12.6d0,
2901  & 11.8d0, 11.2d0, 10.6d0, 9.8d0, 9.d0,
2902  & 8.25d0, 7.5d0, 6.25d0, 5.d0, 4.5d0, 5*4.d0 /
2903 *
2904  END
2905 *-- Author :
2906 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2907  DOUBLE PRECISION FUNCTION damg(IT)
2908  IMPLICIT DOUBLE PRECISION (a-h,o-z)
2909 C*** RANDOM SELECTION OF MASSES OF DECAYING PARTICLES
2910 C INTEGER * 2 ICH,IBAR,K1,K2,NZK,NRK
2911  common/dablti/amm(110),ga(110),tau(110),ich(110)
2912  *,ibar(110),k1(110),k2(110)
2913  COMMON /dgamre/ redu,amo,am(15 )
2914  dimension gasuni(14)
2915  DATA gasuni/
2916  *-1.d0,-.98d0,-.95d0,-.87d0,-.72d0,-.48d0,
2917  *-.17d0,.17d0,.48d0,.72d0,.87d0,.95d0,.98d0,1.d0/
2918  DATA gauno/2.352d0/
2919  DATA gaunon/2.4d0/
2920  DATA io/14/
2921  DATA nstab/23/
2922  i=1
2923  IF (it.LE.0) go to 30
2924  IF (it.LE.nstab) go to 20
2925  dgauni=gauno*gaunon/(io-1.)
2926  CALL drandm(vv)
2927  vv=vv*2.-1.+1.d-16
2928  10 CONTINUE
2929  vo=gasuni(i)
2930  i=i+1
2931  v1=gasuni(i)
2932  IF (vv.GT.v1) go to 10
2933  uniga=dgauni*(i-2.+(vv-vo+1.e-16)/(v1-vo)-(io-1.)*.5)
2934  dam=ga(it)*uniga/gauno
2935  aam=amm(it)+dam
2936  damg=aam
2937  RETURN
2938  20 CONTINUE
2939  damg=amm(it)
2940  RETURN
2941  30 CONTINUE
2942  damg=0.
2943  RETURN
2944  END
2945 *-- Author :
2946  SUBROUTINE dcalum(N,ITTA)
2947  IMPLICIT DOUBLE PRECISION (a-h,o-z)
2948 C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
2949 C INTEGER * 2 ICH,IBAR,K1,K2,NZK,NRK
2950 C *,IEII,IKII,NURE
2951  common/dablti/am(110),ga(110),tau(110),ich(110)
2952  *,ibar(110),k1(110),k2(110)
2953  COMMON /dredve/ thresh(268), irii(17),ikii(17),ieii(17)
2954  common/dspli/nzk(460,3),wt(460)
2955  COMMON /dreac/umo( 296),plabf( 296),siin( 296),wk( 5184),
2956  *nrk(2, 268),nure(30,2)
2957  ire=nure(n,itta/8+1)
2958  ieo=ieii(ire)+1
2959  iee=ieii(ire +1)
2960  am1=am(n )
2961  am12=am1**2
2962  am2=am(itta)
2963  am22=am2**2
2964  DO 10 ie=ieo,iee
2965  plab2=plabf(ie)**2
2966  elab=sqrt(am12+am22+2.*sqrt(plab2+am12)*am2)
2967  umo(ie)=elab
2968  10 CONTINUE
2969  iko=ikii(ire)+1
2970  ike=ikii(ire +1)
2971  umoo=umo(ieo)
2972  DO 30 ik=iko,ike
2973  IF(nrk(2,ik).GT.0) go to 30
2974  iki=nrk(1,ik)
2975  amss=5.
2976  k11=k1(iki)
2977  k22=k2(iki)
2978  DO 20 ik1=k11,k22
2979  in=nzk(ik1,1)
2980  ams=am(in)
2981  in=nzk(ik1,2)
2982  IF(in.GT.0)ams=ams+am(in)
2983  in=nzk(ik1,3)
2984  IF(in.GT.0) ams=ams+am(in)
2985  IF (ams.LT.amss) amss=ams
2986  20 CONTINUE
2987  IF(umoo.LT.amss) umoo=amss
2988  thresh(ik)=umoo
2989  30 CONTINUE
2990  RETURN
2991  END
2992 *-- Author :
2993  SUBROUTINE dchanh
2994  IMPLICIT DOUBLE PRECISION (a-h,o-z)
2995  common/dablti/am(110),ga(110),tau(110),ich(110)
2996  *,ibar(110),k1(110),k2(110)
2997  common/dspli/ nzk(460,3),wt(460)
2998  dimension hwt(460)
2999  COMMON /dredve/ thresh(268), irii(17),ikii(17),ieii(17)
3000  dimension hwk(40)
3001  COMMON /dreac/umo( 296),plabf( 296),siin( 296),wk( 5184),
3002  *nrk(2, 268),nure(30,2)
3003  dimension si(5184)
3004  equivalence(wk(1),si(1))
3005 C--------------------
3006 C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
3007 C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
3008 C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
3009 C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
3010 C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
3011 C--------------------------
3012  ireg=16
3013  DO 90 ire=1,ireg
3014  iwko=irii(ire)
3015  iee=ieii(ire+1)-ieii(ire)
3016  ike=ikii(ire+1)-ikii(ire)
3017  ieo=ieii(ire)+1
3018  iika=ikii(ire)
3019 * modifications to suppress elestic scattering 24/07/91
3020  DO 80 ie=1,iee
3021  sis=1.e-14
3022  sinorc=0.0
3023  DO 10 ik=1,ike
3024  iwk=iwko+iee*(ik-1)+ie
3025  IF(nrk(2,iika+ik).EQ.0) sinorc=1.0
3026  sis=sis+si(iwk)*sinorc
3027  10 CONTINUE
3028  siin(ieo+ie-1)=sis
3029  sio=0.
3030  IF (sis.GE.1.d-12) go to 20
3031  sis=1.
3032  sio=1.
3033  20 CONTINUE
3034  sinorc=0.0
3035  DO 30 ik=1,ike
3036  iwk=iwko+iee*(ik-1)+ie
3037  IF(nrk(2,iika+ik).EQ.0) sinorc=1.0
3038  sio=sio+si(iwk)*sinorc/sis
3039  hwk(ik)=sio
3040  30 CONTINUE
3041  DO 40 ik=1,ike
3042  iwk=iwko+iee*(ik-1)+ie
3043  40 wk(iwk)=hwk(ik)
3044  iiki=ikii(ire)
3045  DO 70 ik=1,ike
3046  am111=0.
3047  inrk1=nrk(1,iiki+ik)
3048  IF (inrk1.GT.0) am111=am(inrk1)
3049  am222=0.
3050  inrk2=nrk(2,iiki+ik)
3051  IF (inrk2.GT.0) am222=am(inrk2)
3052  thresh(iiki+ik)=am111 +am222
3053  IF (inrk2-1.GE.0) go to 60
3054  inrkk=k1(inrk1)
3055  amss=5.
3056  inrko=k2(inrk1)
3057  DO 50 inrk1=inrkk,inrko
3058  inzk1=nzk(inrk1,1)
3059  inzk2=nzk(inrk1,2)
3060  inzk3=nzk(inrk1,3)
3061  IF (inzk1.LE.0.OR.inzk1.GT.110) go to 50
3062  IF (inzk2.LE.0.OR.inzk2.GT.110) go to 50
3063  IF (inzk3.LE.0.OR.inzk3.GT.110) go to 50
3064 C WRITE (6,310)INRK1,INZK1,INZK2,INZK3
3065  1000 FORMAT (4i10)
3066  ams=am(inzk1)+am(inzk2)
3067  IF (inzk3-1.GE.0) ams=ams+am(inzk3)
3068  IF (amss.GT.ams) amss=ams
3069  50 CONTINUE
3070  ams=amss
3071  IF (ams.LT.umo(ieo)) ams=umo(ieo)
3072  thresh(iiki+ik)=ams
3073  60 CONTINUE
3074  70 CONTINUE
3075  80 CONTINUE
3076  90 CONTINUE
3077  DO 100 j=1,460
3078  100 hwt(j)=0.
3079  DO 120 i=1,110
3080  ik1=k1(i)
3081  ik2=k2(i)
3082  hv=0.
3083  IF (ik2.GT.460)ik2=460
3084  IF (ik1.LE.0)ik1=1
3085  DO 110 j=ik1,ik2
3086  hv=hv+wt(j)
3087  hwt(j)=hv
3088  ji=j
3089  110 CONTINUE
3090 C IF (ABS(HV-1.).GT.1.E-4) WRITE(6,1010)I,JI,HV
3091 C1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
3092  120 CONTINUE
3093  DO 130 j=1,460
3094  130 wt(j)=hwt(j)
3095  RETURN
3096  END
3097 *-- Author :
3098  SUBROUTINE dhadde
3099  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3100  CHARACTER*8 anamc,zknamc,aname,zkname,rkname,anamz,zknamz
3101 C
3102  common/dpar/anamc(210),amc(210),gac(210),tauc(210),ichc(210),
3103  *ibarc(210),k1c(210),k2c(210)
3104 C COMMON /DDECAC/ ZKNAMC(540),NZKC(540,3),WTC(540)
3105 
3106  parameter(idmax9=602)
3107 C CHARACTER*8 ZKNAME
3108  common/ddecac/ zknamc(idmax9),wtc(idmax9),nzkc(idmax9,3)
3109 
3110 
3111  COMMON /dnams/ aname(110),zkname(460),rkname(268)
3112  COMMON /dablti/am(110),ga(110),tau(110),ich(110)
3113  *,ibar(110),k1(110),k2(110)
3114  COMMON /dspli/nzk(460,3),wt(460)
3115  COMMON /daddhp/ amz(16),gaz(16),tauz(16),ichz(16),ibarz(16),k1z
3116  +(16),k2z(16),wtz(153),ii22, nzkz(153,3)
3117 
3118  common/daddhn/anamz(16),zknamz(153)
3119  DATA iretur/0/
3120  iretur=iretur+1
3121  am(31)=0.48
3122  IF (iretur.GT.1) RETURN
3123  DO 10 i=1,94
3124  aname(i)=anam c(i)
3125  am(i)=amc(i)
3126  ga( i)=ga c(i)
3127  tau( i)=tau c(i)
3128  ich( i)=ich c(i)
3129  ibar( i)=ibarc(i)
3130  k1( i)=k1c(i)
3131  k2( i)=k2 c(i)
3132  10 CONTINUE
3133  am(1)=0.9383d0
3134  am(2)=am(1)
3135  DO 20 i=26,30
3136  k1(i)=452
3137  k2(i)=452
3138  20 CONTINUE
3139  DO 30 i=1,307
3140  zkname(i)=zknamc(i)
3141  wt( i)=wt c(i)
3142  nzk( i,1)=nzk c(i, 1)
3143  nzk( i,2)=nzk c(i, 2)
3144  nzk( i,3)=nzk c(i, 3)
3145  30 CONTINUE
3146  DO 40 i=1,16
3147  l=i+94
3148  aname(l)=anamz(i)
3149  am(l)=amz(i)
3150  ga( l)=ga z(i)
3151  tau( l)=tau z(i)
3152  ich( l)=ich z(i)
3153  ibar( l)=ibarz(i)
3154  k1( l)=k1z(i)
3155  k2( l)=k2 z(i)
3156  40 CONTINUE
3157  DO 50 i=1,153
3158  l=i+307
3159  zkname(l)=zknamz(i)
3160  wt( l)=wt z(i)
3161  nzk( l,3)=nzk z(i, 3)
3162  nzk( l,2)=nzk z(i, 2)
3163  nzk( l,1)=nzk z(i, 1)
3164  50 CONTINUE
3165  RETURN
3166  END
3167 *-- Author :
3168  FUNCTION iefund(PL,IRE)
3169  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3170 C*****IEFUN CALCULATES A MOMENTUM INDEX
3171 C INTEGER * 2 ICH,IBAR,K1,K2,NZK,NRK
3172 C *,IEII,IKII,NURE
3173  COMMON /drun/ runtes,eftes
3174  COMMON /dredve/ thresh(268), irii(17),ikii(17),ieii(17)
3175  COMMON /dreac/umo( 296),plabf( 296),siin( 296),wk( 5184),
3176  *nrk(2, 268),nure(30,2)
3177  ipla=ieii(ire)+1
3178  *+1
3179  iple=ieii(ire+1)
3180  IF (pl.LT.0.) go to 30
3181  DO 10 i=ipla,iple
3182  j=i-ipla+1
3183  IF (pl.LE.plabf(i)) go to 60
3184  10 CONTINUE
3185  i=iple
3186  IF ( eftes.GT.40.d0) go to 20
3187  eftes=eftes+1.
3188  WRITE(6,1000)pl,j
3189  20 CONTINUE
3190  go to 70
3191  30 CONTINUE
3192  DO 40 i=ipla,iple
3193  j=i-ipla+1
3194  IF (-pl.LE.umo(i)) go to 60
3195  40 CONTINUE
3196  i=iple
3197  IF ( eftes.GT.40.d0) go to 50
3198  eftes=eftes+1.
3199  WRITE(6,1000)pl,i
3200  50 CONTINUE
3201  60 CONTINUE
3202  70 CONTINUE
3203  iefund=i
3204  RETURN
3205  1000 FORMAT(14h plab or -ecm=,e12.4,27h is out of considered range ,
3206  +7h iefun=,i5)
3207  END
3208 *-- Author :
3209  SUBROUTINE dsigin(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
3210  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3211  common/dablti/am(110),ga(110),tau(110),ich(110)
3212  *,ibar(110),k1(110),k2(110)
3213  COMMON /dredve/ thresh(268), irii(17),ikii(17),ieii(17)
3214  COMMON /dreac/umo( 296),plabf( 296),siin( 296),wk( 5184),
3215  *nrk(2, 268),nure(30,2)
3216  ie=iefund(plab,ire)
3217  IF (ie.LE.ieii(ire)) ie=ie+1
3218  amt=am(itar)
3219  amn=am(n)
3220  amn2=amn*amn
3221  amt2=amt*amt
3222  ecm=sqrt(amn2+amt2+2.*amt*sqrt(amn2+plab**2))
3223 C*** INTERPOLATION PREPARATION
3224  ecmo=umo(ie)
3225  ecm1=umo(ie-1)
3226  decm=ecmo-ecm1
3227  dec=ecmo-ecm
3228  iiki=ikii(ire)+1
3229  eklim=-thresh(iiki)
3230  wok=siin(ie)
3231  wdk=wok-siin(ie-1)
3232  IF (ecm.GT.ecmo) wdk=0.
3233 C*** INTERPOLATION IN CHANNEL WEIGHTS
3234  ielim=iefund(eklim,ire)
3235  delim=umo(ielim)+eklim
3236  *+1.e-16
3237  dete=(ecm-(ecmo-eklim)*.5)*2.
3238  IF (delim*delim-dete*dete) 20,20,10
3239  10 decc=delim
3240  go to 30
3241  20 decc=decm
3242  30 CONTINUE
3243  wkk=wok-wdk*dec/(decc+1.d-9)
3244  IF (wkk.LT.0.) wkk=0.
3245  si=wkk+1.d-12
3246  IF (-eklim.GT.ecm) si=1.d-14
3247  RETURN
3248  END
3249 *-- Author :
3250  SUBROUTINE dtchoi(T,P,PP,E,EE,I,II,N,AM1,AM2)
3251  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3252 C ****************************
3253 C TCHOIC CALCULATES A RANDOM VALUE
3254 C FOR THE FOUR-MOMENTUM-TRANSFER T
3255 C ****************************
3256  COMMON /dablti/ am(110),ga(110),tau(110),ich(110), ibar(110),k1
3257  +(110),k2(110)
3258  COMMON /dslope/ sm(25),bbm(25),bbb(25)
3259  ama=am1
3260  amb=am2
3261  IF (i.GT.30.AND.ii.GT.30) go to 20
3262  iii=ii
3263  am3=am2
3264  IF (i.LE.30) go to 10
3265  iii=i
3266  am3=am1
3267  10 CONTINUE
3268  go to 30
3269  20 CONTINUE
3270  iii=ii
3271  am3=am2
3272  IF (ama.LE.amb) go to 30
3273  iii=i
3274  am3=am1
3275  30 CONTINUE
3276  ib=ibar(iii)
3277  ama=am3
3278  k=(ama-0.75)/0.05
3279  IF (k-2.LT.0) k=1
3280  IF (k-26.GE.0) k=25
3281  IF (ib)50,40,50
3282  40 bm=bbm(k)
3283  go to 60
3284  50 bm=bbb(k)
3285  60 CONTINUE
3286 C NORMALIZATION
3287  tmin=-2.*(e*ee-p*pp)+am(n)**2+am1 **2
3288  tmax=-2.*(e*ee+p*pp)+am(n)**2+am1 **2
3289  CALL drandm(vb)
3290 **sr 19-11-95
3291 C IF (VB.LT.0.2D0) BM=BM*0.1
3292 C **0.5
3293  bm = bm*5.0d0
3294 **
3295  tmi=bm*tmin
3296  tma=bm*tmax
3297  etma=0.
3298  IF (abs(tma).GT.120.d0) go to 70
3299  etma=exp(tma)
3300  70 CONTINUE
3301  an=(1./bm)*(exp(tmi)-etma)
3302 C*** RANDOM CHOICE OF THE T - VALUE
3303  CALL drandm(r)
3304  t=(1./bm)*log(etma+r*an*bm)
3305  RETURN
3306  END
3307 *-- Author :
3308  SUBROUTINE dtwopa(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
3309  1it1,it2,umoo,ecm,p,n,am1,am2)
3310  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3311 C ******************************************************
3312 C QUASI TWO PARTICLE PRODUCTION
3313 C TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
3314 C FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
3315 C IN THE CM - SYSTEM
3316 C COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
3317 C SPHERICAL COORDINATES
3318 C ******************************************************
3319  COMMON /dablti/ am(110),ga(110),tau(110),ich(110), ibar(110),k1
3320  +(110),k2(110)
3321 C
3322  ama=am1
3323  amb=am2
3324  ama2=ama*ama
3325  e1=((umoo-amb)*(umoo+amb) + ama2)/(2.*umoo)
3326  e2=umoo - e1
3327  IF (e1.LT.ama*1.00001d0) e1=ama*1.00001d0
3328  amte=(e1-ama)*(e1+ama)
3329  amte=amte+1.d-18
3330  p1=sqrt(amte)
3331  p2=p1
3332 C / P2 / = / P1 / BUT OPPOSITE DIRECTIONS
3333 C DETERMINATION OF THE ANGLES
3334 C COS(THETA1)=COD1 COS(THETA2)=COD2
3335 C SIN(PHI1)=SIF1 SIN(PHI2)=SIF2
3336 C COS(PHI1)=COF1 COS(PHI2)=COF2
3337 C PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
3338  CALL dcosi(cof1,sif1)
3339  cof2=-cof1
3340  sif2=-sif1
3341 C CALCULATION OF THETA1
3342  CALL dtchoi(tr,p,p1,ecm,e1,it1,it2,n,am1,am2)
3343  cod1=(tr-ama2-am(n)*am(n)+2.*ecm*e1)/(2.*p*p1+1.e-18)
3344  IF (cod1.GT.0.9999999d0) cod1=0.9999999d0
3345  cod2=-cod1
3346  RETURN
3347  END
3348 *-- Author :
3349  SUBROUTINE dcosi(SFE,CFE)
3350  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3351  10 x=rndm(a)
3352  y=rndm(b)
3353  xx=x*x
3354  yy=y*y
3355  xy=xx+yy
3356  IF(xy.GT.1.) go to 10
3357  cfe=(xx-yy)/xy
3358  sfe=2.*x*y/xy
3359  IF(rndm(c).LT.0.5d0) go to 20
3360  RETURN
3361  20 sfe=-sfe
3362  RETURN
3363  END
3364 *-- Author :
3365  SUBROUTINE dgauss(X,A,S)
3366  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3367  DATA is/0/
3368  IF(is.NE.0) go to 10
3369  CALL drandm(x)
3370  ro=sqrt(abs(2.*log(x)))
3371  CALL dcosi(sfe,cfe)
3372  x=ro*sfe
3373  is=1
3374  go to 20
3375  10 x=ro*cfe
3376  is=0
3377  20 x=a+x*s
3378  RETURN
3379  END
3380 *-- Author :
3381  SUBROUTINE drandm(X)
3382  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3383  x=rndm(v)
3384  RETURN
3385  END
3386 *-- Author :
3387 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3388 
3389 *=== blkdt5 ===========================================================*
3390 *== *
3391  BLOCK DATA zk
3392  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3393  CHARACTER*8 zknam5,zknam6,anamz,zknam4
3394  COMMON /daddhp/ amz(16),gaz(16),tauz(16),ichz(16),ibarz(16),
3395  & k1z(16),k2z(16),wtz(153),ii22,nzk1(153),nzk2(153),nzk3(153)
3396  COMMON /daddhn/ anamz(16),zknam4(9),zknam5(90),zknam6(54)
3397 * Particle masses in GeV *
3398  DATA amz/ 3*2.2d0, 0.9576d0, 3*1.887d0, 2.4d0, 2.03d0, 2*1.44d0,
3399  & 2*1.7d0, 3*0.d0/
3400 * Resonance width Gamma in GeV *
3401  DATA gaz/ 3*.2d0, .1d0, 4*.2d0, .18d0, 2*.2d0, 2*.15d0, 3*0.d0 /
3402 * Mean life time in seconds *
3403  DATA tauz / 16*0.d0 /
3404 * Charge of particles and resonances *
3405  DATA ichz/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
3406 * Baryonic charge *
3407  DATA ibarz/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
3408 * First number of decay channels used for resonances *
3409 * and decaying particles *
3410  DATA k1z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
3411  & 3*460/
3412 * Last number of decay channels used for resonances *
3413 * and decaying particles *
3414  DATA k2z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
3415  & 3*460/
3416 * Weight of decay channel *
3417  DATA wtz/ .17d0, .83d0, 2*.33d0, .34d0, .17d0, 2*.33d0, .17d0,
3418  & .01d0, .13d0, .36d0, .27d0, .23d0, .0014d0, .0029d0, .0014d0,
3419  & .0029d0, 4*.0007d0, .0517d0, .0718d0, .0144d0, .0431d0, .0359d0,
3420  & .0718d0, .0014d0, .0273d0, .0014d0, .0431d0, 2*.0129d0, .0259d0,
3421  & .0517d0, .0359d0, .0014d0, 2*.0144d0, .0129d0, .0014d0, .0259d0,
3422  & .0359d0, .0072d0, .0474d0, .0948d0, .0259d0, .0072d0, .0144d0,
3423  & .0287d0, .0431d0, .0144d0, .0287d0, .0474d0, .0144d0, .0075d0,
3424  & .0057d0, .0019d0, .0038d0, .0095d0, 2*.0014d0, .0191d0, .0572d0,
3425  & .1430d0, 2*.0029d0, 5*.0477d0, .0019d0, .0191d0, .0686d0,.0172d0,
3426  & .0095d0, .1888d0, .0172d0, .0191d0, .0381d0, 2*.0571d0, .0190d0,
3427  & .0057d0, .0019d0, .0038d0, .0095d0, .0014d0, .0014d0, .0191d0,
3428  & .0572d0, .1430d0, 2*.0029d0, 5*.0477d0, .0019d0, .0191d0,.0686d0,
3429  & .0172d0, .0095d0, .1888d0, .0172d0, .0191d0, .0381d0, 2*.0571d0,
3430  & .0190d0, 4*.25d0, 2*.2d0, .12d0, .1d0, .07d0, .07d0, .14d0,
3431  & 2*.05d0, .0d0, .3334d0, .2083d0, 2*.125d0, .2083d0, .0d0, .125d0,
3432  & .2083d0, .3334d0, .2083d0, .125d0, .3d0, .05d0, .65d0, .3d0,
3433  & .05d0, .65d0, 9*1.d0 /
3434 * Particle numbers in decay channel *
3435  DATA nzk1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
3436  & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
3437  & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
3438  & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
3439  & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
3440  & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
3441  & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
3442  & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
3443  DATA nzk2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
3444  & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
3445  & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
3446  & 4*33, 32, 3*35, 2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
3447  & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
3448  & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
3449  & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
3450  & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
3451  & 1, 8, 1, 8, 1, 9*0 /
3452  DATA nzk3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
3453  & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
3454  & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
3455  & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
3456  & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
3457  & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
3458 * Particle names *
3459  DATA anamz / 'NNPI', 'ANPPI', 'ANNPI', ' ETS ',' PAP ',' PAN ',
3460  & 'APN', 'DEO ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
3461  & 3*'BLANK' /
3462 * Name of decay channel *
3463  DATA zknam4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
3464  & 'ANNPI0','APPPI0','ANPPI-'/
3465  DATA zknam5/' GAGA ','P+P-GA','ETP+P-','K+K- ','K0AK0 ',
3466  & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET ','&0R0 ','P-R+ ',
3467  & 'P+R- ','POOM ',' ETET ','ETSP0 ','R0ET ',' R0R0 ','R+R- ',
3468  & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
3469  & 'P+R-R0','R0OM ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
3470  & 'P+R-OM','OMOM ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
3471  & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
3472  & 'OMOMOM',
3473  & ' P+PO ','P+POPO','P+P+P-','P+ET ','P0R+ ','P+R0 ','ETSP+ ',
3474  & 'R+ET ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
3475  & 'P+R-R+','R+OM ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
3476  & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
3477  & 'P-PO ','P-POPO','P-P-P+','P-ET ','POR- ','P-R0 ','ETSP- ',
3478  & 'R-ET ','R-R0 ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
3479  DATA zknam6/'P+R-R-','R-OM ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
3480  & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
3481  & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO ','LPI+ ',
3482  & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
3483  & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
3484  & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
3485  & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
3486  & 9*'BLANK'/
3487 *= end*block.zk *
3488  END
3489 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3490 *-- Author :
3491 c
3492 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3493 
3494 *$ CREATE BLKDT3.FOR
3495 *COPY BLKDT3
3496 *
3497 *=== blkdt3 ===========================================================*
3498 *== *
3499  BLOCK DATA blkd43
3500  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3501 C INCLUDE '(DBLPRC)'
3502 C INCLUDE '(DIMPAR)'
3503 C INCLUDE '(IOUNIT)'
3504 * * * reaction channel cross section data *
3505 C INCLUDE '(REAC)'
3506 
3507 *$ CREATE REAC.ADD
3508 *COPY REAC
3509 *
3510 *=== reac =============================================================*
3511 *
3512 *----------------------------------------------------------------------*
3513 * *
3514 * Created on 10 december 1991 by Alfredo Ferrari & Paola Sala *
3515 * Infn - Milan *
3516 * *
3517 * Last change on 10-dec-91 by Alfredo Ferrari *
3518 * *
3519 * This is the original common reac of Hadrin *
3520 * *
3521 *----------------------------------------------------------------------*
3522 *
3523  COMMON /dreac/ umo( 296), plabf( 296), siin( 296),
3524  + wk(5184), nrk(2,268), nure(30,2)
3525 
3526  dimension
3527  & umopi(92), umokc(68), umop(39), umon(63), umok0(34),
3528  & plapi(92), plakc(68), plap(39), plan(63), plak0(34),
3529  & spikp1(315), spikpu(278), spikpv(372),
3530  & spikpw(278), spikpx(372), spikp4(315),
3531  & spikp5(187), spikp6(289),
3532  & skmpel(102), spikp7(289), skmnel(68), spikp8(187),
3533  & spikp9(143), spikp0(169), spkpv(143),
3534  & sappel(105), spikpe(399), sapnel(84), spikpz(273),
3535  & sanpel(84) , spikpf(273),
3536  & spkp15(187), spkp16(272),
3537  & nrkpi(164), nrkkc(132), nrkp(70), nrkn(116), nrkk0(54),
3538  & nureln(60)
3539 *
3540  dimension nrklin(532)
3541  equivalence(nrk(1,1), nrklin(1))
3542  equivalence( umo( 1), umopi(1)), ( umo( 93), umokc(1))
3543  equivalence( umo(161), umop(1)), ( umo(200), umon(1))
3544  equivalence( umo(263), umok0(1))
3545  equivalence( plabf( 1), plapi(1)), ( plabf( 93), plakc(1))
3546  equivalence( plabf(161), plap(1)), ( plabf(200), plan(1))
3547  equivalence( plabf(263), plak0(1))
3548  equivalence( wk( 1), spikp1(1)), ( wk( 316), spikpu(1))
3549  equivalence( wk( 594), spikpv(1)), ( wk( 966), spikpw(1))
3550  equivalence( wk(1244), spikpx(1)), ( wk(1616), spikp4(1))
3551  equivalence( wk(1931), spikp5(1)), ( wk(2118), spikp6(1))
3552  equivalence( wk(2407), skmpel(1)), ( wk(2509), spikp7(1))
3553  equivalence( wk(2798), skmnel(1)), ( wk(2866), spikp8(1))
3554  equivalence( wk(3053), spikp9(1)), ( wk(3196), spikp0(1))
3555  equivalence( wk(3365), spkpv(1)), ( wk(3508), sappel(1))
3556  equivalence( wk(3613), spikpe(1)), ( wk(4012), sapnel(1))
3557  equivalence( wk(4096), spikpz(1)), ( wk(4369), sanpel(1))
3558  equivalence( wk(4453), spikpf(1)), ( wk(4726), spkp15(1))
3559  equivalence( wk(4913), spkp16(1))
3560  equivalence(nrk(1,1), nrklin(1))
3561  equivalence(nrklin( 1), nrkpi(1)), (nrklin( 165), nrkkc(1))
3562  equivalence(nrklin( 297), nrkp(1)), (nrklin( 367), nrkn(1))
3563  equivalence(nrklin( 483), nrkk0(1))
3564  equivalence(nure(1,1), nureln(1))
3565 *
3566 **** pi- p data *
3567 **** pi+ n data *
3568  DATA plapi / 0.d0, .3d0, .5d0, .6d0, .7d0, .8d0, .9d0, .95d0,1.d0,
3569  & 1.15d0, 1.3d0, 1.5d0, 1.6d0, 1.8d0, 2.d0, 2.3d0, 2.5d0, 2.8d0,
3570  & 3.d0, 3.5d0, 4.d0, 0.d0, .285d0, .4d0, .45d0, .5d0, .6d0, .7d0,
3571  & .75d0, .8d0, .85d0, .9d0, 1.d0, 1.15d0, 1.3d0, 1.5d0, 1.6d0,
3572  & 1.8d0, 2.d0, 2.3d0, 2.5d0, 2.8d0, 3.d0, 3.5d0, 4.d0, 4.5d0, 0.d0,
3573  & .285d0, .4d0, .45d0, .5d0, .6d0, .7d0, .75d0, .8d0, .85d0, .9d0,
3574  & 1.d0, 1.15d0, 1.3d0, 1.5d0, 1.6d0, 1.8d0, 2.d0, 2.3d0, 2.5d0,
3575  & 2.8d0, 3.d0, 3.5d0, 4.d0, 4.5d0, 0.d0, .3d0, .5d0, .6d0, .7d0,
3576  & .8d0, .9d0, .95d0, 1.d0, 1.15d0, 1.3d0, 1.5d0, 1.6d0, 1.8d0,
3577  & 2.d0, 2.3d0, 2.5d0, 2.8d0, 3.d0, 3.5d0, 4.d0 /
3578  DATA plakc /
3579  & 0.d0, .58d0, .8d0, 1.01d0, 1.23d0, 1.45d0, 1.68d0, 1.94d0,
3580  & 2.18d0, 2.42d0, 2.68d0, 2.96d0, 3.24d0,
3581  & 3.51d0, 3.84d0, 4.16d0, 4.49d0,
3582  & 0.d0, .58d0, .8d0, 1.01d0, 1.23d0, 1.45d0, 1.68d0, 1.94d0,
3583  & 2.18d0, 2.42d0, 2.68d0, 2.96d0, 3.24d0,
3584  & 3.51d0, 3.84d0, 4.16d0, 4.49d0,
3585  & 0.d0, .58d0, .8d0, 1.01d0, 1.23d0, 1.45d0, 1.68d0, 1.94d0,
3586  & 2.18d0, 2.42d0, 2.68d0, 2.96d0, 3.24d0,
3587  & 3.51d0, 3.84d0, 4.16d0, 4.49d0,
3588  & 0.d0, .58d0, .8d0, 1.01d0, 1.23d0, 1.45d0, 1.68d0, 1.94d0,
3589  & 2.18d0, 2.42d0, 2.68d0, 2.96d0, 3.24d0,
3590  & 3.51d0, 3.84d0, 4.16d0, 4.49d0/
3591  DATA plak0 /
3592  & 0.d0, .58d0, .8d0, 1.01d0, 1.23d0, 1.45d0, 1.68d0, 1.94d0,
3593  & 2.18d0, 2.42d0, 2.68d0, 2.96d0, 3.24d0,
3594  & 3.51d0, 3.84d0, 4.16d0, 4.49d0,
3595  & 0.d0, .58d0, .8d0, 1.01d0, 1.23d0, 1.45d0, 1.68d0, 1.94d0,
3596  & 2.18d0, 2.42d0, 2.68d0, 2.96d0, 3.24d0,
3597  & 3.51d0, 3.84d0, 4.16d0, 4.49d0/
3598 * pp pn np nn *
3599  DATA plap /
3600  & 0.d0, 1.06d0, 1.34d0, 1.63d0, 1.92d0, 2.2d0, 2.5d0,2.8d0,3.1d0,
3601  & 3.43d0, 3.75d0, 4.07d0, 4.43d0,
3602  & 0.d0, 1.06d0, 1.34d0, 1.63d0, 1.92d0, 2.2d0, 2.5d0,2.8d0,3.1d0,
3603  & 3.43d0, 3.75d0, 4.07d0, 4.43d0,
3604  & 0.d0, 1.06d0, 1.34d0, 1.63d0, 1.92d0, 2.2d0, 2.5d0,2.8d0,3.1d0,
3605  & 3.43d0, 3.75d0, 4.07d0, 4.43d0 /
3606 * app apn anp ann *
3607  DATA plan /
3608  & 0.d0, 1.d-3, .1d0, .2d0, .3d0, .4d0, .5d0, .6d0,
3609  & .74d0, 1.06d0, 1.34d0, 1.63d0, 1.92d0, 2.2d0, 2.5d0,2.8d0,3.1d0,
3610  & 3.43d0, 3.75d0, 4.07d0, 4.43d0,
3611  & 0.d0, 1.d-3, .1d0, .2d0, .3d0, .4d0, .5d0, .6d0,
3612  & .74d0, 1.06d0, 1.34d0, 1.63d0, 1.92d0, 2.2d0, 2.5d0,2.8d0,3.1d0,
3613  & 3.43d0, 3.75d0, 4.07d0, 4.43d0,
3614  & 0.d0, 1.d-3, .1d0, .2d0, .3d0, .4d0, .5d0, .6d0,
3615  & .74d0, 1.06d0, 1.34d0, 1.63d0, 1.92d0, 2.2d0, 2.5d0,2.8d0,3.1d0,
3616  & 3.43d0, 3.75d0, 4.07d0, 4.43d0 /
3617  DATA siin / 296*0.d0 /
3618  DATA umopi/ 1.08d0,1.233d0,1.302d0,1.369d0,1.496d0,
3619  & 1.557d0,1.615d0,1.6435d0,
3620  & 1.672d0,1.753d0,1.831d0,1.930d0,1.978d0,2.071d0,2.159d0,
3621  & 2.286d0,2.366d0,2.482d0,2.56d0,
3622  & 2.735d0,2.90d0,
3623  & 1.08d0,1.222d0,1.302d0,1.3365d0,1.369d0,1.434d0,
3624  & 1.496d0,1.527d0,1.557d0,
3625  & 1.586d0,1.615d0,1.672d0,1.753d0,1.831d0,1.930d0,1.978d0,
3626  & 2.071d0,2.159d0,2.286d0,2.366d0,
3627  & 2.482d0,2.560d0,2.735d0,2.90d0,3.06d0,
3628  & 1.08d0,1.222d0,1.302d0,1.3365d0,1.369d0,1.434d0,
3629  & 1.496d0,1.527d0,1.557d0,
3630  & 1.586d0,1.615d0,1.672d0,1.753d0,1.831d0,1.930d0,1.978d0,
3631  & 2.071d0,2.159d0,2.286d0,2.366d0,
3632  & 2.482d0,2.560d0,2.735d0,2.90d0,3.06d0,
3633  & 1.08d0,1.233d0,1.302d0,1.369d0,1.496d0,
3634  & 1.557d0,1.615d0,1.6435d0,
3635  & 1.672d0,1.753d0,1.831d0,1.930d0,1.978d0,2.071d0,2.159d0,
3636  & 2.286d0,2.366d0,2.482d0,2.56d0,
3637  & 2.735d0, 2.90d0/
3638  DATA umokc/ 1.44d0,
3639  & 1.598d0,1.7d0,1.8d0,1.9d0,2.0d0,2.1d0,2.2d0,2.3d0,2.4d0,2.5d0,
3640  & 2.6d0,2.7d0,2.8d0,2.9d0,3.0d0,
3641  & 3.1d0,1.44d0,
3642  & 1.598d0,1.7d0,1.8d0,1.9d0,2.0d0,2.1d0,2.2d0,2.3d0,2.4d0,2.5d0,
3643  & 2.6d0,2.7d0,2.8d0,2.9d0,3.0d0,
3644  & 3.1d0,1.44d0,
3645  & 1.598d0,1.7d0,1.8d0,1.9d0,2.0d0,2.1d0,2.2d0,2.3d0,2.4d0,2.5d0,
3646  & 2.6d0,2.7d0,2.8d0,2.9d0,3.0d0,
3647  & 3.1d0,1.44d0,
3648  & 1.598d0,1.7d0,1.8d0,1.9d0,2.0d0,2.1d0,2.2d0,2.3d0,2.4d0,2.5d0,
3649  & 2.6d0,2.7d0,2.8d0,2.9d0,3.0d0,
3650  & 3.1d0/
3651  DATA umok0/ 1.44d0,
3652  & 1.598d0,1.7d0,1.8d0,1.9d0,2.0d0,2.1d0,2.2d0,2.3d0,2.4d0,2.5d0,
3653  & 2.6d0,2.7d0,2.8d0,2.9d0,3.0d0,
3654  & 3.1d0,1.44d0,
3655  & 1.598d0,1.7d0,1.8d0,1.9d0,2.0d0,2.1d0,2.2d0,2.3d0,2.4d0,2.5d0,
3656  & 2.6d0,2.7d0,2.8d0,2.9d0,3.0d0,
3657  & 3.1d0/
3658 * pp pn np nn *
3659  DATA umop/
3660  & 1.88d0,2.102d0,2.2d0,2.3d0,2.4d0,2.5d0,2.6d0,2.7d0,2.8d0,2.9d0,
3661  & 3.d0,3.1d0,3.2d0,
3662  & 1.88d0,2.102d0,2.2d0,2.3d0,2.4d0,2.5d0,2.6d0,2.7d0,2.8d0,2.9d0,
3663  & 3.d0,3.1d0,3.2d0,
3664  & 1.88d0,2.102d0,2.2d0,2.3d0,2.4d0,2.5d0,2.6d0,2.7d0,2.8d0,2.9d0,
3665  & 3.d0,3.1d0,3.2d0/
3666 * app apn anp ann *
3667  DATA umon /
3668  & 1.877d0,1.87701d0,1.879d0,1.887d0,1.9d0,1.917d0,1.938d0,1.962d0,
3669  & 2.d0,2.102d0,2.2d0,2.3d0,2.4d0,2.5d0,2.6d0,2.7d0,2.8d0,2.9d0,
3670  & 3.d0,3.1d0,3.2d0,
3671  & 1.877d0,1.87701d0,1.879d0,1.887d0,1.9d0,1.917d0,1.938d0,1.962d0,
3672  & 2.d0,2.102d0,2.2d0,2.3d0,2.4d0,2.5d0,2.6d0,2.7d0,2.8d0,2.9d0,
3673  & 3.d0,3.1d0,3.2d0,
3674  & 1.877d0,1.87701d0,1.879d0,1.887d0,1.9d0,1.917d0,1.938d0,1.962d0,
3675  & 2.d0,2.102d0,2.2d0,2.3d0,2.4d0,2.5d0,2.6d0,2.7d0,2.8d0,2.9d0,
3676  & 3.d0,3.1d0,3.2d0/
3677 **** reaction channel state particles *
3678  DATA nrkpi / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
3679  & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
3680  & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
3681  & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
3682  & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
3683  & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
3684  & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
3685  & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
3686  & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
3687  & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
3688  DATA nrkkc/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
3689  & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
3690  & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
3691  & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
3692  & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
3693  & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
3694  & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
3695  & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
3696 * *
3697 * k0 p k0 n ak0 p ak/ n *
3698 * *
3699  DATA nrkk0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
3700  & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13, 22, 13, 21, 23,
3701  & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
3702  & 53, 47, 1, 103, 0, 93, 0/
3703 * pp pn np nn *
3704  DATA nrkp / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
3705  & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
3706  & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
3707  & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
3708 * app apn anp ann *
3709  DATA nrkn/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
3710  & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
3711  & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
3712  & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
3713  & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
3714  & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
3715  & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
3716 **** channel cross section *
3717  DATA spikp1/ 0.d0, 300.d0, 40.d0, 20.d0, 13.d0,8.5d0,8.d0, 9.5d0,
3718  & 12.d0,14.d0,15.5d0,20.d0,17.d0,13.d0,10.d0,9.d0,8.5d0,8.d0,7.8d0,
3719  & 7.3d0, 6.7d0, 9*0.d0,.23d0,.35d0,.7d0,.52d0,.4d0,.3d0,.2d0,.15d0,
3720  & .13d0, .11d0, .09d0, .07d0, 0.d0, .033d0,.8d0,1.35d0,1.35d0,.5d0,
3721  & 15*0.d0, 3*0.d0,.00d0,0.80d0,2.2d0,3.6d0,4.6d0,4.7d0,3.5d0,2.4d0,
3722  &1.8d0,1.4d0,.75d0,.47d0,.25d0,.13d0,.08d0,6*0.d0,0.d0,1.2d0,3.3d0,
3723  & 5.4d0,6.9d0,7.3d0,5.3d0,3.6d0,2.7d0,2.2d0,1.1d0,.73d0,.4d0,.22d0,
3724  & .12d0,9*0.d0,.0d0,0.d0,2.0d0,4.4d0,6.8d0,9.9d0,7.9d0,6.0d0,3.8d0,
3725  &2.5d0,2.d0,1.4d0,1.d0,.6d0,.35d0,10*0.d0,.25d0,.55d0,.75d0,1.25d0,
3726  & 1.9d0,2.d0,1.8d0,1.5d0,1.25d0,1.d0,.8d0,6*0.d0,4*0.d0,.4d0,.85d0,
3727  & 1.1d0, 1.85d0, 2.8d0, 3.d0,2.7d0,2.2d0,1.85d0,1.5d0,1.2d0,6*0.d0,
3728  & 6*0.d0, .5d0, 1.2d0, 1.7d0, 3.4d0, 5.2d0, 6.4d0, 6.1d0, 5.6d0,
3729  & 5.2d0, 6*0.d0, 2*0.d0, .0d0, 1.d0, 3.3d0, 5.2d0, 4.45d0, 3.6d0,
3730  & 2.75d0, 1.9d0, 1.65d0, 1.3d0, .95d0, .6d0, .45d0, 6*0.d0, 3*0.d0,
3731  & .0d0, .45d0, 1.4d0, 1.5d0, 1.1d0, .85d0, .5d0, .3d0, .2d0, .15d0,
3732  & 8*0.d0, 5*0.d0, .0d0, .0d0, .6d0, .8d0, .95d0, .8d0, .7d0, .6d0,
3733  & .5d0, .4d0, 6*0.d0, 5*0.d0, .0d0, .00d0, .85d0, 1.2d0, 1.4d0,
3734  & 1.2d0, 1.05d0, .9d0, .7d0, .55d0, 6*0.d0, 5*0.d0, .0d0, .00d0,
3735  & 1.d0, 1.5d0, 3.5d0, 4.15d0, 3.7d0, 2.7d0, 2.3d0, 1.75d0, 6*0.d0,
3736  & 10*0.d0, .5d0, 2.0d0, 3.3d0, 5.4d0, 7.d0 /
3737 **** pi+ n data *
3738  DATA spikpu/ 0.d0, 25.d0, 13.d0, 11.d0, 10.5d0, 14.d0, 20.d0,
3739  & 20.d0, 16.d0, 14.d0, 19.d0, 28.d0, 17.5d0, 13.5d0, 12.d0, 10.5d0,
3740  & 10.d0, 10.d0, 9.5d0, 9.d0, 8.d0, 7.5d0, 7.d0, 6.5d0, 6.d0, 0.d0,
3741  & 48.d0, 19.d0, 15.d0, 11.5d0, 10.d0, 8.d0, 6.5d0, 5.5d0, 4.8d0,
3742  & 4.2d0, 7.5d0, 3.4d0, 2.5d0, 2.5d0, 2.1d0, 1.4d0, 1.d0, .8d0,
3743  & .6d0, .46d0, .3d0, .2d0, .15d0, .13d0, 11*0.d0, .95d0, .65d0,
3744  & .48d0, .35d0, .2d0, .18d0, .17d0, .16d0, .15d0, .1d0, .09d0,
3745  & .065d0, .05d0, .04d0, 12*0.d0, .2d0, .25d0, .25d0, .2d0, .1d0,
3746  & .08d0, .06d0, .045d0, .03d0, .02d0, .01d0, .005d0, .003d0,
3747  & 12*0.d0, .3d0, .24d0, .18d0, .15d0, .13d0, .12d0, .11d0, .1d0,
3748  & .09d0, .08d0, .05d0, .04d0, .03d0, 0.d0, 0.16d0, .7d0, 1.3d0,
3749  & 3.1d0, 4.5d0, 2.d0, 18*0.d0, 3*.0d0, 0.d0, 0.d0, 4.0d0, 11.d0,
3750  & 11.4d0, 10.3d0, 7.5d0, 6.8d0, 4.75d0, 2.5d0, 1.5d0, .9d0, .55d0,
3751  & .35d0, 13*0.d0, .1d0, .34d0, .5d0, .8d0, 1.1d0, 2.25d0, 3.3d0,
3752  & 2.3d0, 1.6d0, .95d0, .45d0, .28d0, .15d0, 10*0.d0, 2*0.d0, .17d0,
3753  & .64d0, 1.d0, 1.5d0, 2.1d0, 4.25d0, 6.2d0, 4.4d0, 3.d0, 1.8d0,
3754  & .9d0, .53d0, .28d0, 10*0.d0, 2*0.d0, .25d0, .82d0,
3755  & 1.3d0, 1.9d0, 2.8d0, 5.5d0 , 8.d0, 5.7d0, 3.9d0, 2.35d0, 1.15d0,
3756  & .69d0, .37d0, 10*0.d0, 7*0.d0, .0d0, .34d0, 1.5d0, 3.47d0,
3757  & 5.87d0, 6.23d0, 4.27d0, 2.6d0, 1.d0, .6d0, .3d0, .15d0, 6*0.d0/
3758 *
3759  DATA spikpv/ 7*0.d0, .00d0, .16d0, .75d0, 1.73d0, 2.93d0, 3.12d0,
3760  & 2.13d0, 1.3d0, .5d0, .3d0, .15d0, .08d0, 6*0.d0, 10*0.d0, .2d0,
3761  & .6d0, .92d0, 2.4d0, 4.9d0, 6.25d0, 5.25d0, 3.5d0, 2.15d0, 1.4d0,
3762  & 1.d0, .7d0, 13*0.d0, .13d0, .4d0, .62d0, 1.6d0, 3.27d0, 4.17d0,
3763  & 3.5d0, 2.33d0, 1.43d0, .93d0, .66d0, .47d0, 13*0.d0, .07d0, .2d0,
3764  & .31d0, .8d0, 1.63d0, 2.08d0, 1.75d0, 1.17d0, .72d0, .47d0, .34d0,
3765  & .23d0, 17*0.d0, .33d0, 1.d0, 1.8d0, 2.67d0, 5.33d0, 6.d0, 5.53d0,
3766  & 5.d0, 17*0.d0, .17d0, .5d0, .9d0, 1.83d0, 2.67d0, 3.0d0, 2.77d0,
3767  & 2.5d0, 3*0.d0, 3*0.d0, 1.d0, 3.3d0, 2.8d0, 2.5d0, 2.3d0, 1.8d0,
3768  & 1.5d0, 1.1d0, .8d0, .7d0, .55d0, .3d0, 10*0.d0, 9*0.d0, .1d0,
3769  & .4d0, 1.d0, 1.4d0, 2.2d0, 2.5d0, 2.2d0, 1.65d0, 1.35d0, 1.1d0,
3770  & .8d0, .6d0, .4d0, 12*0.d0, .15d0, .6d0, 1.5d0, 2.1d0, 3.3d0,
3771  & 3.8d0, 3.3d0, 2.45d0, 2.05d0, 1.65d0, 1.2d0, .9d0, .6d0, 3*0.d0,
3772  & 9*0.d0, .10d0, .2d0, .5d0, .7d0, 1.3d0, 1.55d0, 1.9d0, 1.8d0,
3773  & 1.55d0, 1.35d0, 1.15d0, .95d0, .7d0, 13*0.d0, .2d0, .5d0, .7d0,
3774  & 1.3d0, 1.55d0, 1.9d0, 1.8d0, 1.55d0, 1.35d0, 1.15d0, .95d0, .7d0,
3775  & 17*0.d0, .2d0, .5d0, .85d0, 2.d0, 2.15d0, 2.05d0, 1.75d0, 1.d0,
3776  & 17*0.d0, .13d0, .33d0, .57d0, 1.33d0, 1.43d0, 1.36d0, 1.17d0,
3777  & .67d0, 17*0.d0, .07d0, .17d0, .28d0, .67d0, .72d0, .69d0, .58d0,
3778  & .33d0,17*0.d0,.4d0, .7d0, 1.d0, 1.6d0, 1.8d0, 2.3d0,1.9d0,1.7d0 /
3779 **** pi- p data *
3780  DATA spikpw/ 0.d0, 25.d0, 13.d0, 11.d0, 10.5d0, 14.d0, 2*20.d0,
3781  & 16.d0, 14.d0, 19.d0, 28.d0, 17.5d0, 13.5d0, 12.d0, 10.5d0,
3782  & 2*10.d0, 9.5d0, 9.d0, 8.d0, 7.5d0, 7.d0, 6.5d0, 6.d0, 0.d0,
3783  & 48.d0, 19.d0, 15.d0, 11.5d0, 10.d0, 8.d0, 6.5d0, 5.5d0, 4.8d0,
3784  & 4.2d0, 7.5d0, 3.4d0, 2*2.5d0, 2.1d0, 1.4d0, 1.d0, .8d0, .6d0,
3785  & .46d0, .3d0, .2d0, .15d0, .13d0, 11*0.d0, .95d0, .65d0, .48d0,
3786  & .35d0, .2d0, .18d0, .17d0, .16d0, .15d0, .1d0, .09d0, .065d0,
3787  & .05d0, .04d0, 12*0.d0, .2d0, 2*.25d0, .2d0, .1d0, .08d0, .06d0,
3788  & .045d0, .03d0, .02d0, .01d0, .005d0, .003d0, 12*0.d0, .3d0,
3789  & .24d0, .18d0, .15d0, .13d0, .12d0, .11d0, .1d0, .09d0, .08d0,
3790  & .05d0, .04d0, .03d0, 0.d0, 0.16d0, .7d0, 1.3d0, 3.1d0, 4.5d0,
3791  & 2.d0, 23*0.d0, 4.0d0, 11.d0, 11.4d0, 10.3d0, 7.5d0, 6.8d0,
3792  & 4.75d0, 2.5d0, 1.5d0, .9d0, .55d0, .35d0, 13*0.d0, .1d0, .34d0,
3793  & .5d0, .8d0, 1.1d0, 2.25d0, 3.3d0, 2.3d0, 1.6d0, .95d0, .45d0,
3794  & .28d0, .15d0, 12*0.d0, .17d0, .64d0, 1.d0, 1.5d0, 2.1d0, 4.25d0,
3795  & 6.2d0, 4.4d0, 3.d0, 1.8d0, .9d0, .53d0, .28d0, 12*0.d0, .25d0,
3796  & .82d0, 1.3d0, 1.9d0, 2.8d0, 5.5d0, 8.d0, 5.7d0, 3.9d0, 2.35d0,
3797  & 1.15d0, .69d0, .37d0, 18*0.d0, .34d0, 1.5d0, 3.47d0, 5.87d0,
3798  & 6.23d0, 4.27d0, 2.6d0, 1.d0, .6d0, .3d0, .15d0, 6*0.d0/
3799 *
3800  DATA spikpx/ 8*0.d0, .16d0, .75d0, 1.73d0, 2.93d0, 3.12d0,
3801  & 2.13d0, 1.3d0, .5d0, .3d0, .15d0, .08d0, 16*0.d0, .2d0, .6d0,
3802  & .92d0, 2.4d0, 4.9d0, 6.25d0, 5.25d0, 3.5d0, 2.15d0, 1.4d0, 1.d0,
3803  & .7d0, 13*0.d0, .13d0, .4d0, .62d0, 1.6d0, 3.27d0, 4.17d0, 3.5d0,
3804  & 2.33d0, 1.43d0, .93d0, .66d0, .47d0, 13*0.d0, .07d0, .2d0, .31d0,
3805  & .8d0, 1.63d0, 2.08d0, 1.75d0, 1.17d0, .72d0, .47d0, .34d0, .23d0,
3806  & 17*0.d0, .33d0, 1.d0, 1.8d0, 2.67d0, 5.33d0, 6.d0, 5.53d0, 5.d0,
3807  & 17*0.d0, .17d0, .5d0, .9d0, 1.83d0, 2.67d0, 3.0d0, 2.77d0, 2.5d0,
3808  & 6*0.d0, 1.d0, 3.3d0, 2.8d0, 2.5d0, 2.3d0, 1.8d0, 1.5d0, 1.1d0,
3809  & .8d0, .7d0, .55d0, .3d0, 19*0.d0, .1d0, .4d0, 1.d0, 1.4d0, 2.2d0,
3810  & 2.5d0, 2.2d0, 1.65d0, 1.35d0, 1.1d0, .8d0, .6d0, .4d0, 12*0.d0,
3811  & .15d0, .6d0, 1.5d0, 2.1d0, 3.3d0, 3.8d0, 3.3d0, 2.45d0, 2.05d0,
3812  & 1.65d0, 1.2d0, .9d0, .6d0, 12*0.d0, .10d0, .2d0, .5d0, .7d0,
3813  & 1.3d0, 1.55d0, 1.9d0, 1.8d0, 1.55d0, 1.35d0, 1.15d0, .95d0, .7d0,
3814  & 13*0.d0, .2d0, .5d0, .7d0, 1.3d0, 1.55d0, 1.9d0, 1.8d0, 1.55d0,
3815  & 1.35d0, 1.15d0, .95d0, .7d0, 17*0.d0, .2d0, .5d0, .85d0, 2.d0,
3816  & 2.15d0, 2.05d0, 1.75d0, 1.d0, 17*0.d0, .13d0, .33d0, .57d0,
3817  & 1.33d0, 1.43d0, 1.36d0, 1.17d0, .67d0, 17*0.d0, .07d0, .17d0,
3818  & .28d0, .67d0, .72d0, .69d0, .58d0, .33d0, 17*0.d0, .4d0, .7d0,
3819  & 1.d0, 1.6d0, 1.8d0, 2.3d0, 1.9d0, 1.7d0 /
3820 **** pi- n data *
3821  DATA spikp4 / 0.d0, 300.d0, 40.d0, 20.d0, 13.d0, 8.5d0, 8.d0,
3822  & 9.5d0, 12.d0, 14.d0, 15.5d0, 20.d0, 17.d0, 13.d0, 10.d0, 9.d0,
3823  & 8.5d0, 8.d0, 7.8d0, 7.3d0, 6.7d0, 9*0.d0, .23d0, .35d0, .7d0,
3824  & .52d0, .4d0, .3d0, .2d0, .15d0, .13d0, .11d0, .09d0, .07d0, 0.d0,
3825  & .033d0, .8d0, 2*1.35d0, .5d0, 19*0.d0, 0.8d0, 2.2d0, 3.6d0,
3826  & 4.6d0, 4.7d0, 3.5d0, 2.4d0, 1.8d0, 1.4d0, .75d0, .47d0, .25d0,
3827  & .13d0, .08d0, 7*0.d0, 1.2d0, 3.3d0, 5.4d0, 6.9d0, 7.3d0, 5.3d0,
3828  & 3.6d0, 2.7d0, 2.2d0, 1.1d0, .73d0, .4d0, .22d0, .12d0, 11*0.d0,
3829  & 2.0d0, 4.4d0, 6.8d0, 9.9d0, 7.9d0, 6.0d0, 3.8d0, 2.5d0, 2.d0,
3830  & 1.4d0, 1.d0, .6d0, .35d0, 10*0.d0, .25d0, .55d0, .75d0, 1.25d0,
3831  & 1.9d0, 2.d0, 1.8d0, 1.5d0, 1.25d0, 1.d0, .8d0, 10*0.d0, .4d0,
3832  & .85d0, 1.1d0, 1.85d0, 2.8d0, 3.d0, 2.7d0, 2.2d0, 1.85d0, 1.5d0,
3833  & 1.2d0, 12*0.d0, .5d0, 1.2d0, 1.7d0, 3.4d0, 5.2d0, 6.4d0, 6.1d0,
3834  & 5.6d0, 5.2d0, 9*0.d0, 1.d0, 3.3d0, 5.2d0, 4.45d0, 3.6d0, 2.75d0,
3835  & 1.9d0, 1.65d0, 1.3d0, .95d0, .6d0, .45d0, 10*0.d0, .45d0, 1.4d0,
3836  & 1.5d0, 1.1d0, .85d0, .5d0, .3d0, .2d0, .15d0, 15*0.d0, .6d0,
3837  & .8d0, .95d0, .8d0, .7d0, .6d0, .5d0, .4d0, 13*0.d0, .85d0, 1.2d0,
3838  & 1.4d0, 1.2d0, 1.05d0, .9d0, .7d0, .55d0, 13*0.d0, 1.d0, 1.5d0,
3839  & 3.5d0, 4.15d0, 3.7d0, 2.7d0, 2.3d0, 1.75d0, 16*0.d0, .5d0, 2.0d0,
3840  & 3.3d0, 5.4d0, 7.d0 /
3841 **** k+ p data *
3842  DATA spikp5/ 0.d0, 20.d0, 14.d0, 12.d0, 11.5d0, 10.d0, 8.d0,
3843  & 7.d0, 6.d0, 5.5d0, 5.3d0, 5.d0, 4.5d0, 4.4d0, 3.8d0, 3.d0, 2.8d0,
3844  & 0.d0, .5d0, 1.15d0, 2.d0, 1.3d0, .8d0, .45d0, 13*0.d0, 0.9d0,
3845  & 2.5d0, 3.d0, 2.5d0, 2.3d0, 2.d0, 1.7d0, 1.5d0, 1.2d0, .9d0, .6d0,
3846  & .45d0, .21d0, .2d0, 3*0.d0, .9d0, 2.5d0, 3.d0, 2.5d0, 2.3d0,
3847  & 2.d0, 1.7d0, 1.5d0, 1.2d0, .9d0, .6d0, .45d0, .21d0, .2d0,
3848  & 4*0.d0, 1.d0, 2.1d0, 2.6d0, 2.3d0, 2.1d0, 1.8d0, 1.7d0, 1.4d0,
3849  & 1.2d0, 1.05d0, .9d0, .66d0, .5d0, 7*0.d0, .3d0, 2*1.d0, .9d0,
3850  & .7d0, .4d0, .3d0, .2d0, 11*0.d0, .1d0, 1.d0, 2.2d0, 3.5d0, 4.2d0,
3851  & 4.55d0, 4.85d0, 4.9d0, 10*0.d0, .2d0, .7d0, 1.6d0, 2.5d0, 2.2d0,
3852  & 1.71d0, 1.6d0, 6*0.d0, 1.4d0, 3.8d0, 5.d0, 4.7d0, 4.4d0, 4.d0,
3853  & 3.5d0, 2.85d0, 2.35d0, 2.01d0, 1.8d0, 12*0.d0, .1d0, .8d0,2.05d0,
3854  & 3.31d0, 3.5d0, 12*0.d0, .034d0, .2d0, .75d0, 1.04d0, 1.24d0 /
3855 **** k+ n data *
3856  DATA spikp6/ 0.d0, 6.d0, 11.d0, 13.d0, 6.d0, 5.d0, 3.d0, 2.2d0,
3857  & 1.5d0, 1.2d0, 1.d0, .7d0, .6d0, .5d0, .45d0, .35d0, .3d0, 0.d0,
3858  & 6.d0, 11.d0, 13.d0, 6.d0, 5.d0, 3.d0, 2.2d0, 1.5d0, 1.2d0, 1.d0,
3859  & .7d0, .6d0, .5d0, .45d0, .35d0, .3d0, 0.d0, .5d0, 1.3d0, 2.8d0,
3860  & 2.3d0, 1.6d0, .9d0, 13*0.d0, 0.9d0, 2.5d0, 3.d0, 2.5d0, 2.3d0,
3861  & 2.d0, 1.7d0, 1.5d0,1.2d0,.9d0,.6d0,.45d0,.21d0,.2d0,3*0.d0,0.9d0,
3862  & 2.5d0, 3.d0, 2.5d0, 2.3d0,2.d0,1.7d0,1.5d0,1.2d0,.9d0,.6d0,.45d0,
3863  & .21d0, .2d0,4*0.d0,1.d0,2.1d0,2.6d0,2.3d0,2.d0,1.8d0,1.7d0,1.4d0,
3864  & 1.2d0,1.15d0,.9d0,.66d0,.5d0,4*0.d0,1.d0,2.1d0,2.6d0,2.3d0,2.1d0,
3865  & 1.8d0,1.7d0,1.4d0,1.2d0, 1.15d0, .9d0, .66d0, .5d0, 7*0.d0, .3d0,
3866  & 2*1.d0, .9d0, .7d0, .4d0, .35d0, .2d0, 9*0.d0, .3d0, 2*1.d0,.9d0,
3867  & .7d0, .4d0, .35d0, .2d0, 11*0.d0, .1d0, 1.d0, 2.4d0,3.5d0,4.25d0,
3868  & 4.55d0, 4.85d0, 4.9d0, 9*0.d0, .1d0, 1.d0, 2.4d0, 3.5d0, 4.25d0,
3869  & 4.55d0, 4.85d0, 4.9d0, 10*0.d0, .2d0, .7d0, 1.6d0, 2.5d0, 2.2d0,
3870  & 1.71d0, 1.6d0, 10*0.d0, .2d0, .7d0, 1.6d0, 2.5d0, 2.2d0, 1.71d0,
3871  & 1.6d0, 6*0.d0, 1.4d0, 3.8d0, 5.d0, 4.7d0,4.4d0,4.d0,3.5d0,2.85d0,
3872  & 2.35d0, 2.01d0, 1.8d0, 6*0.d0, 1.4d0,3.8d0,5.d0,4.7d0,4.4d0,4.d0,
3873  & 3.5d0,2.85d0,2.35d0,2.01d0,1.8d0,12*0.d0,.1d0,.8d0,2.05d0,3.31d0,
3874  & 3.5d0, 12*0.d0, .034d0,.2d0,.75d0,1.04d0,1.24d0 /
3875 **** k- p data *
3876  DATA skmpel/ 0.d0, 35.d0, 22.d0, 25.d0, 17.d0, 9.d0, 9.5d0, 8.d0,
3877  & 7.d0, 6.5d0, 6.1d0, 5.d0, 4.8d0, 4.6d0, 4.45d0, 4.3d0, 4.2d0,
3878  & 0.d0, 8.d0, 3.5d0, 8.d0, 3.d0, 1.9d0, 1.7d0, 1.d0, .9d0, .8d0,
3879  & .75d0, .5d0, .42d0, .38d0, .34d0, .25d0, .2d0,
3880  & 0.d0, 3.d0, 3.2d0, 3.5d0, 1.5d0, 1.4d0, 1.1d0, .6d0, .5d0,
3881  & .35d0, .28d0, .25d0, .18d0, .12d0, .1d0, .08d0, .04d0,
3882  & 0.d0, 8.5d0, 2.4d0, 1.7d0, 1.3d0, 1.3d0, 1.1d0, .5d0,
3883  & .4d0, .4d0, .35d0, .3d0, .28d0, .2d0, .16d0, .13d0, .11d0,
3884  & 0.d0, 7.d0, 4.8d0, 1.4d0, 1.9d0, .9d0, .4d0, .2d0, .13d0,
3885  & .1d0, .08d0, .06d0, .04d0, .02d0, .015d0, .01d0, .01d0,
3886  & 0.d0, 5.5d0, 1.d0, .8d0, .75d0, .32d0, .2d0, .1d0, .09d0,
3887  & .08d0, .065d0, .05d0, .04d0, .022d0, .017d0, 2*.01d0/
3888  DATA spikp7 / 0.d0, .56d0, 1.46d0, 3.16d0, 2.01d0, 1.28d0, .74d0,
3889  & 14*0.d0, 1.13d0, 2.61d0, 2.91d0, 2.58d0, 2.35d0, 2.02d0,
3890  & 1.91d0, 1.57d0, 1.35d0, 1.29d0, 1.01d0, .74d0, .65d0, 4*0.d0,
3891  & 1.13d0, 2.61d0, 2.91d0, 2.58d0, 2.35d0, 2.02d0, 1.91d0, 1.57d0,
3892  & 1.35d0, 1.29d0, 1.01d0, .74d0, .65d0, 3*0.d0, 1.0d0, 3.03d0,
3893  & 3.36d0, 2.8d0, 2.58d0, 2.24d0, 1.91d0, 1.68d0, 1.35d0, 1.01d0,
3894  & .67d0, .5d0, .24d0, .23d0, 3*0.d0, 1.0d0, 3.03d0, 3.36d0, 2.8d0,
3895  & 2.58d0, 2.24d0, 1.91d0, 1.68d0, 1.35d0, 1.01d0, .67d0, .5d0,
3896  & .24d0, .23d0, 7*0.d0, .34d0, 1.12d0, 1.12d0, 1.01d0, .78d0,
3897  & .45d0, .39d0, .22d0, .07d0, 0.d0, 7*0.d0, .34d0, 1.12d0, 1.12d0,
3898  & 1.01d0, .78d0, .45d0, .39d0, .22d0, .07d0, 0.d0, 6*0.d0, 1.71d0,
3899  & 4.26d0, 5.6d0, 5.57d0, 4.93d0, 4.48d0, 3.92d0, 3.19d0, 2.63d0,
3900  & 2.25d0, 2.d0, 6*0.d0, 1.71d0, 4.26d0, 5.6d0, 5.57d0, 4.93d0,
3901  & 4.48d0, 3.92d0, 3.19d0, 2.63d0, 2.25d0, 2.d0, 10*0.d0, .22d0,
3902  & .8d0, .75d0, 1.d0, 1.3d0, 1.5d0, 1.3d0, 10*0.d0, .22d0, .8d0,
3903  & .75d0, 1.d0, 1.3d0, 1.5d0, 1.3d0, 13*0.d0, .1d0, .3d0, .7d0,1.d0,
3904  & 13*0.d0, .1d0, .3d0, .7d0, 1.d0, 9*0.d0, .11d0, 1.72d0, 2.69d0,
3905  & 3.92d0, 4.76d0, 5.10d0, 5.44d0, 5.3d0, 9*0.d0, .11d0, 1.72d0,
3906  & 2.69d0, 3.92d0, 4.76d0, 5.1d0, 5.44d0, 5.3d0, 5*0.d0,9.2d0,4.7d0,
3907  & 1.9d0, 10*0.d0, 2.5d0, 15.d0, 21.5d0, 15.3d0, 3.d0, 1.5d0,
3908  & 10*0.d0/
3909 ***** k- n data *
3910  DATA skmnel/0.d0, 4.d0, 9.5d0, 20.d0, 13.d0, 9.5d0, 6.d0, 4.4d0,
3911  & 3.d0, 2.4d0, 2.d0, 1.4d0, 1.2d0, 1.d0, .9d0, .7d0, .6d0,
3912  & 0.d0, 4.5d0, 6.d0, 5.d0, 2.5d0, 2.d0, 1.7d0, 2.1d0,
3913  & 1.9d0, .9d0, .5d0, .3d0, .24d0, .2d0, .18d0, .1d0, .09d0,
3914  & 0.d0, 1.8d0, 2.d0, 1.1d0, .9d0, .5d0, .5d0, .4d0, .4d0,
3915  & .2d0, .1d0, .06d0, .05d0, .04d0, .03d0, .02d0, .02d0,
3916  & 0.d0, 1.5d0, 2.d0, .9d0, 1.1d0, .4d0, .6d0, .7d0, .65d0,
3917  & .3d0, .17d0, .1d0, .08d0, .07d0, .06d0, .04d0, .03d0/
3918  DATA spikp8/0.d0, .56d0, 1.29d0, 2.26d0, 1.01d0, .64d0, .37d0,
3919  & 14*0.d0, 1.13d0, 2.61d0, 2.91d0, 2.58d0, 2.35d0, 2.02d0,
3920  & 1.91d0, 1.57d0, 1.35d0, 1.29d0, 1.01d0, .74d0, .65d0,
3921  & 3*0.d0, 1.d0, 3.03d0, 3.36d0, 2.8d0, 2.58d0, 2.24d0,
3922  & 1.91d0, 1.68d0, 1.35d0, 1.01d0, .67d0, .5d0, .24d0, .23d0,
3923  & 3*0.d0, 1.d0, 3.03d0, 3.36d0, 2.8d0, 2.58d0, 2.24d0,
3924  & 1.91d0, 1.68d0, 1.35d0, 1.01d0, .67d0, .5d0, .24d0, .23d0,
3925  & 7*0.d0, .34d0, 1.12d0, 1.12d0, 1.01d0, .78d0, .45d0,
3926  & .39d0, .22d0, .07d0, 0.d0,
3927  & 6*0.d0, 1.71d0, 4.26d0, 5.6d0, 5.57d0, 4.93d0,
3928  & 4.48d0, 3.92d0, 3.19d0, 2.63d0, 2.25d0, 2.d0,
3929  & 10*0.d0, .22d0, .8d0, .75d0, 1.d0, 1.3d0, 1.5d0, 1.3d0,
3930  & 13*0.d0, .1d0, .3d0, .7d0, 1.d0,
3931  & 13*0.d0, .1d0, .3d0, .7d0, 1.d0,
3932  & 9*0.d0, .11d0, 1.72d0, 2.69d0, 3.92d0, 4.76d0,
3933  & 5.10d0, 5.44d0, 5.3d0,
3934  & 4*0.d0, 0.00d0, 9.2d0, 4.7d0, 1.9d0, 9*0.d0/
3935 ***** p p data *
3936  DATA spikp9/ 0.d0, 24.d0, 25.d0, 27.d0, 23.d0, 21.d0, 20.d0,
3937  & 19.d0, 17.d0, 15.5d0, 14.d0, 13.5d0, 13.d0,
3938  & 0.d0, 3.6d0, 1.7d0, 10*0.d0,
3939  & .0d0, 0.d0, 8.7d0, 17.7d0, 18.8d0, 15.9d0,
3940  & 11.7d0, 8.d0, 6.d0, 5.3d0, 4.5d0, 3.9d0, 3.5d0,
3941  & .0d0, .0d0, 2.8d0, 5.8d0, 6.2d0, 5.1d0, 3.8d0,
3942  & 2.7d0, 2.1d0, 1.8d0, 1.5d0, 1.3d0, 1.1d0,
3943  & 5*0.d0, 4.6d0, 10.2d0, 15.1d0,
3944  & 16.9d0, 16.5d0, 11.d0, 5.5d0, 3.5d0,
3945  & 10*0.d0, 4.3d0, 7.6d0, 9.d0,
3946  & 10*0.d0, 1.7d0, 2.6d0, 3.d0,
3947  & 6*0.d0, .3d0, .6d0, 1.d0, 1.6d0, 1.3d0, .8d0, .6d0,
3948  & 6*0.d0, .7d0, 1.2d0, 1.8d0, 2.5d0, 1.8d0, 1.3d0,
3949  & 1.2d0, 10*0.d0, .6d0, 1.4d0, 1.7d0,
3950  & 10*0.d0, 1.9d0, 4.1d0, 5.2d0/
3951 ***** p n data *
3952  DATA spikp0/ 0.d0, 24.d0, 25.d0, 27.d0, 23.d0, 21.d0, 20.d0,
3953  & 19.d0, 17.d0, 15.5d0, 14.d0, 13.5d0, 13.d0,
3954  & 0.d0, 1.8d0, .2d0, 12*0.d0,
3955  & 3.2d0, 6.05d0, 9.9d0, 5.1d0,
3956  & 3.8d0, 2.7d0, 1.9d0, 1.5d0, 1.4d0, 1.3d0, 1.1d0,
3957  & 2*.0d0, 3.2d0, 6.05d0, 9.9d0, 5.1d0,
3958  & 3.8d0, 2.7d0, 1.9d0, 1.5d0, 1.4d0, 1.3d0, 1.1d0,
3959  & 5*0.d0, 4.6d0, 10.2d0, 15.1d0,
3960  & 16.4d0, 15.2d0, 11.d0, 5.4d0, 3.5d0,
3961  & 5*0.d0, 4.6d0, 10.2d0, 15.1d0,
3962  & 16.4d0, 15.2d0, 11.d0, 5.4d0, 3.5d0,
3963  & 10*0.d0, .7d0, 5.1d0, 8.d0,
3964  & 10*0.d0, .7d0, 5.1d0, 8.d0,
3965  & 10*.0d0, .3d0, 2.8d0, 4.7d0,
3966  & 10*.0d0, .3d0, 2.8d0, 4.7d0,
3967  & 7*0.d0, 1.2d0, 2.5d0, 3.5d0, 6.d0, 5.3d0, 2.9d0,
3968  & 7*0.d0, 1.7d0, 3.6d0, 5.4d0, 9.d0, 7.6d0, 4.2d0,
3969  & 5*0.d0, 7.7d0, 6.1d0, 2.9d0, 5*0.d0/
3970 * nn - data *
3971 * *
3972  DATA spkp v/ 0.d0, 24.d0, 25.d0, 27.d0, 23.d0, 21.d0, 20.d0,
3973  & 19.d0, 17.d0, 15.5d0, 14.d0, 13.5d0, 13.d0,
3974  & 0.d0, 3.6d0, 1.7d0, 12*0.d0,
3975  & 8.7d0, 17.7d0, 18.8d0, 15.9d0,
3976  & 11.7d0, 8.d0, 6.d0, 5.3d0, 4.5d0, 3.9d0, 3.5d0,
3977  & .0d0, .0d0, 2.8d0, 5.8d0, 6.2d0, 5.1d0, 3.8d0,
3978  & 2.7d0, 2.1d0, 1.8d0, 1.5d0, 1.3d0, 1.1d0,
3979  & 5*0.d0, 4.6d0, 10.2d0, 15.1d0, 16.9d0, 16.5d0,
3980  & 11.d0, 5.5d0, 3.5d0,
3981  & 10*0.d0, 4.3d0, 7.6d0, 9.d0,
3982  & 10*0.d0, 1.7d0, 2.6d0, 3.d0,
3983  & 6*0.d0, .3d0, .6d0, 1.d0, 1.6d0, 1.3d0, .8d0, .6d0,
3984  & 6*0.d0, .7d0, 1.2d0, 1.8d0, 2.5d0, 1.8d0, 1.3d0,
3985  & 1.2d0, 10*0.d0, .6d0, 1.4d0, 1.7d0,
3986  & 10*0.d0, 1.9d0, 4.1d0, 5.2d0/
3987 **************** ap - p - data *
3988  DATA sappel/ 0.d0, 176.d0, 160.d0, 105.d0, 75.d0, 68.d0, 65.d0,
3989  & 50.d0, 50.d0, 43.d0, 42.d0, 40.5d0, 35.d0, 30.d0, 28.d0,
3990  & 25.d0, 22.d0, 21.d0, 20.d0, 18.d0, 17.d0, 11*0.d0,
3991  & .05d0, .15d0, .18d0, .2d0, .2d0, .3d0, .4d0, .6d0, .7d0, .85d0,
3992  & 0.d0, 1.d0, .9d0, .46d0, .3d0, .23d0, .18d0, .16d0, .14d0,
3993  & .1d0, .08d0, .05d0, .02d0, .015d0, 4*.011d0, 3*.005d0,
3994  & 0.d0, 55.d0, 50.d0, 25.d0, 15.d0, 15.d0, 14.d0, 12.d0,
3995  & 10.d0, 7.d0, 6.d0, 4.d0, 3.3d0, 2.8d0, 2.4d0, 2.d0, 1.8d0,
3996  & 1.55d0, 1.3d0, .95d0, .75d0,
3997  & 0.d0, 3.3d0, 3.d0, 1.5d0, 1.d0, .7d0, .4d0, .35d0, .4d0,
3998  & .25d0, .18d0, .08d0, .04d0, .03d0, .023d0, .016d0, .014d0,
3999  & .01d0, .008d0, .006d0, .005d0/
4000  DATA spikpe/0.d0, 215.d0, 193.d0, 170.d0, 148.d0, 113.d0, 97.d0,
4001  & 84.d0, 78.d0, 68.d0, 64.d0, 61.d0, 46.d0, 36.d0, 31.3d0, 28.5d0,
4002  & 25.7d0, 22.6d0, 21.4d0, 20.7d0, 19.9d0,
4003  & 9*0.d0, 2.d0, 2.5d0, .2d0, 19*0.d0, .3d0, 1.4d0, 2.2d0, 1.2d0,
4004  & 1.1d0, 1.d0, .8d0, .6d0, .5d0, .4d0, .3d0, 10*0.d0, .3d0, 1.4d0,
4005  & 2.2d0, 1.2d0, 1.1d0, 1.d0, .8d0, .6d0, .5d0, .4d0, .3d0, 10*0.d0,
4006  & .3d0, 1.4d0, 2.2d0, 1.2d0, 1.1d0, 1.d0, .8d0, .6d0, .5d0, .4d0,
4007  & .3d0, 10*0.d0, .3d0, 1.4d0, 2.2d0, 1.2d0, 1.1d0, 1.d0, .8d0,
4008  & .6d0, .5d0, .4d0, .3d0, 9*0.d0, .6d0, 2.5d0, 5.d0, 5.2d0, 5.1d0,
4009  & 5.4d0, 5.8d0, 2.8d0, 2.1d0, 1.8d0, 1.6d0, 1.2d0, 13*0.d0, 1.3d0,
4010  & 1.5d0, 2.d0, 2.5d0, 2.5d0, 2.3d0, 1.8d0, 1.4d0, 13*0.d0, 1.3d0,
4011  & 1.5d0, 2.d0, 2.5d0, 2.5d0, 2.3d0, 1.8d0, 1.4d0, 13*0.d0, 1.3d0,
4012  & 1.5d0, 2.d0, 2.5d0, 2.5d0, 2.3d0, 1.8d0, 1.4d0, 13*0.d0, 1.3d0,
4013  & 1.5d0, 2.d0, 2.5d0, 2.5d0, 2.3d0, 1.8d0, 1.4d0, 14*0.d0, .2d0,
4014  & .5d0, 1.1d0, 1.6d0, 1.4d0, 1.1d0, .9d0, 14*0.d0, .2d0, .5d0,
4015  & 1.1d0, 1.6d0, 1.4d0, 1.1d0, .9d0, 14*0.d0, .2d0, .5d0, 1.1d0,
4016  & 1.6d0, 1.4d0, 1.1d0, .9d0, 14*0.d0, .2d0, .5d0, 1.1d0, 1.6d0,
4017  & 1.4d0, 1.1d0, .9d0, 17*0.d0, .3d0, 1.6d0, 2.6d0, 3.6d0, 17*0.d0,
4018  & .3d0, 1.6d0, 2.6d0, 3.6d0, 17*0.d0, .3d0, 1.6d0, 2.6d0,
4019  & 3.6d0, 17*0.d0, .3d0, 1.6d0, 2.6d0, 3.6d0 /
4020 **************** ap - n - data *
4021  DATA sapnel/
4022  & 0.d0, 176.d0, 160.d0, 105.d0, 75.d0, 68.d0, 65.d0,
4023  & 50.d0, 50.d0, 43.d0, 42.d0, 40.5d0, 35.d0, 30.d0, 28.d0,
4024  & 25.d0, 22.d0, 21.d0, 20.d0, 18.d0, 17.d0, 11*0.d0,
4025  & .05d0, .15d0, .18d0, .2d0, .2d0, .3d0, .4d0, .6d0, .7d0,
4026  & .85d0, 0.d0, 1.d0, .9d0, .46d0, .3d0, .23d0, .18d0, .16d0,
4027  & .14d0, .1d0, .08d0, .05d0, .02d0, .015d0, 4*.011d0, 3*.005d0,
4028  & 0.d0, 3.3d0, 3.d0, 1.5d0, 1.d0, .7d0, .4d0, .35d0, .4d0,
4029  & .25d0, .18d0, .08d0, .04d0, .03d0, .023d0, .016d0, .014d0,
4030  & .01d0, .008d0, .006d0, .005d0 /
4031  DATA spikpz/ 0.d0, 215.d0, 193.d0, 170.d0, 148.d0, 113.d0, 97.d0,
4032  & 84.d0, 78.d0, 68.d0, 64.d0, 61.d0, 46.d0, 36.d0, 31.3d0, 28.5d0,
4033  & 25.7d0, 22.6d0, 21.4d0, 20.7d0, 19.9d0, 9*0.d0, 2.4d0, .2d0,
4034  & 20*0.d0, 1.8d0, 2.8d0, 3.6d0, 2.3d0, 1.8d0, 1.5d0, 1.3d0, 1.d0,
4035  & .7d0, .5d0, .3d0, 10*0.d0, 1.8d0, 2.8d0, 3.6d0, 2.3d0, 1.8d0,
4036  & 1.5d0, 1.3d0, 1.d0, .7d0, .5d0, .3d0, 10*0.d0, 1.8d0, 2.8d0,
4037  & 3.6d0, 2.3d0, 1.8d0, 1.5d0, 1.3d0, 1.d0, .7d0, .5d0, .3d0,
4038  & 10*0.d0, 1.8d0, 2.8d0, 3.6d0, 2.3d0, 1.8d0, 1.5d0, 1.3d0, 1.d0,
4039  & .7d0, .5d0, .3d0, 13*0.d0, 5.2d0, 8.7d0, 11.4d0, 14.d0, 11.9d0,
4040  & 7.6d0, 6.d0, 5.d0, 13*0.d0, 5.2d0, 8.7d0, 11.4d0, 14.d0, 11.9d0,
4041  & 7.6d0, 6.d0, 5.d0, 18*0.d0, 1.d0, 4.9d0, 8.5d0, 18*0.d0, 1.d0,
4042  & 4.9d0, 8.5d0, 15*0.d0, 1.9d0, 2.3d0, 4.d0, 6.5d0, 5.2d0, 3.4d0,
4043  & 15*0.d0, 1.9d0, 2.3d0, 4.d0, 6.5d0, 5.2d0, 3.4d0, 15*0.d0, 1.9d0,
4044  & 2.3d0, 4.d0, 6.5d0, 5.2d0, 3.4d0 /
4045 * *
4046 * *
4047 **************** an - p - data *
4048 * *
4049  DATA sanpel/
4050  & 0.d0, 176.d0, 160.d0, 105.d0, 75.d0, 68.d0, 65.d0, 50.d0,
4051  & 50.d0, 43.d0, 42.d0, 40.5d0, 35.d0, 30.d0, 28.d0,
4052  & 25.d0, 22.d0, 21.d0, 20.d0, 18.d0, 17.d0, 11*0.d0, .05d0,
4053  & .15d0, .18d0, .2d0, .2d0, .3d0, .4d0, .6d0, .7d0, .85d0,
4054  & 0.d0, 1.d0, .9d0, .46d0, .3d0, .23d0, .18d0, .16d0, .14d0,
4055  & .1d0, .08d0, .05d0, .02d0, .015d0, 4*.011d0, 3*.005d0,
4056  & 0.d0, 3.3d0, 3.d0, 1.5d0, 1.d0, .7d0, .4d0, .35d0, .4d0, .25d0,
4057  & .18d0, .08d0, .04d0, .03d0, .023d0, .016d0, .014d0,
4058  & .01d0, .008d0, .006d0, .005d0 /
4059  DATA spikpf/ 0.d0, 215.d0, 193.d0, 170.d0, 148.d0, 113.d0, 97.d0,
4060  & 84.d0, 78.d0, 68.d0, 64.d0, 61.d0, 46.d0, 36.d0, 31.3d0, 28.5d0,
4061  & 25.7d0, 22.6d0, 21.4d0, 20.7d0, 19.9d0, 9*0.d0, 2.4d0, .2d0,
4062  & 20*0.d0, 1.8d0, 2.8d0, 3.6d0, 2.3d0, 1.8d0, 1.5d0, 1.3d0, 1.d0,
4063  & .7d0, .5d0, .3d0, 10*0.d0, 1.8d0, 2.8d0, 3.6d0, 2.3d0, 1.8d0,
4064  & 1.5d0, 1.3d0, 1.d0, .7d0, .5d0, .3d0, 10*0.d0, 1.8d0, 2.8d0,
4065  & 3.6d0, 2.3d0, 1.8d0, 1.5d0, 1.3d0, 1.d0, .7d0, .5d0, .3d0,
4066  & 10*0.d0, 1.8d0, 2.8d0, 3.6d0, 2.3d0, 1.8d0, 1.5d0, 1.3d0, 1.d0,
4067  & .7d0, .5d0, .3d0, 13*0.d0, 5.2d0, 8.7d0, 11.4d0, 14.d0, 11.9d0,
4068  & 7.6d0, 6.d0, 5.d0, 13*0.d0, 5.2d0, 8.7d0, 11.4d0, 14.d0, 11.9d0,
4069  & 7.6d0, 6.d0, 5.d0, 18*0.d0, 1.d0, 4.9d0, 8.5d0, 18*0.d0, 1.d0,
4070  & 4.9d0, 8.5d0, 15*0.d0, 1.9d0, 2.3d0, 4.d0, 6.5d0, 5.2d0, 3.4d0,
4071  & 15*0.d0, 1.9d0, 2.3d0, 4.d0, 6.5d0, 5.2d0, 3.4d0, 15*0.d0, 1.9d0,
4072  & 2.3d0, 4.d0, 6.5d0, 5.2d0, 3.4d0 /
4073 **** ko - n - data *
4074  DATA spkp15/0.d0, 20.d0, 14.d0, 12.d0, 11.5d0, 10.d0, 8.d0, 7.d0,
4075  & 6.d0, 5.5d0, 5.3d0, 5.d0, 4.5d0, 4.4d0, 3.8d0, 3.d0, 2.8d0,
4076  & 0.d0, .5d0, 1.15d0, 2.d0, 1.3d0, .8d0, .45d0, 10*0.d0,
4077  & 3*0.d0, 0.9d0, 2.5d0, 3.d0, 2.5d0, 2.3d0, 2.d0, 1.7d0,
4078  & 1.5d0, 1.2d0, .9d0, .6d0, .45d0, .21d0, .2d0,
4079  & 3*0.d0, 0.9d0, 2.5d0, 3.d0, 2.5d0, 2.3d0, 2.d0, 1.7d0,
4080  & 1.5d0, 1.2d0, .9d0, .6d0, .45d0, .21d0, .2d0,
4081  & 4*0.d0, 1.d0, 2.1d0, 2.6d0, 2.3d0, 2.1d0, 1.8d0, 1.7d0,
4082  & 1.4d0, 1.2d0, 1.05d0, .9d0, .66d0, .5d0,
4083  & 7*0.d0, .3d0, 1.d0, 1.d0, .9d0, .7d0, .4d0, .30d0, .2d0,
4084  & 11*0.d0, .1d0, 1.d0, 2.2d0, 3.5d0, 4.20d0, 4.55d0,
4085  & 4.85d0, 4.9d0,
4086  & 10*0.d0, .2d0, .7d0, 1.6d0, 2.5d0, 2.2d0, 1.71d0, 1.6d0,
4087  & 6*0.d0, 1.4d0, 3.8d0, 5.d0, 4.7d0, 4.4d0, 4.d0, 3.5d0,
4088  & 2.85d0, 2.35d0, 2.01d0, 1.8d0,
4089  & 12*0.d0, .1d0, .8d0, 2.05d0, 3.31d0, 3.5d0,
4090  & 12*0.d0, .034d0, .20d0, .75d0, 1.04d0, 1.24d0 /
4091 **** ako - p - data *
4092  DATA spkp16/ 0.d0, 4.d0, 9.5d0, 20.d0, 13.d0, 9.5d0, 6.d0, 4.4d0,
4093  & 3.d0, 2.4d0, 2.d0, 1.4d0, 1.2d0, 1.d0, .9d0, .7d0, .6d0, 0.d0,
4094  & 4.5d0, 6.d0, 5.d0, 2.5d0, 2.d0, 1.7d0, 2.1d0, 1.9d0, .9d0, .5d0,
4095  & .3d0, .24d0, .2d0, .18d0, .1d0, .09d0, 0.d0, 1.8d0, 2.d0, 1.1d0,
4096  & .9d0, .5d0, .5d0, .4d0, .4d0, .2d0, .1d0, .06d0, .05d0, .04d0,
4097  & .03d0, .02d0, .02d0, 0.d0, 1.5d0, 2.d0, .9d0, 1.1d0, .4d0, .6d0,
4098  & .7d0, .65d0, .3d0, .17d0, .1d0, .08d0, .07d0, .06d0, .04d0,
4099  & .03d0, 0.d0, .56d0, 1.29d0, 2.26d0, 1.01d0, .64d0, .37d0,
4100  & 14*0.d0, 1.13d0, 2.61d0, 2.91d0, 2.58d0, 2.35d0, 2.02d0, 1.91d0,
4101  & 1.57d0, 1.35d0, 1.29d0, 1.01d0, .74d0, .65d0, 3*0.d0, 1.0d0,
4102  & 3.03d0, 3.36d0, 2.8d0, 2.58d0, 2.24d0, 1.91d0, 1.68d0, 1.35d0,
4103  & 1.01d0, .67d0, .5d0, .24d0, .23d0, 3*0.d0, 1.0d0, 3.03d0, 3.36d0,
4104  & 2.8d0, 2.58d0, 2.24d0, 1.91d0, 1.68d0, 1.35d0, 1.01d0, .67d0,
4105  & .5d0, .24d0, .23d0, 7*0.d0, .34d0, 1.12d0, 1.12d0, 1.01d0, .78d0,
4106  & .45d0, .39d0, .22d0, .07d0, 7*0.d0, 1.71d0, 4.26d0, 5.6d0,5.57d0,
4107  & 4.93d0, 4.48d0, 3.92d0, 3.19d0, 2.63d0, 2.25d0, 2.d0, 10*0.d0,
4108  & .22d0, .8d0, .75d0, 1.d0, 1.3d0, 1.5d0, 1.3d0, 13*0.d0, .1d0,
4109  & .3d0, .7d0, 1.d0, 13*0.d0, .1d0, .3d0, .7d0, 1.d0, 9*0.d0, .11d0,
4110  & 1.72d0, 2.69d0, 3.92d0, 4.76d0, 5.10d0, 5.44d0, 5.3d0, 5*0.d0,
4111  & 9.2d0, 4.7d0, 1.9d0, 9*0.d0, .0d0,2.5d0,15.d0,
4112  & 21.5d0, 15.3d0, 3.d0, 1.5d0, 10*0.d0 /
4113  DATA nureln/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
4114  & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
4115 *= end*block.blkdt3 *
4116  END
4117 
4118 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4119  BLOCK DATA reacch
4120  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4121 C*** REACTION CHANNEL CROSS SECTION DATA
4122 C INTEGER * 2
4123 C * NRKPI,NRKKC,NRKK0,NRKP,NRKN
4124 C * ,NURE
4125  COMMON /dreacc/
4126  *umopi( 92),umokc( 68),umop( 39),umon( 63),umok0( 34),
4127  *plapi( 92),plakc( 68),plap( 39),plan( 63),plak0( 34),
4128  *siin(296),
4129  *spikp1( 315),spikp u(278),spikp v(372),
4130  *spikp w(278),spikp x(372),spikp 4(315),
4131  *spikp 5(187),spikp 6(306),
4132  *s kmpel(102),spikp 7(289),s kmnel( 68),spikp 8(187),
4133  *spikp 9(143),spikp 0(169),spkp v(143),
4134  *s appel(105),spikp e(399),s apnel( 84),spikp z(273),
4135  *s anpel( 84),spikp f(273),
4136  *spkp15(187),spkp16(255),
4137  *nrkpi( 164),nrkkc( 134),nrkp( 70),nrkn( 116),nrkk0( 52),
4138  *nure(60)
4139 C111111111111111111111111111111111111111111111111111111111111111111
4140 *
4141 **** pi- p data *
4142 **** pi+ n data *
4143  DATA plapi / 0.d0, .3d0, .5d0, .6d0, .7d0, .8d0, .9d0, .95d0,1.d0,
4144  & 1.15d0, 1.3d0, 1.5d0, 1.6d0, 1.8d0, 2.d0, 2.3d0, 2.5d0, 2.8d0,
4145  & 3.d0, 3.5d0, 4.d0, 0.d0, .285d0, .4d0, .45d0, .5d0, .6d0, .7d0,
4146  & .75d0, .8d0, .85d0, .9d0, 1.d0, 1.15d0, 1.3d0, 1.5d0, 1.6d0,
4147  & 1.8d0, 2.d0, 2.3d0, 2.5d0, 2.8d0, 3.d0, 3.5d0, 4.d0, 4.5d0, 0.d0,
4148  & .285d0, .4d0, .45d0, .5d0, .6d0, .7d0, .75d0, .8d0, .85d0, .9d0,
4149  & 1.d0, 1.15d0, 1.3d0, 1.5d0, 1.6d0, 1.8d0, 2.d0, 2.3d0, 2.5d0,
4150  & 2.8d0, 3.d0, 3.5d0, 4.d0, 4.5d0, 0.d0, .3d0, .5d0, .6d0, .7d0,
4151  & .8d0, .9d0, .95d0, 1.d0, 1.15d0, 1.3d0, 1.5d0, 1.6d0, 1.8d0,
4152  & 2.d0, 2.3d0, 2.5d0, 2.8d0, 3.d0, 3.5d0, 4.d0 /
4153  DATA plakc /
4154  & 0.d0, .58d0, .8d0, 1.01d0, 1.23d0, 1.45d0, 1.68d0, 1.94d0,
4155  & 2.18d0, 2.42d0, 2.68d0, 2.96d0, 3.24d0,
4156  & 3.51d0, 3.84d0, 4.16d0, 4.49d0,
4157  & 0.d0, .58d0, .8d0, 1.01d0, 1.23d0, 1.45d0, 1.68d0, 1.94d0,
4158  & 2.18d0, 2.42d0, 2.68d0, 2.96d0, 3.24d0,
4159  & 3.51d0, 3.84d0, 4.16d0, 4.49d0,
4160  & 0.d0, .58d0, .8d0, 1.01d0, 1.23d0, 1.45d0, 1.68d0, 1.94d0,
4161  & 2.18d0, 2.42d0, 2.68d0, 2.96d0, 3.24d0,
4162  & 3.51d0, 3.84d0, 4.16d0, 4.49d0,
4163  & 0.d0, .58d0, .8d0, 1.01d0, 1.23d0, 1.45d0, 1.68d0, 1.94d0,
4164  & 2.18d0, 2.42d0, 2.68d0, 2.96d0, 3.24d0,
4165  & 3.51d0, 3.84d0, 4.16d0, 4.49d0/
4166  DATA plak0 /
4167  & 0.d0, .58d0, .8d0, 1.01d0, 1.23d0, 1.45d0, 1.68d0, 1.94d0,
4168  & 2.18d0, 2.42d0, 2.68d0, 2.96d0, 3.24d0,
4169  & 3.51d0, 3.84d0, 4.16d0, 4.49d0,
4170  & 0.d0, .58d0, .8d0, 1.01d0, 1.23d0, 1.45d0, 1.68d0, 1.94d0,
4171  & 2.18d0, 2.42d0, 2.68d0, 2.96d0, 3.24d0,
4172  & 3.51d0, 3.84d0, 4.16d0, 4.49d0/
4173 * pp pn np nn *
4174  DATA plap /
4175  & 0.d0, 1.06d0, 1.34d0, 1.63d0, 1.92d0, 2.2d0, 2.5d0,2.8d0,3.1d0,
4176  & 3.43d0, 3.75d0, 4.07d0, 4.43d0,
4177  & 0.d0, 1.06d0, 1.34d0, 1.63d0, 1.92d0, 2.2d0, 2.5d0,2.8d0,3.1d0,
4178  & 3.43d0, 3.75d0, 4.07d0, 4.43d0,
4179  & 0.d0, 1.06d0, 1.34d0, 1.63d0, 1.92d0, 2.2d0, 2.5d0,2.8d0,3.1d0,
4180  & 3.43d0, 3.75d0, 4.07d0, 4.43d0 /
4181 * app apn anp ann *
4182  DATA plan /
4183  & 0.d0, 1.d-3, .1d0, .2d0, .3d0, .4d0, .5d0, .6d0,
4184  & .74d0, 1.06d0, 1.34d0, 1.63d0, 1.92d0, 2.2d0, 2.5d0,2.8d0,3.1d0,
4185  & 3.43d0, 3.75d0, 4.07d0, 4.43d0,
4186  & 0.d0, 1.d-3, .1d0, .2d0, .3d0, .4d0, .5d0, .6d0,
4187  & .74d0, 1.06d0, 1.34d0, 1.63d0, 1.92d0, 2.2d0, 2.5d0,2.8d0,3.1d0,
4188  & 3.43d0, 3.75d0, 4.07d0, 4.43d0,
4189  & 0.d0, 1.d-3, .1d0, .2d0, .3d0, .4d0, .5d0, .6d0,
4190  & .74d0, 1.06d0, 1.34d0, 1.63d0, 1.92d0, 2.2d0, 2.5d0,2.8d0,3.1d0,
4191  & 3.43d0, 3.75d0, 4.07d0, 4.43d0 /
4192  DATA siin / 296*0.d0 /
4193  DATA umopi/ 1.08d0,1.233d0,1.302d0,1.369d0,1.496d0,
4194  & 1.557d0,1.615d0,1.6435d0,
4195  & 1.672d0,1.753d0,1.831d0,1.930d0,1.978d0,2.071d0,2.159d0,
4196  & 2.286d0,2.366d0,2.482d0,2.56d0,
4197  & 2.735d0,2.90d0,
4198  & 1.08d0,1.222d0,1.302d0,1.3365d0,1.369d0,1.434d0,
4199  & 1.496d0,1.527d0,1.557d0,
4200  & 1.586d0,1.615d0,1.672d0,1.753d0,1.831d0,1.930d0,1.978d0,
4201  & 2.071d0,2.159d0,2.286d0,2.366d0,
4202  & 2.482d0,2.560d0,2.735d0,2.90d0,3.06d0,
4203  & 1.08d0,1.222d0,1.302d0,1.3365d0,1.369d0,1.434d0,
4204  & 1.496d0,1.527d0,1.557d0,
4205  & 1.586d0,1.615d0,1.672d0,1.753d0,1.831d0,1.930d0,1.978d0,
4206  & 2.071d0,2.159d0,2.286d0,2.366d0,
4207  & 2.482d0,2.560d0,2.735d0,2.90d0,3.06d0,
4208  & 1.08d0,1.233d0,1.302d0,1.369d0,1.496d0,
4209  & 1.557d0,1.615d0,1.6435d0,
4210  & 1.672d0,1.753d0,1.831d0,1.930d0,1.978d0,2.071d0,2.159d0,
4211  & 2.286d0,2.366d0,2.482d0,2.56d0,
4212  & 2.735d0, 2.90d0/
4213  DATA umokc/ 1.44d0,
4214  & 1.598d0,1.7d0,1.8d0,1.9d0,2.0d0,2.1d0,2.2d0,2.3d0,2.4d0,2.5d0,
4215  & 2.6d0,2.7d0,2.8d0,2.9d0,3.0d0,
4216  & 3.1d0,1.44d0,
4217  & 1.598d0,1.7d0,1.8d0,1.9d0,2.0d0,2.1d0,2.2d0,2.3d0,2.4d0,2.5d0,
4218  & 2.6d0,2.7d0,2.8d0,2.9d0,3.0d0,
4219  & 3.1d0,1.44d0,
4220  & 1.598d0,1.7d0,1.8d0,1.9d0,2.0d0,2.1d0,2.2d0,2.3d0,2.4d0,2.5d0,
4221  & 2.6d0,2.7d0,2.8d0,2.9d0,3.0d0,
4222  & 3.1d0,1.44d0,
4223  & 1.598d0,1.7d0,1.8d0,1.9d0,2.0d0,2.1d0,2.2d0,2.3d0,2.4d0,2.5d0,
4224  & 2.6d0,2.7d0,2.8d0,2.9d0,3.0d0,
4225  & 3.1d0/
4226  DATA umok0/ 1.44d0,
4227  & 1.598d0,1.7d0,1.8d0,1.9d0,2.0d0,2.1d0,2.2d0,2.3d0,2.4d0,2.5d0,
4228  & 2.6d0,2.7d0,2.8d0,2.9d0,3.0d0,
4229  & 3.1d0,1.44d0,
4230  & 1.598d0,1.7d0,1.8d0,1.9d0,2.0d0,2.1d0,2.2d0,2.3d0,2.4d0,2.5d0,
4231  & 2.6d0,2.7d0,2.8d0,2.9d0,3.0d0,
4232  & 3.1d0/
4233 * pp pn np nn *
4234  DATA umop/
4235  & 1.88d0,2.102d0,2.2d0,2.3d0,2.4d0,2.5d0,2.6d0,2.7d0,2.8d0,2.9d0,
4236  & 3.d0,3.1d0,3.2d0,
4237  & 1.88d0,2.102d0,2.2d0,2.3d0,2.4d0,2.5d0,2.6d0,2.7d0,2.8d0,2.9d0,
4238  & 3.d0,3.1d0,3.2d0,
4239  & 1.88d0,2.102d0,2.2d0,2.3d0,2.4d0,2.5d0,2.6d0,2.7d0,2.8d0,2.9d0,
4240  & 3.d0,3.1d0,3.2d0/
4241 * app apn anp ann *
4242  DATA umon /
4243  & 1.877d0,1.87701d0,1.879d0,1.887d0,1.9d0,1.917d0,1.938d0,1.962d0,
4244  & 2.d0,2.102d0,2.2d0,2.3d0,2.4d0,2.5d0,2.6d0,2.7d0,2.8d0,2.9d0,
4245  & 3.d0,3.1d0,3.2d0,
4246  & 1.877d0,1.87701d0,1.879d0,1.887d0,1.9d0,1.917d0,1.938d0,1.962d0,
4247  & 2.d0,2.102d0,2.2d0,2.3d0,2.4d0,2.5d0,2.6d0,2.7d0,2.8d0,2.9d0,
4248  & 3.d0,3.1d0,3.2d0,
4249  & 1.877d0,1.87701d0,1.879d0,1.887d0,1.9d0,1.917d0,1.938d0,1.962d0,
4250  & 2.d0,2.102d0,2.2d0,2.3d0,2.4d0,2.5d0,2.6d0,2.7d0,2.8d0,2.9d0,
4251  & 3.d0,3.1d0,3.2d0/
4252 
4253 C111111111111111111111111111111111111111111111111111111111111111111
4254 C111111111111111111111111111111111111111111111111111111111111111111
4255 C*** REACTION CAHNNEL STATE PARTICLES
4256  DATA nrk pi/
4257  *13,1,15,21,81,0,
4258  *13,54,23,53,13,63,13,58,23,57,13,65,1,32,53,31,54,32,53,33,53,35,
4259  *63,32,
4260  *13,8,23,1,17,15,21,24,22,15,82,0,
4261  *61,0,13,55,23,54,14,53,13,64,
4262  *23,63,13,59,23,58,14,57,13,66,23,65,1,31,8,32,1,33,1,35,54,31,55,
4263  *32,54,33,53,34,54,35,
4264  *14,1,23,8,17,24,20,15,22,24,83,0,
4265  *62,0,14,54,23,55,13,56,14,63,
4266  *23,64,14,58,23,59,13,60,14,65,23,66,8,31,1,34,8,33,8,35,55,31,54,
4267  *34,55,33,56,32,55,35,
4268  *14,8,24,20,84,0,
4269  *14,55,23,56,14,64,14,59,23,60,14,66,8,34,56,31,55,34,56,33,56,35,
4270  *64,34
4271  f/
4272  DATA nrk kc/
4273  *15,1,89,0,
4274  *24,53,15,54,1,36,1,40,1,44,36,63,15,63,45,53,44,54,
4275  *15,8,24,1,91,0,
4276  *24,54,15,55,8,36,1,37,8,40,1,41,8,44,1,45,36,64,37,63,15,64,24,63,
4277  *45,54,44,55,93,0,
4278  *16,1,25,8, 17,23,21,14, 20,13,22,23, 90,0,
4279  *38,1,39,8,16,54,25,55,1,42,8,43,16,63,25,64,39,64,38,63,46,54,
4280  *47,55,8,47,1,46,52,0,51,0,
4281  *16,8,17,14,20,23,22,14,92,0,
4282  *8,38,16,55,25,56,8,42,16,64,38,64,46,55,47,56,8,46,94,0
4283  */
4284 C
4285 C K0 P K0 N AK0 P AK/ N
4286 C
4287  DATA nrk k0/
4288  *24,8,
4289  *106,0,15,56,24,55,37,8,41,8,45,8,37,64,24,64,44,56,45,55,
4290  *25,1,17,13, 22,13,21,23,
4291  *107,0,39,1,25,54,16,53,43,1,25,63,39,63,47,54,46,53,47,1,103,0/
4292 C PP PN NP NN
4293  DATA nrk p/1,1,85,0,
4294  f8,53,1,54,1,63,8,57,1,58,54,54,53,55,63,54,64,53,
4295  *1,8,86,0,
4296  f8,54,1,55,8,63,1,64,8,58,1,59,64,54,63,55,54,55,53,56,77,0,
4297  *8,8,
4298  *95,0,8,55,1,56,8,64,8,59,1,60,55,55,54,56,64,55,63,56/
4299 C APP APN ANP ANN
4300  DATA nrk n/ 1,2,17,18,15,16,8,9,13,14,99,0,87,0, 1,68,8,69,2,54,9,
4301  +55,102,0, 2,63,9,64,1,75,8,76,53,67,54,68, 55,69,56,70,63,68,64,
4302  +69,75,54,76,55, 2,8,18,20, 16,24,14,23, 101,0,88,0, 2,55,9,56,1,
4303  +67,8,68,2,64,8,75,2,59,8,72,68,55,67,54,69,56, 1,9,18,21,15,25,13,
4304  +23,100,0, 96,0,2,53,9,54,1,69,8,70,1,76,9,63,1,73,9,58,55,70,53,
4305  +68,54,69/
4306 C222222222222222222222222222222222222222222222222222222222222222222222
4307 **** channel cross section *
4308  DATA spikp1/ 0.d0, 300.d0, 40.d0, 20.d0, 13.d0,8.5d0,8.d0, 9.5d0,
4309  & 12.d0,14.d0,15.5d0,20.d0,17.d0,13.d0,10.d0,9.d0,8.5d0,8.d0,7.8d0,
4310  & 7.3d0, 6.7d0, 9*0.d0,.23d0,.35d0,.7d0,.52d0,.4d0,.3d0,.2d0,.15d0,
4311  & .13d0, .11d0, .09d0, .07d0, 0.d0, .033d0,.8d0,1.35d0,1.35d0,.5d0,
4312  & 15*0.d0, 3*0.d0,.00d0,0.80d0,2.2d0,3.6d0,4.6d0,4.7d0,3.5d0,2.4d0,
4313  &1.8d0,1.4d0,.75d0,.47d0,.25d0,.13d0,.08d0,6*0.d0,0.d0,1.2d0,3.3d0,
4314  & 5.4d0,6.9d0,7.3d0,5.3d0,3.6d0,2.7d0,2.2d0,1.1d0,.73d0,.4d0,.22d0,
4315  & .12d0,9*0.d0,.0d0,0.d0,2.0d0,4.4d0,6.8d0,9.9d0,7.9d0,6.0d0,3.8d0,
4316  &2.5d0,2.d0,1.4d0,1.d0,.6d0,.35d0,10*0.d0,.25d0,.55d0,.75d0,1.25d0,
4317  & 1.9d0,2.d0,1.8d0,1.5d0,1.25d0,1.d0,.8d0,6*0.d0,4*0.d0,.4d0,.85d0,
4318  & 1.1d0, 1.85d0, 2.8d0, 3.d0,2.7d0,2.2d0,1.85d0,1.5d0,1.2d0,6*0.d0,
4319  & 6*0.d0, .5d0, 1.2d0, 1.7d0, 3.4d0, 5.2d0, 6.4d0, 6.1d0, 5.6d0,
4320  & 5.2d0, 6*0.d0, 2*0.d0, .0d0, 1.d0, 3.3d0, 5.2d0, 4.45d0, 3.6d0,
4321  & 2.75d0, 1.9d0, 1.65d0, 1.3d0, .95d0, .6d0, .45d0, 6*0.d0, 3*0.d0,
4322  & .0d0, .45d0, 1.4d0, 1.5d0, 1.1d0, .85d0, .5d0, .3d0, .2d0, .15d0,
4323  & 8*0.d0, 5*0.d0, .0d0, .0d0, .6d0, .8d0, .95d0, .8d0, .7d0, .6d0,
4324  & .5d0, .4d0, 6*0.d0, 5*0.d0, .0d0, .00d0, .85d0, 1.2d0, 1.4d0,
4325  & 1.2d0, 1.05d0, .9d0, .7d0, .55d0, 6*0.d0, 5*0.d0, .0d0, .00d0,
4326  & 1.d0, 1.5d0, 3.5d0, 4.15d0, 3.7d0, 2.7d0, 2.3d0, 1.75d0, 6*0.d0,
4327  & 10*0.d0, .5d0, 2.0d0, 3.3d0, 5.4d0, 7.d0 /
4328 **** pi+ n data *
4329  DATA spikpu/ 0.d0, 25.d0, 13.d0, 11.d0, 10.5d0, 14.d0, 20.d0,
4330  & 20.d0, 16.d0, 14.d0, 19.d0, 28.d0, 17.5d0, 13.5d0, 12.d0, 10.5d0,
4331  & 10.d0, 10.d0, 9.5d0, 9.d0, 8.d0, 7.5d0, 7.d0, 6.5d0, 6.d0, 0.d0,
4332  & 48.d0, 19.d0, 15.d0, 11.5d0, 10.d0, 8.d0, 6.5d0, 5.5d0, 4.8d0,
4333  & 4.2d0, 7.5d0, 3.4d0, 2.5d0, 2.5d0, 2.1d0, 1.4d0, 1.d0, .8d0,
4334  & .6d0, .46d0, .3d0, .2d0, .15d0, .13d0, 11*0.d0, .95d0, .65d0,
4335  & .48d0, .35d0, .2d0, .18d0, .17d0, .16d0, .15d0, .1d0, .09d0,
4336  & .065d0, .05d0, .04d0, 12*0.d0, .2d0, .25d0, .25d0, .2d0, .1d0,
4337  & .08d0, .06d0, .045d0, .03d0, .02d0, .01d0, .005d0, .003d0,
4338  & 12*0.d0, .3d0, .24d0, .18d0, .15d0, .13d0, .12d0, .11d0, .1d0,
4339  & .09d0, .08d0, .05d0, .04d0, .03d0, 0.d0, 0.16d0, .7d0, 1.3d0,
4340  & 3.1d0, 4.5d0, 2.d0, 18*0.d0, 3*.0d0, 0.d0, 0.d0, 4.0d0, 11.d0,
4341  & 11.4d0, 10.3d0, 7.5d0, 6.8d0, 4.75d0, 2.5d0, 1.5d0, .9d0, .55d0,
4342  & .35d0, 13*0.d0, .1d0, .34d0, .5d0, .8d0, 1.1d0, 2.25d0, 3.3d0,
4343  & 2.3d0, 1.6d0, .95d0, .45d0, .28d0, .15d0, 10*0.d0, 2*0.d0, .17d0,
4344  & .64d0, 1.d0, 1.5d0, 2.1d0, 4.25d0, 6.2d0, 4.4d0, 3.d0, 1.8d0,
4345  & .9d0, .53d0, .28d0, 10*0.d0, 2*0.d0, .25d0, .82d0,
4346  & 1.3d0, 1.9d0, 2.8d0, 5.5d0 , 8.d0, 5.7d0, 3.9d0, 2.35d0, 1.15d0,
4347  & .69d0, .37d0, 10*0.d0, 7*0.d0, .0d0, .34d0, 1.5d0, 3.47d0,
4348  & 5.87d0, 6.23d0, 4.27d0, 2.6d0, 1.d0, .6d0, .3d0, .15d0, 6*0.d0/
4349 *
4350  DATA spikpv/ 7*0.d0, .00d0, .16d0, .75d0, 1.73d0, 2.93d0, 3.12d0,
4351  & 2.13d0, 1.3d0, .5d0, .3d0, .15d0, .08d0, 6*0.d0, 10*0.d0, .2d0,
4352  & .6d0, .92d0, 2.4d0, 4.9d0, 6.25d0, 5.25d0, 3.5d0, 2.15d0, 1.4d0,
4353  & 1.d0, .7d0, 13*0.d0, .13d0, .4d0, .62d0, 1.6d0, 3.27d0, 4.17d0,
4354  & 3.5d0, 2.33d0, 1.43d0, .93d0, .66d0, .47d0, 13*0.d0, .07d0, .2d0,
4355  & .31d0, .8d0, 1.63d0, 2.08d0, 1.75d0, 1.17d0, .72d0, .47d0, .34d0,
4356  & .23d0, 17*0.d0, .33d0, 1.d0, 1.8d0, 2.67d0, 5.33d0, 6.d0, 5.53d0,
4357  & 5.d0, 17*0.d0, .17d0, .5d0, .9d0, 1.83d0, 2.67d0, 3.0d0, 2.77d0,
4358  & 2.5d0, 3*0.d0, 3*0.d0, 1.d0, 3.3d0, 2.8d0, 2.5d0, 2.3d0, 1.8d0,
4359  & 1.5d0, 1.1d0, .8d0, .7d0, .55d0, .3d0, 10*0.d0, 9*0.d0, .1d0,
4360  & .4d0, 1.d0, 1.4d0, 2.2d0, 2.5d0, 2.2d0, 1.65d0, 1.35d0, 1.1d0,
4361  & .8d0, .6d0, .4d0, 12*0.d0, .15d0, .6d0, 1.5d0, 2.1d0, 3.3d0,
4362  & 3.8d0, 3.3d0, 2.45d0, 2.05d0, 1.65d0, 1.2d0, .9d0, .6d0, 3*0.d0,
4363  & 9*0.d0, .10d0, .2d0, .5d0, .7d0, 1.3d0, 1.55d0, 1.9d0, 1.8d0,
4364  & 1.55d0, 1.35d0, 1.15d0, .95d0, .7d0, 13*0.d0, .2d0, .5d0, .7d0,
4365  & 1.3d0, 1.55d0, 1.9d0, 1.8d0, 1.55d0, 1.35d0, 1.15d0, .95d0, .7d0,
4366  & 17*0.d0, .2d0, .5d0, .85d0, 2.d0, 2.15d0, 2.05d0, 1.75d0, 1.d0,
4367  & 17*0.d0, .13d0, .33d0, .57d0, 1.33d0, 1.43d0, 1.36d0, 1.17d0,
4368  & .67d0, 17*0.d0, .07d0, .17d0, .28d0, .67d0, .72d0, .69d0, .58d0,
4369  & .33d0,17*0.d0,.4d0, .7d0, 1.d0, 1.6d0, 1.8d0, 2.3d0,1.9d0,1.7d0 /
4370 **** pi- p data *
4371  DATA spikpw/ 0.d0, 25.d0, 13.d0, 11.d0, 10.5d0, 14.d0, 2*20.d0,
4372  & 16.d0, 14.d0, 19.d0, 28.d0, 17.5d0, 13.5d0, 12.d0, 10.5d0,
4373  & 2*10.d0, 9.5d0, 9.d0, 8.d0, 7.5d0, 7.d0, 6.5d0, 6.d0, 0.d0,
4374  & 48.d0, 19.d0, 15.d0, 11.5d0, 10.d0, 8.d0, 6.5d0, 5.5d0, 4.8d0,
4375  & 4.2d0, 7.5d0, 3.4d0, 2*2.5d0, 2.1d0, 1.4d0, 1.d0, .8d0, .6d0,
4376  & .46d0, .3d0, .2d0, .15d0, .13d0, 11*0.d0, .95d0, .65d0, .48d0,
4377  & .35d0, .2d0, .18d0, .17d0, .16d0, .15d0, .1d0, .09d0, .065d0,
4378  & .05d0, .04d0, 12*0.d0, .2d0, 2*.25d0, .2d0, .1d0, .08d0, .06d0,
4379  & .045d0, .03d0, .02d0, .01d0, .005d0, .003d0, 12*0.d0, .3d0,
4380  & .24d0, .18d0, .15d0, .13d0, .12d0, .11d0, .1d0, .09d0, .08d0,
4381  & .05d0, .04d0, .03d0, 0.d0, 0.16d0, .7d0, 1.3d0, 3.1d0, 4.5d0,
4382  & 2.d0, 23*0.d0, 4.0d0, 11.d0, 11.4d0, 10.3d0, 7.5d0, 6.8d0,
4383  & 4.75d0, 2.5d0, 1.5d0, .9d0, .55d0, .35d0, 13*0.d0, .1d0, .34d0,
4384  & .5d0, .8d0, 1.1d0, 2.25d0, 3.3d0, 2.3d0, 1.6d0, .95d0, .45d0,
4385  & .28d0, .15d0, 12*0.d0, .17d0, .64d0, 1.d0, 1.5d0, 2.1d0, 4.25d0,
4386  & 6.2d0, 4.4d0, 3.d0, 1.8d0, .9d0, .53d0, .28d0, 12*0.d0, .25d0,
4387  & .82d0, 1.3d0, 1.9d0, 2.8d0, 5.5d0, 8.d0, 5.7d0, 3.9d0, 2.35d0,
4388  & 1.15d0, .69d0, .37d0, 18*0.d0, .34d0, 1.5d0, 3.47d0, 5.87d0,
4389  & 6.23d0, 4.27d0, 2.6d0, 1.d0, .6d0, .3d0, .15d0, 6*0.d0/
4390 *
4391  DATA spikpx/ 8*0.d0, .16d0, .75d0, 1.73d0, 2.93d0, 3.12d0,
4392  & 2.13d0, 1.3d0, .5d0, .3d0, .15d0, .08d0, 16*0.d0, .2d0, .6d0,
4393  & .92d0, 2.4d0, 4.9d0, 6.25d0, 5.25d0, 3.5d0, 2.15d0, 1.4d0, 1.d0,
4394  & .7d0, 13*0.d0, .13d0, .4d0, .62d0, 1.6d0, 3.27d0, 4.17d0, 3.5d0,
4395  & 2.33d0, 1.43d0, .93d0, .66d0, .47d0, 13*0.d0, .07d0, .2d0, .31d0,
4396  & .8d0, 1.63d0, 2.08d0, 1.75d0, 1.17d0, .72d0, .47d0, .34d0, .23d0,
4397  & 17*0.d0, .33d0, 1.d0, 1.8d0, 2.67d0, 5.33d0, 6.d0, 5.53d0, 5.d0,
4398  & 17*0.d0, .17d0, .5d0, .9d0, 1.83d0, 2.67d0, 3.0d0, 2.77d0, 2.5d0,
4399  & 6*0.d0, 1.d0, 3.3d0, 2.8d0, 2.5d0, 2.3d0, 1.8d0, 1.5d0, 1.1d0,
4400  & .8d0, .7d0, .55d0, .3d0, 19*0.d0, .1d0, .4d0, 1.d0, 1.4d0, 2.2d0,
4401  & 2.5d0, 2.2d0, 1.65d0, 1.35d0, 1.1d0, .8d0, .6d0, .4d0, 12*0.d0,
4402  & .15d0, .6d0, 1.5d0, 2.1d0, 3.3d0, 3.8d0, 3.3d0, 2.45d0, 2.05d0,
4403  & 1.65d0, 1.2d0, .9d0, .6d0, 12*0.d0, .10d0, .2d0, .5d0, .7d0,
4404  & 1.3d0, 1.55d0, 1.9d0, 1.8d0, 1.55d0, 1.35d0, 1.15d0, .95d0, .7d0,
4405  & 13*0.d0, .2d0, .5d0, .7d0, 1.3d0, 1.55d0, 1.9d0, 1.8d0, 1.55d0,
4406  & 1.35d0, 1.15d0, .95d0, .7d0, 17*0.d0, .2d0, .5d0, .85d0, 2.d0,
4407  & 2.15d0, 2.05d0, 1.75d0, 1.d0, 17*0.d0, .13d0, .33d0, .57d0,
4408  & 1.33d0, 1.43d0, 1.36d0, 1.17d0, .67d0, 17*0.d0, .07d0, .17d0,
4409  & .28d0, .67d0, .72d0, .69d0, .58d0, .33d0, 17*0.d0, .4d0, .7d0,
4410  & 1.d0, 1.6d0, 1.8d0, 2.3d0, 1.9d0, 1.7d0 /
4411 **** pi- n data *
4412  DATA spikp4 / 0.d0, 300.d0, 40.d0, 20.d0, 13.d0, 8.5d0, 8.d0,
4413  & 9.5d0, 12.d0, 14.d0, 15.5d0, 20.d0, 17.d0, 13.d0, 10.d0, 9.d0,
4414  & 8.5d0, 8.d0, 7.8d0, 7.3d0, 6.7d0, 9*0.d0, .23d0, .35d0, .7d0,
4415  & .52d0, .4d0, .3d0, .2d0, .15d0, .13d0, .11d0, .09d0, .07d0, 0.d0,
4416  & .033d0, .8d0, 2*1.35d0, .5d0, 19*0.d0, 0.8d0, 2.2d0, 3.6d0,
4417  & 4.6d0, 4.7d0, 3.5d0, 2.4d0, 1.8d0, 1.4d0, .75d0, .47d0, .25d0,
4418  & .13d0, .08d0, 7*0.d0, 1.2d0, 3.3d0, 5.4d0, 6.9d0, 7.3d0, 5.3d0,
4419  & 3.6d0, 2.7d0, 2.2d0, 1.1d0, .73d0, .4d0, .22d0, .12d0, 11*0.d0,
4420  & 2.0d0, 4.4d0, 6.8d0, 9.9d0, 7.9d0, 6.0d0, 3.8d0, 2.5d0, 2.d0,
4421  & 1.4d0, 1.d0, .6d0, .35d0, 10*0.d0, .25d0, .55d0, .75d0, 1.25d0,
4422  & 1.9d0, 2.d0, 1.8d0, 1.5d0, 1.25d0, 1.d0, .8d0, 10*0.d0, .4d0,
4423  & .85d0, 1.1d0, 1.85d0, 2.8d0, 3.d0, 2.7d0, 2.2d0, 1.85d0, 1.5d0,
4424  & 1.2d0, 12*0.d0, .5d0, 1.2d0, 1.7d0, 3.4d0, 5.2d0, 6.4d0, 6.1d0,
4425  & 5.6d0, 5.2d0, 9*0.d0, 1.d0, 3.3d0, 5.2d0, 4.45d0, 3.6d0, 2.75d0,
4426  & 1.9d0, 1.65d0, 1.3d0, .95d0, .6d0, .45d0, 10*0.d0, .45d0, 1.4d0,
4427  & 1.5d0, 1.1d0, .85d0, .5d0, .3d0, .2d0, .15d0, 15*0.d0, .6d0,
4428  & .8d0, .95d0, .8d0, .7d0, .6d0, .5d0, .4d0, 13*0.d0, .85d0, 1.2d0,
4429  & 1.4d0, 1.2d0, 1.05d0, .9d0, .7d0, .55d0, 13*0.d0, 1.d0, 1.5d0,
4430  & 3.5d0, 4.15d0, 3.7d0, 2.7d0, 2.3d0, 1.75d0, 16*0.d0, .5d0, 2.0d0,
4431  & 3.3d0, 5.4d0, 7.d0 /
4432 **** k+ p data *
4433  DATA spikp5/ 0.d0, 20.d0, 14.d0, 12.d0, 11.5d0, 10.d0, 8.d0,
4434  & 7.d0, 6.d0, 5.5d0, 5.3d0, 5.d0, 4.5d0, 4.4d0, 3.8d0, 3.d0, 2.8d0,
4435  & 0.d0, .5d0, 1.15d0, 2.d0, 1.3d0, .8d0, .45d0, 13*0.d0, 0.9d0,
4436  & 2.5d0, 3.d0, 2.5d0, 2.3d0, 2.d0, 1.7d0, 1.5d0, 1.2d0, .9d0, .6d0,
4437  & .45d0, .21d0, .2d0, 3*0.d0, .9d0, 2.5d0, 3.d0, 2.5d0, 2.3d0,
4438  & 2.d0, 1.7d0, 1.5d0, 1.2d0, .9d0, .6d0, .45d0, .21d0, .2d0,
4439  & 4*0.d0, 1.d0, 2.1d0, 2.6d0, 2.3d0, 2.1d0, 1.8d0, 1.7d0, 1.4d0,
4440  & 1.2d0, 1.05d0, .9d0, .66d0, .5d0, 7*0.d0, .3d0, 2*1.d0, .9d0,
4441  & .7d0, .4d0, .3d0, .2d0, 11*0.d0, .1d0, 1.d0, 2.2d0, 3.5d0, 4.2d0,
4442  & 4.55d0, 4.85d0, 4.9d0, 10*0.d0, .2d0, .7d0, 1.6d0, 2.5d0, 2.2d0,
4443  & 1.71d0, 1.6d0, 6*0.d0, 1.4d0, 3.8d0, 5.d0, 4.7d0, 4.4d0, 4.d0,
4444  & 3.5d0, 2.85d0, 2.35d0, 2.01d0, 1.8d0, 12*0.d0, .1d0, .8d0,2.05d0,
4445  & 3.31d0, 3.5d0, 12*0.d0, .034d0, .2d0, .75d0, 1.04d0, 1.24d0 /
4446 
4447 C222222222222222222222222222222222222222222222222222222222222222222222
4448 C2222222222222222222222222222222222222222222222222222222222222222222222
4449 
4450 
4451 
4452 C**** K+ N DATA
4453  DATA s pikp6/ 0.,6.,11.,13.,6.,5.,3.,2.2,1.5,1.2,1.,.7,.6,.5,.45,.
4454  +35,.3, 0.,6.,11.,13.,6.,5.,3.,2.2,1.5,1.2,1.,.7,.6,.5,.45,.35,.3,
4455  +0.,.5,1.3,2.8,2.3,1.6,.9,10*0., 3*0.,0.9,2.5,3.,2.5,2.3,2.,1.7,
4456  +1.5,1.2,.9,.6,.45,.21,.2, 3*0.,0.9,2.5,3.,2.5,2.3,2.,1.7,1.5,1.2,.
4457  +9,.6,.45,.21,.2, 4*0.,1.0,2.1,2.6,2.3,2.0,1.8,1.7,1.4,1.2,1.15,.9,
4458  +.66, .5, 4*0.,1.0,2.1,2.6,2.3,2.1,1.8,1.7,1.4,1.2,1.15,.9,.66, .5,
4459  +7*0.,.3,1.,1.,.9,.7,.4,.35,.2,.00,0., 7*0.,.3,1.,1.,.9,.7,.4,.35,.
4460  +2,.00,0., 9*0.,.1,1.,2.4,3.5,4.25,4.55,4.85,4.9, 9*0.,.1,1.,2.4,
4461  +3.5,4.25,4.55,4.85,4.9, 10*0.,.2,.7,1.6,2.5,2.2,1.71,1.6, 10*0.,.
4462  +2,.7,1.6,2.5,2.2,1.71,1.6, 6*0.,1.4,3.8,5.,4.7,4.4,4.,3.5,2.85,
4463  +2.35,2.01,1.8, 6*0.,1.4,3.8,5.,4.7,4.4,4.,3.5,2.85,2.35,2.01,1.8,
4464  +12*0.,.1,.8,2.05,3.31,3.5, 12*0.,.034,.20,.75,1.04,1.24, .0,2.5,
4465  +15.,21.5,15.3,3.,1.5,10*0./
4466 
4467 C333333333333333333333333333333333333333333333333333333333333333333333
4468 
4469 **** k- p data *
4470  DATA skmpel/ 0.d0, 35.d0, 22.d0, 25.d0, 17.d0, 9.d0, 9.5d0, 8.d0,
4471  & 7.d0, 6.5d0, 6.1d0, 5.d0, 4.8d0, 4.6d0, 4.45d0, 4.3d0, 4.2d0,
4472  & 0.d0, 8.d0, 3.5d0, 8.d0, 3.d0, 1.9d0, 1.7d0, 1.d0, .9d0, .8d0,
4473  & .75d0, .5d0, .42d0, .38d0, .34d0, .25d0, .2d0,
4474  & 0.d0, 3.d0, 3.2d0, 3.5d0, 1.5d0, 1.4d0, 1.1d0, .6d0, .5d0,
4475  & .35d0, .28d0, .25d0, .18d0, .12d0, .1d0, .08d0, .04d0,
4476  & 0.d0, 8.5d0, 2.4d0, 1.7d0, 1.3d0, 1.3d0, 1.1d0, .5d0,
4477  & .4d0, .4d0, .35d0, .3d0, .28d0, .2d0, .16d0, .13d0, .11d0,
4478  & 0.d0, 7.d0, 4.8d0, 1.4d0, 1.9d0, .9d0, .4d0, .2d0, .13d0,
4479  & .1d0, .08d0, .06d0, .04d0, .02d0, .015d0, .01d0, .01d0,
4480  & 0.d0, 5.5d0, 1.d0, .8d0, .75d0, .32d0, .2d0, .1d0, .09d0,
4481  & .08d0, .065d0, .05d0, .04d0, .022d0, .017d0, 2*.01d0/
4482  DATA spikp7 / 0.d0, .56d0, 1.46d0, 3.16d0, 2.01d0, 1.28d0, .74d0,
4483  & 14*0.d0, 1.13d0, 2.61d0, 2.91d0, 2.58d0, 2.35d0, 2.02d0,
4484  & 1.91d0, 1.57d0, 1.35d0, 1.29d0, 1.01d0, .74d0, .65d0, 4*0.d0,
4485  & 1.13d0, 2.61d0, 2.91d0, 2.58d0, 2.35d0, 2.02d0, 1.91d0, 1.57d0,
4486  & 1.35d0, 1.29d0, 1.01d0, .74d0, .65d0, 3*0.d0, 1.0d0, 3.03d0,
4487  & 3.36d0, 2.8d0, 2.58d0, 2.24d0, 1.91d0, 1.68d0, 1.35d0, 1.01d0,
4488  & .67d0, .5d0, .24d0, .23d0, 3*0.d0, 1.0d0, 3.03d0, 3.36d0, 2.8d0,
4489  & 2.58d0, 2.24d0, 1.91d0, 1.68d0, 1.35d0, 1.01d0, .67d0, .5d0,
4490  & .24d0, .23d0, 7*0.d0, .34d0, 1.12d0, 1.12d0, 1.01d0, .78d0,
4491  & .45d0, .39d0, .22d0, .07d0, 0.d0, 7*0.d0, .34d0, 1.12d0, 1.12d0,
4492  & 1.01d0, .78d0, .45d0, .39d0, .22d0, .07d0, 0.d0, 6*0.d0, 1.71d0,
4493  & 4.26d0, 5.6d0, 5.57d0, 4.93d0, 4.48d0, 3.92d0, 3.19d0, 2.63d0,
4494  & 2.25d0, 2.d0, 6*0.d0, 1.71d0, 4.26d0, 5.6d0, 5.57d0, 4.93d0,
4495  & 4.48d0, 3.92d0, 3.19d0, 2.63d0, 2.25d0, 2.d0, 10*0.d0, .22d0,
4496  & .8d0, .75d0, 1.d0, 1.3d0, 1.5d0, 1.3d0, 10*0.d0, .22d0, .8d0,
4497  & .75d0, 1.d0, 1.3d0, 1.5d0, 1.3d0, 13*0.d0, .1d0, .3d0, .7d0,1.d0,
4498  & 13*0.d0, .1d0, .3d0, .7d0, 1.d0, 9*0.d0, .11d0, 1.72d0, 2.69d0,
4499  & 3.92d0, 4.76d0, 5.10d0, 5.44d0, 5.3d0, 9*0.d0, .11d0, 1.72d0,
4500  & 2.69d0, 3.92d0, 4.76d0, 5.1d0, 5.44d0, 5.3d0, 5*0.d0,9.2d0,4.7d0,
4501  & 1.9d0, 10*0.d0, 2.5d0, 15.d0, 21.5d0, 15.3d0, 3.d0, 1.5d0,
4502  & 10*0.d0/
4503 C333333333333333333333333333333333333333333333333333333333333333333333
4504 C3333333333333333333333333333333333333333333333333333333333333333333333
4505 
4506 
4507 
4508 
4509 C**** K- N DATA
4510  DATA skmnel/
4511  *0.,4.,9.5,20.,13.,9.5,6.,4.4,3.,2.4,2.,1.4,1.2,1.,.9,.7,.6,
4512  *0.,4.5,6.,5.,2.5,2.,1.7,2.1,1.9,.9,.5,.3,.24,.2,.18,.1,.09,
4513  *0.,1.8,2.,1.1,.9,.5,.5,.4,.4,.2,.1,.06,.05,.04,.03,.02,.02,
4514  *0.,1.5,2.,.9,1.1,.4,.6,.7,.65,.3,.17,.1,.08,.07,.06,.04,.03/
4515  DATA s pikp8/ 0.,.56,1.29,2.26,1.01,.64,.37,10*0., 4*0.,1.13,2.61,
4516  +2.91,2.58,2.35,2.02,1.91,1.57,1.35,1.29,1.01,.74, .65, 3*0.,1.00,
4517  +3.03,3.36,2.8,2.58,2.24,1.91,1.68,1.35,1.01,.67,.5,.24, .23, 3*0.,
4518  +1.00,3.03,3.36,2.8,2.58,2.24,1.91,1.68,1.35,1.01,.67,.5,.24, .23,
4519  +7*0.,.34,1.12,1.12,1.01,.78,.45,.39,.22,.07,0., 6*0.,1.71,4.26,
4520  +5.6,5.57,4.93,4.48,3.92,3.19,2.63,2.25,2., 10*0.,.22,.8,.75,1.,
4521  +1.3,1.5,1.3, 13*0.,.1,.3,.7,1., 13*0.,.1,.3,.7,1., 9*0.,.11,1.72,
4522  +2.69,3.92,4.76,5.10,5.44,5.3, 4*0.,0.00,9.2,4.7,1.9,9*0. /
4523 
4524 
4525 
4526 
4527 
4528 
4529 
4530 
4531 C**** P P DATA
4532  DATA s pikp9/ 0.,24.,25.,27.,23.,21.,20.,19.,17.,15.5,14.,13.5,
4533  +13., 0.,3.6,1.7, 10*0., .0,0.0,8.7,17.7,18.8,15.9,11.7,8.,6.,5.3,
4534  +4.5,3.9,3.5, .0,.0,2.8,5.8,6.2,5.1,3.8,2.7,2.1,1.8,1.5,1.3,1.1, 4
4535  +*0.,0.0,4.6,10.2,15.1,16.9,16.5,11.,5.5,3.5, 10*0.,4.3,7.6,9., 10
4536  +*0.,1.7,2.6,3., 6*0.,.3,.6,1.,1.6,1.3,.8,.6, 6*0.,.7,1.2,1.8,2.5,
4537  +1.8,1.3,1.2, 10*0.,.6,1.4,1.7, 10*0.,1.9,4.1,5.2/
4538 
4539 
4540 C444444444444444444444444444444444444444444444444444444444444444444444
4541 ***** p n data *
4542  DATA spikp0/ 0.d0, 24.d0, 25.d0, 27.d0, 23.d0, 21.d0, 20.d0,
4543  & 19.d0, 17.d0, 15.5d0, 14.d0, 13.5d0, 13.d0,
4544  & 0.d0, 1.8d0, .2d0, 12*0.d0,
4545  & 3.2d0, 6.05d0, 9.9d0, 5.1d0,
4546  & 3.8d0, 2.7d0, 1.9d0, 1.5d0, 1.4d0, 1.3d0, 1.1d0,
4547  & 2*.0d0, 3.2d0, 6.05d0, 9.9d0, 5.1d0,
4548  & 3.8d0, 2.7d0, 1.9d0, 1.5d0, 1.4d0, 1.3d0, 1.1d0,
4549  & 5*0.d0, 4.6d0, 10.2d0, 15.1d0,
4550  & 16.4d0, 15.2d0, 11.d0, 5.4d0, 3.5d0,
4551  & 5*0.d0, 4.6d0, 10.2d0, 15.1d0,
4552  & 16.4d0, 15.2d0, 11.d0, 5.4d0, 3.5d0,
4553  & 10*0.d0, .7d0, 5.1d0, 8.d0,
4554  & 10*0.d0, .7d0, 5.1d0, 8.d0,
4555  & 10*.0d0, .3d0, 2.8d0, 4.7d0,
4556  & 10*.0d0, .3d0, 2.8d0, 4.7d0,
4557  & 7*0.d0, 1.2d0, 2.5d0, 3.5d0, 6.d0, 5.3d0, 2.9d0,
4558  & 7*0.d0, 1.7d0, 3.6d0, 5.4d0, 9.d0, 7.6d0, 4.2d0,
4559  & 5*0.d0, 7.7d0, 6.1d0, 2.9d0, 5*0.d0/
4560 * nn - data *
4561 * *
4562  DATA spkp v/ 0.d0, 24.d0, 25.d0, 27.d0, 23.d0, 21.d0, 20.d0,
4563  & 19.d0, 17.d0, 15.5d0, 14.d0, 13.5d0, 13.d0,
4564  & 0.d0, 3.6d0, 1.7d0, 12*0.d0,
4565  & 8.7d0, 17.7d0, 18.8d0, 15.9d0,
4566  & 11.7d0, 8.d0, 6.d0, 5.3d0, 4.5d0, 3.9d0, 3.5d0,
4567  & .0d0, .0d0, 2.8d0, 5.8d0, 6.2d0, 5.1d0, 3.8d0,
4568  & 2.7d0, 2.1d0, 1.8d0, 1.5d0, 1.3d0, 1.1d0,
4569  & 5*0.d0, 4.6d0, 10.2d0, 15.1d0, 16.9d0, 16.5d0,
4570  & 11.d0, 5.5d0, 3.5d0,
4571  & 10*0.d0, 4.3d0, 7.6d0, 9.d0,
4572  & 10*0.d0, 1.7d0, 2.6d0, 3.d0,
4573  & 6*0.d0, .3d0, .6d0, 1.d0, 1.6d0, 1.3d0, .8d0, .6d0,
4574  & 6*0.d0, .7d0, 1.2d0, 1.8d0, 2.5d0, 1.8d0, 1.3d0,
4575  & 1.2d0, 10*0.d0, .6d0, 1.4d0, 1.7d0,
4576  & 10*0.d0, 1.9d0, 4.1d0, 5.2d0/
4577 **************** ap - p - data *
4578  DATA sappel/ 0.d0, 176.d0, 160.d0, 105.d0, 75.d0, 68.d0, 65.d0,
4579  & 50.d0, 50.d0, 43.d0, 42.d0, 40.5d0, 35.d0, 30.d0, 28.d0,
4580  & 25.d0, 22.d0, 21.d0, 20.d0, 18.d0, 17.d0, 11*0.d0,
4581  & .05d0, .15d0, .18d0, .2d0, .2d0, .3d0, .4d0, .6d0, .7d0, .85d0,
4582  & 0.d0, 1.d0, .9d0, .46d0, .3d0, .23d0, .18d0, .16d0, .14d0,
4583  & .1d0, .08d0, .05d0, .02d0, .015d0, 4*.011d0, 3*.005d0,
4584  & 0.d0, 55.d0, 50.d0, 25.d0, 15.d0, 15.d0, 14.d0, 12.d0,
4585  & 10.d0, 7.d0, 6.d0, 4.d0, 3.3d0, 2.8d0, 2.4d0, 2.d0, 1.8d0,
4586  & 1.55d0, 1.3d0, .95d0, .75d0,
4587  & 0.d0, 3.3d0, 3.d0, 1.5d0, 1.d0, .7d0, .4d0, .35d0, .4d0,
4588  & .25d0, .18d0, .08d0, .04d0, .03d0, .023d0, .016d0, .014d0,
4589  & .01d0, .008d0, .006d0, .005d0/
4590  DATA spikpe/0.d0, 215.d0, 193.d0, 170.d0, 148.d0, 113.d0, 97.d0,
4591  & 84.d0, 78.d0, 68.d0, 64.d0, 61.d0, 46.d0, 36.d0, 31.3d0, 28.5d0,
4592  & 25.7d0, 22.6d0, 21.4d0, 20.7d0, 19.9d0,
4593  & 9*0.d0, 2.d0, 2.5d0, .2d0, 19*0.d0, .3d0, 1.4d0, 2.2d0, 1.2d0,
4594  & 1.1d0, 1.d0, .8d0, .6d0, .5d0, .4d0, .3d0, 10*0.d0, .3d0, 1.4d0,
4595  & 2.2d0, 1.2d0, 1.1d0, 1.d0, .8d0, .6d0, .5d0, .4d0, .3d0, 10*0.d0,
4596  & .3d0, 1.4d0, 2.2d0, 1.2d0, 1.1d0, 1.d0, .8d0, .6d0, .5d0, .4d0,
4597  & .3d0, 10*0.d0, .3d0, 1.4d0, 2.2d0, 1.2d0, 1.1d0, 1.d0, .8d0,
4598  & .6d0, .5d0, .4d0, .3d0, 9*0.d0, .6d0, 2.5d0, 5.d0, 5.2d0, 5.1d0,
4599  & 5.4d0, 5.8d0, 2.8d0, 2.1d0, 1.8d0, 1.6d0, 1.2d0, 13*0.d0, 1.3d0,
4600  & 1.5d0, 2.d0, 2.5d0, 2.5d0, 2.3d0, 1.8d0, 1.4d0, 13*0.d0, 1.3d0,
4601  & 1.5d0, 2.d0, 2.5d0, 2.5d0, 2.3d0, 1.8d0, 1.4d0, 13*0.d0, 1.3d0,
4602  & 1.5d0, 2.d0, 2.5d0, 2.5d0, 2.3d0, 1.8d0, 1.4d0, 13*0.d0, 1.3d0,
4603  & 1.5d0, 2.d0, 2.5d0, 2.5d0, 2.3d0, 1.8d0, 1.4d0, 14*0.d0, .2d0,
4604  & .5d0, 1.1d0, 1.6d0, 1.4d0, 1.1d0, .9d0, 14*0.d0, .2d0, .5d0,
4605  & 1.1d0, 1.6d0, 1.4d0, 1.1d0, .9d0, 14*0.d0, .2d0, .5d0, 1.1d0,
4606  & 1.6d0, 1.4d0, 1.1d0, .9d0, 14*0.d0, .2d0, .5d0, 1.1d0, 1.6d0,
4607  & 1.4d0, 1.1d0, .9d0, 17*0.d0, .3d0, 1.6d0, 2.6d0, 3.6d0, 17*0.d0,
4608  & .3d0, 1.6d0, 2.6d0, 3.6d0, 17*0.d0, .3d0, 1.6d0, 2.6d0,
4609  & 3.6d0, 17*0.d0, .3d0, 1.6d0, 2.6d0, 3.6d0 /
4610 **************** ap - n - data *
4611  DATA sapnel/
4612  & 0.d0, 176.d0, 160.d0, 105.d0, 75.d0, 68.d0, 65.d0,
4613  & 50.d0, 50.d0, 43.d0, 42.d0, 40.5d0, 35.d0, 30.d0, 28.d0,
4614  & 25.d0, 22.d0, 21.d0, 20.d0, 18.d0, 17.d0, 11*0.d0,
4615  & .05d0, .15d0, .18d0, .2d0, .2d0, .3d0, .4d0, .6d0, .7d0,
4616  & .85d0, 0.d0, 1.d0, .9d0, .46d0, .3d0, .23d0, .18d0, .16d0,
4617  & .14d0, .1d0, .08d0, .05d0, .02d0, .015d0, 4*.011d0, 3*.005d0,
4618  & 0.d0, 3.3d0, 3.d0, 1.5d0, 1.d0, .7d0, .4d0, .35d0, .4d0,
4619  & .25d0, .18d0, .08d0, .04d0, .03d0, .023d0, .016d0, .014d0,
4620  & .01d0, .008d0, .006d0, .005d0 /
4621  DATA spikpz/ 0.d0, 215.d0, 193.d0, 170.d0, 148.d0, 113.d0, 97.d0,
4622  & 84.d0, 78.d0, 68.d0, 64.d0, 61.d0, 46.d0, 36.d0, 31.3d0, 28.5d0,
4623  & 25.7d0, 22.6d0, 21.4d0, 20.7d0, 19.9d0, 9*0.d0, 2.4d0, .2d0,
4624  & 20*0.d0, 1.8d0, 2.8d0, 3.6d0, 2.3d0, 1.8d0, 1.5d0, 1.3d0, 1.d0,
4625  & .7d0, .5d0, .3d0, 10*0.d0, 1.8d0, 2.8d0, 3.6d0, 2.3d0, 1.8d0,
4626  & 1.5d0, 1.3d0, 1.d0, .7d0, .5d0, .3d0, 10*0.d0, 1.8d0, 2.8d0,
4627  & 3.6d0, 2.3d0, 1.8d0, 1.5d0, 1.3d0, 1.d0, .7d0, .5d0, .3d0,
4628  & 10*0.d0, 1.8d0, 2.8d0, 3.6d0, 2.3d0, 1.8d0, 1.5d0, 1.3d0, 1.d0,
4629  & .7d0, .5d0, .3d0, 13*0.d0, 5.2d0, 8.7d0, 11.4d0, 14.d0, 11.9d0,
4630  & 7.6d0, 6.d0, 5.d0, 13*0.d0, 5.2d0, 8.7d0, 11.4d0, 14.d0, 11.9d0,
4631  & 7.6d0, 6.d0, 5.d0, 18*0.d0, 1.d0, 4.9d0, 8.5d0, 18*0.d0, 1.d0,
4632  & 4.9d0, 8.5d0, 15*0.d0, 1.9d0, 2.3d0, 4.d0, 6.5d0, 5.2d0, 3.4d0,
4633  & 15*0.d0, 1.9d0, 2.3d0, 4.d0, 6.5d0, 5.2d0, 3.4d0, 15*0.d0, 1.9d0,
4634  & 2.3d0, 4.d0, 6.5d0, 5.2d0, 3.4d0 /
4635 * *
4636 * *
4637 **************** an - p - data *
4638 * *
4639  DATA sanpel/
4640  & 0.d0, 176.d0, 160.d0, 105.d0, 75.d0, 68.d0, 65.d0, 50.d0,
4641  & 50.d0, 43.d0, 42.d0, 40.5d0, 35.d0, 30.d0, 28.d0,
4642  & 25.d0, 22.d0, 21.d0, 20.d0, 18.d0, 17.d0, 11*0.d0, .05d0,
4643  & .15d0, .18d0, .2d0, .2d0, .3d0, .4d0, .6d0, .7d0, .85d0,
4644  & 0.d0, 1.d0, .9d0, .46d0, .3d0, .23d0, .18d0, .16d0, .14d0,
4645  & .1d0, .08d0, .05d0, .02d0, .015d0, 4*.011d0, 3*.005d0,
4646  & 0.d0, 3.3d0, 3.d0, 1.5d0, 1.d0, .7d0, .4d0, .35d0, .4d0, .25d0,
4647  & .18d0, .08d0, .04d0, .03d0, .023d0, .016d0, .014d0,
4648  & .01d0, .008d0, .006d0, .005d0 /
4649  DATA spikpf/ 0.d0, 215.d0, 193.d0, 170.d0, 148.d0, 113.d0, 97.d0,
4650  & 84.d0, 78.d0, 68.d0, 64.d0, 61.d0, 46.d0, 36.d0, 31.3d0, 28.5d0,
4651  & 25.7d0, 22.6d0, 21.4d0, 20.7d0, 19.9d0, 9*0.d0, 2.4d0, .2d0,
4652  & 20*0.d0, 1.8d0, 2.8d0, 3.6d0, 2.3d0, 1.8d0, 1.5d0, 1.3d0, 1.d0,
4653  & .7d0, .5d0, .3d0, 10*0.d0, 1.8d0, 2.8d0, 3.6d0, 2.3d0, 1.8d0,
4654  & 1.5d0, 1.3d0, 1.d0, .7d0, .5d0, .3d0, 10*0.d0, 1.8d0, 2.8d0,
4655  & 3.6d0, 2.3d0, 1.8d0, 1.5d0, 1.3d0, 1.d0, .7d0, .5d0, .3d0,
4656  & 10*0.d0, 1.8d0, 2.8d0, 3.6d0, 2.3d0, 1.8d0, 1.5d0, 1.3d0, 1.d0,
4657  & .7d0, .5d0, .3d0, 13*0.d0, 5.2d0, 8.7d0, 11.4d0, 14.d0, 11.9d0,
4658  & 7.6d0, 6.d0, 5.d0, 13*0.d0, 5.2d0, 8.7d0, 11.4d0, 14.d0, 11.9d0,
4659  & 7.6d0, 6.d0, 5.d0, 18*0.d0, 1.d0, 4.9d0, 8.5d0, 18*0.d0, 1.d0,
4660  & 4.9d0, 8.5d0, 15*0.d0, 1.9d0, 2.3d0, 4.d0, 6.5d0, 5.2d0, 3.4d0,
4661  & 15*0.d0, 1.9d0, 2.3d0, 4.d0, 6.5d0, 5.2d0, 3.4d0, 15*0.d0, 1.9d0,
4662  & 2.3d0, 4.d0, 6.5d0, 5.2d0, 3.4d0 /
4663 **** ko - n - data *
4664  DATA spkp15/0.d0, 20.d0, 14.d0, 12.d0, 11.5d0, 10.d0, 8.d0, 7.d0,
4665  & 6.d0, 5.5d0, 5.3d0, 5.d0, 4.5d0, 4.4d0, 3.8d0, 3.d0, 2.8d0,
4666  & 0.d0, .5d0, 1.15d0, 2.d0, 1.3d0, .8d0, .45d0, 10*0.d0,
4667  & 3*0.d0, 0.9d0, 2.5d0, 3.d0, 2.5d0, 2.3d0, 2.d0, 1.7d0,
4668  & 1.5d0, 1.2d0, .9d0, .6d0, .45d0, .21d0, .2d0,
4669  & 3*0.d0, 0.9d0, 2.5d0, 3.d0, 2.5d0, 2.3d0, 2.d0, 1.7d0,
4670  & 1.5d0, 1.2d0, .9d0, .6d0, .45d0, .21d0, .2d0,
4671  & 4*0.d0, 1.d0, 2.1d0, 2.6d0, 2.3d0, 2.1d0, 1.8d0, 1.7d0,
4672  & 1.4d0, 1.2d0, 1.05d0, .9d0, .66d0, .5d0,
4673  & 7*0.d0, .3d0, 1.d0, 1.d0, .9d0, .7d0, .4d0, .30d0, .2d0,
4674  & 11*0.d0, .1d0, 1.d0, 2.2d0, 3.5d0, 4.20d0, 4.55d0,
4675  & 4.85d0, 4.9d0,
4676  & 10*0.d0, .2d0, .7d0, 1.6d0, 2.5d0, 2.2d0, 1.71d0, 1.6d0,
4677  & 6*0.d0, 1.4d0, 3.8d0, 5.d0, 4.7d0, 4.4d0, 4.d0, 3.5d0,
4678  & 2.85d0, 2.35d0, 2.01d0, 1.8d0,
4679  & 12*0.d0, .1d0, .8d0, 2.05d0, 3.31d0, 3.5d0,
4680  & 12*0.d0, .034d0, .20d0, .75d0, 1.04d0, 1.24d0 /
4681 
4682 C444444444444444444444444444444444444444444444444444444444444444444444
4683 C44444444444444444444444444444444444444444444444444444444444444444
4684 C*** AKO - P - DATA
4685  DATA spkp16/
4686  *0.,4.,9.5,20.,13.,9.5,6.,4.4,3.,2.4,2.,1.4,1.2,1.,.9,.7,.6,
4687  *0.,4.5,6.,5.,2.5,2.,1.7,2.1,1.9,.9,.5,.3,.24,.2,.18,.1,.09,
4688  *0.,1.8,2.,1.1,.9,.5,.5,.4,.4,.2,.1,.06,.05,.04,.03,.02,.02,
4689  *0.,1.5,2.,.9,1.1,.4,.6,.7,.65,.3,.17,.1,.08,.07,.06,.04,.03,
4690  *0.,.56,1.29,2.26,1.01,.64,.37,10*0.,
4691  *4*0.,1.13,2.61,2.91,2.58,2.35,2.02,1.91,1.57,1.35,1.29,1.01,.74,
4692  *.65,
4693  *3*0.,1.00,3.03,3.36,2.8,2.58,2.24,1.91,1.68,1.35,1.01,.67,.5,.24,
4694  *.23,
4695  *3*0.,1.00,3.03,3.36,2.8,2.58,2.24,1.91,1.68,1.35,1.01,.67,.5,.24,
4696  *.23,
4697  *7*0.,.34,1.12,1.12,1.01,.78,.45,.39,.22,.07,0.,
4698  *6*0.,1.71,4.26,5.6,5.57,4.93,4.48,3.92,3.19,2.63,2.25,2.,
4699  *10*0.,.22,.8,.75,1.,1.3,1.5,1.3,
4700  *13*0.,.1,.3,.7,1., 13*0.,.1,.3,.7,1.,
4701  *9*0.,.11,1.72,2.69,3.92,4.76,5.10,5.44,5.3,
4702  *4*0.,0.00,9.2,4.7,1.9,9*0.
4703  */
4704  DATA nure/9,12,5*0,10,14,3*0,1,3,5,7,6*0,2,6,16,5*0,
4705  *10,13,5*0,11,12,3*0,2,4,6,8,6*0,3,15,7,5*0/
4706  END
4707 **sr 19-11-95: DNUPRE removed
4708 *-- Author :
4709 C
4710 C*******************************************************************
4711 C
4712  SUBROUTINE tsamcs(KPROJ,EKIN,CST)
4713  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4714 C
4715 C HJM 24/10/88
4716 C
4717 C SAMPLING OF COS(THETA)
4718 C FOR NUCLEON-PROTON ELASTIC SCATTERING
4719 C ACCORDING TO HETKFA2/BERTINI PARAMETRIZATION
4720 C
4721 C------------------------------------------------------------- ------
4722 C
4723  dimension dclin(195),dchn(143),dchna(36),dchnb(60)
4724  dimension pdci(60),pdch(55)
4725 C
4726 C--------------------------------------------------------------------
4727 C
4728  DATA (dclin(i),i=1,80) /
4729 C*** DCLN ARRAY
4730  * 5.000d-01, 1.000d+00, 0.000d+00, 1.000d+00, 0.000d+00,
4731  * 4.993d-01, 9.881d-01, 5.963d-02, 9.851d-01, 5.945d-02,
4732  * 4.936d-01, 8.955d-01, 5.224d-01, 8.727d-01, 5.091d-01,
4733  * 4.889d-01, 8.228d-01, 8.859d-01, 7.871d-01, 8.518d-01,
4734  * 4.874d-01, 7.580d-01, 1.210d+00, 7.207d-01, 1.117d+00,
4735  * 4.912d-01, 6.969d-01, 1.516d+00, 6.728d-01, 1.309d+00,
4736  * 5.075d-01, 6.471d-01, 1.765d+00, 6.667d-01, 1.333d+00,
4737  * 5.383d-01, 6.054d-01, 1.973d+00, 7.059d-01, 1.176d+00,
4738  * 5.397d-01, 5.990d-01, 2.005d+00, 7.023d-01, 1.191d+00,
4739  * 5.336d-01, 6.083d-01, 1.958d+00, 6.959d-01, 1.216d+00,
4740  * 5.317d-01, 6.075d-01, 1.962d+00, 6.897d-01, 1.241d+00,
4741  * 5.300d-01, 6.016d-01, 1.992d+00, 6.786d-01, 1.286d+00,
4742  * 5.281d-01, 6.063d-01, 1.969d+00, 6.786d-01, 1.286d+00,
4743  * 5.280d-01, 5.960d-01, 2.020d+00, 6.667d-01, 1.333d+00,
4744  * 5.273d-01, 5.920d-01, 2.040d+00, 6.604d-01, 1.358d+00,
4745  * 5.273d-01, 5.862d-01, 2.069d+00, 6.538d-01, 1.385d+00/
4746  DATA (dclin(i),i=81,160) /
4747 C*** DCIN ARRAY
4748  * 5.223d-01, 5.980d-01, 2.814d+00, 6.538d-01, 1.385d+00,
4749  * 5.202d-01, 5.969d-01, 2.822d+00, 6.471d-01, 1.412d+00,
4750  * 5.183d-01, 5.881d-01, 2.883d+00, 6.327d-01, 1.469d+00,
4751  * 5.159d-01, 5.866d-01, 2.894d+00, 6.250d-01, 1.500d+00,
4752  * 5.133d-01, 5.850d-01, 2.905d+00, 6.170d-01, 1.532d+00,
4753  * 5.106d-01, 5.833d-01, 2.917d+00, 6.087d-01, 1.565d+00,
4754  * 5.084d-01, 5.801d-01, 2.939d+00, 6.000d-01, 1.600d+00,
4755  * 5.063d-01, 5.763d-01, 2.966d+00, 5.909d-01, 1.636d+00,
4756  * 5.036d-01, 5.730d-01, 2.989d+00, 5.814d-01, 1.674d+00,
4757  * 5.014d-01, 5.683d-01, 3.022d+00, 5.714d-01, 1.714d+00,
4758  * 4.986d-01, 5.641d-01, 3.051d+00, 5.610d-01, 1.756d+00,
4759  * 4.964d-01, 5.580d-01, 3.094d+00, 5.500d-01, 1.800d+00,
4760  * 4.936d-01, 5.573d-01, 3.099d+00, 5.431d-01, 1.827d+00,
4761  * 4.909d-01, 5.509d-01, 3.144d+00, 5.313d-01, 1.875d+00,
4762  * 4.885d-01, 5.512d-01, 3.142d+00, 5.263d-01, 1.895d+00,
4763  * 4.857d-01, 5.437d-01, 3.194d+00, 5.135d-01, 1.946d+00/
4764  DATA (dclin(i),i=161,195) /
4765  * 4.830d-01, 5.353d-01, 3.253d+00, 5.000d-01, 2.000d+00,
4766  * 4.801d-01, 5.323d-01, 3.274d+00, 4.915d-01, 2.034d+00,
4767  * 4.770d-01, 5.228d-01, 3.341d+00, 4.767d-01, 2.093d+00,
4768  * 4.738d-01, 5.156d-01, 3.391d+00, 4.643d-01, 2.143d+00,
4769  * 4.701d-01, 5.010d-01, 3.493d+00, 4.444d-01, 2.222d+00,
4770  * 4.672d-01, 4.990d-01, 3.507d+00, 4.375d-01, 2.250d+00,
4771  * 4.634d-01, 4.856d-01, 3.601d+00, 4.194d-01, 2.323d+00/
4772 C
4773  DATA pdci /
4774  * 4.400d+02, 1.896d-01, 1.931d-01, 1.982d-01, 1.015d-01,
4775  * 1.029d-01, 4.180d-02, 4.228d-02, 4.282d-02, 4.350d-02,
4776  * 2.204d-02, 2.236d-02, 5.900d+02, 1.433d-01, 1.555d-01,
4777  * 1.774d-01, 1.000d-01, 1.128d-01, 5.132d-02, 5.600d-02,
4778  * 6.158d-02, 6.796d-02, 3.660d-02, 3.820d-02, 6.500d+02,
4779  * 1.192d-01, 1.334d-01, 1.620d-01, 9.527d-02, 1.141d-01,
4780  * 5.283d-02, 5.952d-02, 6.765d-02, 7.878d-02, 4.796d-02,
4781  * 6.957d-02, 8.000d+02, 4.872d-02, 6.694d-02, 1.152d-01,
4782  * 9.348d-02, 1.368d-01, 6.912d-02, 7.953d-02, 9.577d-02,
4783  * 1.222d-01, 7.755d-02, 9.525d-02, 1.000d+03, 3.997d-02,
4784  * 5.456d-02, 9.804d-02, 8.084d-02, 1.208d-01, 6.520d-02,
4785  * 8.233d-02, 1.084d-01, 1.474d-01, 9.328d-02, 1.093d-01/
4786 C
4787  DATA pdch /
4788  * 1.000d+03, 9.453d-02, 9.804d-02, 8.084d-02, 1.208d-01,
4789  * 6.520d-02, 8.233d-02, 1.084d-01, 1.474d-01, 9.328d-02,
4790  * 1.093d-01, 1.400d+03, 1.072d-01, 7.450d-02, 6.645d-02,
4791  * 1.136d-01, 6.750d-02, 8.580d-02, 1.110d-01, 1.530d-01,
4792  * 1.010d-01, 1.350d-01, 2.170d+03, 4.004d-02, 3.013d-02,
4793  * 2.664d-02, 5.511d-02, 4.240d-02, 7.660d-02, 1.364d-01,
4794  * 2.300d-01, 1.670d-01, 2.010d-01, 2.900d+03, 1.870d-02,
4795  * 1.804d-02, 1.320d-02, 2.970d-02, 2.860d-02, 5.160d-02,
4796  * 1.020d-01, 2.400d-01, 2.250d-01, 3.370d-01, 4.400d+03,
4797  * 1.196d-03, 8.784d-03, 1.517d-02, 2.874d-02, 2.488d-02,
4798  * 4.464d-02, 8.330d-02, 2.008d-01, 2.360d-01, 3.567d-01/
4799 C
4800  DATA (dchn(i),i=1,90) /
4801  * 4.770d-01, 4.750d-01, 4.715d-01, 4.685d-01, 4.650d-01,
4802  * 4.610d-01, 4.570d-01, 4.550d-01, 4.500d-01, 4.450d-01,
4803  * 4.405d-01, 4.350d-01, 4.300d-01, 4.250d-01, 4.200d-01,
4804  * 4.130d-01, 4.060d-01, 4.000d-01, 3.915d-01, 3.840d-01,
4805  * 3.760d-01, 3.675d-01, 3.580d-01, 3.500d-01, 3.400d-01,
4806  * 3.300d-01, 3.200d-01, 3.100d-01, 3.000d-01, 2.900d-01,
4807  * 2.800d-01, 2.700d-01, 2.600d-01, 2.500d-01, 2.400d-01,
4808  * 2.315d-01, 2.240d-01, 2.150d-01, 2.060d-01, 2.000d-01,
4809  * 1.915d-01, 1.850d-01, 1.780d-01, 1.720d-01, 1.660d-01,
4810  * 1.600d-01, 1.550d-01, 1.500d-01, 1.450d-01, 1.400d-01,
4811  * 1.360d-01, 1.320d-01, 1.280d-01, 1.250d-01, 1.210d-01,
4812  * 1.180d-01, 1.150d-01, 1.120d-01, 1.100d-01, 1.070d-01,
4813  * 1.050d-01, 1.030d-01, 1.010d-01, 9.900d-02, 9.700d-02,
4814  * 9.550d-02, 9.480d-02, 9.400d-02, 9.200d-02, 9.150d-02,
4815  * 9.100d-02, 9.000d-02, 8.990d-02, 8.900d-02, 8.850d-02,
4816  * 8.750d-02, 8.700d-02, 8.650d-02, 8.550d-02, 8.500d-02,
4817  * 8.499d-02, 8.450d-02, 8.350d-02, 8.300d-02, 8.250d-02,
4818  * 8.150d-02, 8.100d-02, 8.030d-02, 8.000d-02, 7.990d-02/
4819  DATA (dchn(i),i=91,143) /
4820  * 7.980d-02, 7.950d-02, 7.900d-02, 7.860d-02, 7.800d-02,
4821  * 7.750d-02, 7.650d-02, 7.620d-02, 7.600d-02, 7.550d-02,
4822  * 7.530d-02, 7.500d-02, 7.499d-02, 7.498d-02, 7.480d-02,
4823  * 7.450d-02, 7.400d-02, 7.350d-02, 7.300d-02, 7.250d-02,
4824  * 7.230d-02, 7.200d-02, 7.100d-02, 7.050d-02, 7.020d-02,
4825  * 7.000d-02, 6.999d-02, 6.995d-02, 6.993d-02, 6.991d-02,
4826  * 6.990d-02, 6.870d-02, 6.850d-02, 6.800d-02, 6.780d-02,
4827  * 6.750d-02, 6.700d-02, 6.650d-02, 6.630d-02, 6.600d-02,
4828  * 6.550d-02, 6.525d-02, 6.510d-02, 6.500d-02, 6.499d-02,
4829  * 6.498d-02, 6.496d-02, 6.494d-02, 6.493d-02, 6.490d-02,
4830  * 6.488d-02, 6.485d-02, 6.480d-02/
4831 C
4832  DATA dchna /
4833  * 6.300d+02, 7.810d-02, 1.421d-01, 1.979d-01, 2.479d-01,
4834  * 3.360d-01, 5.400d-01, 7.236d-01, 1.000d+00, 1.540d+03,
4835  * 2.225d-01, 3.950d-01, 5.279d-01, 6.298d-01, 7.718d-01,
4836  * 9.405d-01, 9.835d-01, 1.000d+00, 2.560d+03, 2.625d-01,
4837  * 4.550d-01, 5.963d-01, 7.020d-01, 8.380d-01, 9.603d-01,
4838  * 9.903d-01, 1.000d+00, 3.520d+03, 4.250d-01, 6.875d-01,
4839  * 8.363d-01, 9.163d-01, 9.828d-01, 1.000d+00, 1.000d+00,
4840  * 1.000d+00/
4841 C
4842  DATA dchnb /
4843  * 6.300d+02, 3.800d-02, 7.164d-02, 1.275d-01, 2.171d-01,
4844  * 3.227d-01, 4.091d-01, 5.051d-01, 6.061d-01, 7.074d-01,
4845  * 8.434d-01, 1.000d+00, 2.040d+03, 1.200d-01, 2.115d-01,
4846  * 3.395d-01, 5.295d-01, 7.251d-01, 8.511d-01, 9.487d-01,
4847  * 9.987d-01, 1.000d+00, 1.000d+00, 1.000d+00, 2.200d+03,
4848  * 1.344d-01, 2.324d-01, 3.754d-01, 5.674d-01, 7.624d-01,
4849  * 8.896d-01, 9.808d-01, 1.000d+00, 1.000d+00, 1.000d+00,
4850  * 1.000d+00, 2.850d+03, 2.330d-01, 4.130d-01, 6.610d-01,
4851  * 9.010d-01, 9.970d-01, 1.000d+00, 1.000d+00, 1.000d+00,
4852  * 1.000d+00, 1.000d+00, 1.000d+00, 3.500d+03, 3.300d-01,
4853  * 5.450d-01, 7.950d-01, 1.000d+00, 1.000d+00, 1.000d+00,
4854  * 1.000d+00, 1.000d+00, 1.000d+00, 1.000d+00, 1.000d+00/
4855 C
4856 C---------------------------------------------------------------
4857  cst=1d0
4858 C
4859 C* IS THE KINETIC ENERGY GREATER THAN LIMIT ?
4860 C
4861  IF (ekin.GT.3.5d0) RETURN
4862 C
4863  IF(kproj.EQ.8) goto 101
4864  IF(kproj.EQ.1) goto 102
4865 C* INVALID REACTION
4866  WRITE(6,'(A,I5/A)')
4867  & ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',kproj,
4868  & ' COS(THETA) = 1D0 RETURNED'
4869  RETURN
4870 C-------------------------------- NP ELASTIC SCATTERING----------
4871 101 CONTINUE
4872  IF (ekin.GT.0.740d0)goto 1000
4873  IF (ekin.LT.0.300d0)THEN
4874 C EKIN .LT. 300 MEV
4875  idat=1
4876  ELSE
4877 C 300 MEV < EKIN < 740 MEV
4878  idat=6
4879  END IF
4880 C
4881  ener=ekin
4882  ie=abs(ener/0.020d0)
4883  univ=(ener-float(ie)*0.020d0)/0.020d0
4884 C FORWARD/BACKWARD DECISION
4885  k=idat+5*ie
4886  bwfw=(dclin(k+5)-dclin(k))*univ + dclin(k)
4887  IF (rndm(v).LT.bwfw)THEN
4888  value2=-1d0
4889  k=k+1
4890  ELSE
4891  value2=1d0
4892  k=k+3
4893  END IF
4894 C
4895  coef=(dclin(k+5)-dclin(k))*univ + dclin(k)
4896  rnd=rndm(v)
4897 C
4898  IF(rnd.LT.coef)THEN
4899  cst=rndm(v)
4900  cst=cst*value2
4901  ELSE
4902  r1=rndm(v)
4903  r2=rndm(v)
4904  r3=rndm(v)
4905  r4=rndm(v)
4906 C
4907  IF(value2.GT.0.0)THEN
4908  cst=max(r1,r2,r3,r4)
4909  goto 1500
4910  ELSE
4911  r5=rndm(v)
4912 C
4913  IF (idat.EQ.1)THEN
4914  cst=-max(r1,r2,r3,r4,r5)
4915  ELSE
4916  r6=rndm(v)
4917  r7=rndm(v)
4918  cst=-max(r1,r2,r3,r4,r5,r6,r7)
4919  END IF
4920 C
4921  END IF
4922 C
4923  END IF
4924 C
4925  goto 1500
4926 C
4927 C******** EKIN .GT. 0.74 GEV
4928 C
4929 1000 ener=ekin - 0.66
4930 C IE=ABS(ENER/0.02)
4931  ie=ener/0.02
4932  emev=ekin*1d3
4933 C
4934  univ=(ener-float(ie)*0.020d0)/0.020d0
4935  k=ie
4936  bwfw=(dchn(k+1)-dchn(k))*univ + dchn(k)
4937  rnd=rndm(v)
4938 C FORWARD NEUTRON
4939  IF (rnd.GE.bwfw)THEN
4940  DO 1200 k=10,36,9
4941  IF (dchna(k).GT.emev) THEN
4942  unive=(emev-dchna(k-9))/(dchna(k)-dchna(k-9))
4943  univ=rndm(v)
4944  DO 1100 i=1,8
4945  ii=k+i
4946  p=(dchna(ii)-dchna(ii-9))*unive + dchna(ii-9)
4947 C
4948  IF (p.GT.univ)THEN
4949  univ=rndm(v)
4950  flti=float(i)-univ
4951  goto(290,290,290,290,330,340,350,360) i
4952  END IF
4953  1100 CONTINUE
4954  END IF
4955  1200 CONTINUE
4956 C
4957  ELSE
4958 C BACKWARD NEUTRON
4959  DO 1400 k=13,60,12
4960  IF (dchnb(k).GT.emev) THEN
4961  unive=(emev-dchnb(k-12))/(dchnb(k)-dchnb(k-12))
4962  univ=rndm(v)
4963  DO 1300 i=1,11
4964  ii=k+i
4965  p=(dchnb(ii)-dchnb(ii-12))*unive + dchnb(ii-12)
4966 C
4967  IF (p.GT.univ)THEN
4968  univ=rndm(v)
4969  flti=float(i)-univ
4970  goto(120,120,140,150,160,160,180,190,200,210,220) i
4971  END IF
4972  1300 CONTINUE
4973  END IF
4974  1400 CONTINUE
4975  END IF
4976 C
4977 120 cst=1.0d-2*flti-1.0d0
4978  goto 1500
4979 140 cst=2.0d-2*univ-0.98d0
4980  goto 1500
4981 150 cst=4.0d-2*univ-0.96d0
4982  goto 1500
4983 160 cst=6.0d-2*flti-1.16d0
4984  goto 1500
4985 180 cst=8.0d-2*univ-0.80d0
4986  goto 1500
4987 190 cst=1.0d-1*univ-0.72d0
4988  goto 1500
4989 200 cst=1.2d-1*univ-0.62d0
4990  goto 1500
4991 210 cst=2.0d-1*univ-0.50d0
4992  goto 1500
4993 220 cst=3.0d-1*(univ-1.0d0)
4994  goto 1500
4995 C
4996 290 cst=1.0d0-2.5d-2*flti
4997  goto 1500
4998 330 cst=0.85d0+0.5d-1*univ
4999  goto 1500
5000 340 cst=0.70d0+1.5d-1*univ
5001  goto 1500
5002 350 cst=0.50d0+2.0d-1*univ
5003  goto 1500
5004 360 cst=0.50d0*univ
5005 C
5006 1500 RETURN
5007 C
5008 C----------------------------------- PP ELASTIC SCATTERING -------
5009 C
5010  102 CONTINUE
5011  emev=ekin*1d3
5012 C
5013  IF (ekin.LE.0.500d0) THEN
5014  rnd=rndm(v)
5015  cst=2.0d0*rnd-1.0d0
5016  RETURN
5017 C
5018  ELSEIF (ekin.LT.1.0d0) THEN
5019  DO 2200 k=13,60,12
5020  IF (pdci(k).GT.emev) THEN
5021  unive=(emev-pdci(k-12))/(pdci(k)-pdci(k-12))
5022  univ=rndm(v)
5023  sum=0
5024  DO 2100 i=1,11
5025  ii=k+i
5026  sum=sum + (pdci(ii)-pdci(ii-12))*unive + pdci(ii-12)
5027 C
5028  IF (univ.LT.sum)THEN
5029  univ=rndm(v)
5030  flti=float(i)-univ
5031  goto(55,55,55,60,60,65,65,65,65,70,70) i
5032  END IF
5033  2100 CONTINUE
5034  END IF
5035  2200 CONTINUE
5036  ELSE
5037  DO 2400 k=12,55,11
5038  IF (pdch(k).GT.emev) THEN
5039  unive=(emev-pdch(k-11))/(pdch(k)-pdch(k-11))
5040  univ=rndm(v)
5041  sum=0.0
5042  DO 2300 i=1,10
5043  ii=k+i
5044  sum=sum + (pdch(ii)-pdch(ii-11))*unive + pdch(ii-11)
5045 C
5046  IF (univ.LT.sum)THEN
5047  univ=rndm(v)
5048  flti=univ+float(i)
5049  goto(50,55,60,60,65,65,65,65,70,70) i
5050  END IF
5051  2300 CONTINUE
5052  END IF
5053  2400 CONTINUE
5054  END IF
5055 C
5056 50 cst=0.4d0*univ
5057  goto 2500
5058 55 cst=0.2d0*flti
5059  goto 2500
5060 60 cst=0.3d0+0.1d0*flti
5061  goto 2500
5062 65 cst=0.6d0+0.04d0*flti
5063  goto 2500
5064 70 cst=0.78d0+0.02d0*flti
5065 C
5066 2500 CONTINUE
5067  IF (rndm(v).GT.0.5d0) cst=-cst
5068 C
5069  RETURN
5070  END
5071 *-- Author :
5072 C
5073 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5074 C
5075 c/* *************************************************************
5076 c/* 27/10/89
5077 c/* TEST OF CROSS SECTION routines
5078 C actually applied in dtunuc90:
5079 c/* SHPTOT (called from SHMAKI)
5080 c/* SIHNIN, SIHNEL (called from FOZOKL)
5081 c/* *************************************************************
5082 C
5083  SUBROUTINE sigtes
5084  IMPLICIT DOUBLE PRECISION (a-h,o-z)
5085 C
5086 *KEEP,PANAME.
5087 C------------------
5088 C
5089 C /PANAME/ CONTAINS PARTICLE NAMES
5090 C BTYPE = LITERAL NAME OF THE PARTICLE
5091 C
5092  CHARACTER*8 btype
5093  COMMON /paname/ btype(30)
5094 *KEEP,DPAR.
5095 C /DPAR/ CONTAINS PARTICLE PROPERTIES
5096 C ANAME = LITERAL NAME OF THE PARTICLE
5097 C AAM = PARTICLE MASS IN GEV
5098 C GA = DECAY WIDTH
5099 C TAU = LIFE TIME OF INSTABLE PARTICLES
5100 C IICH = ELECTRIC CHARGE OF THE PARTICLE
5101 C IIBAR = BARYON NUMBER
5102 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
5103 C
5104  CHARACTER*8 aname
5105  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
5106  +iibar(210),k1(210),k2(210)
5107 C------------------
5108 *KEND.
5109  parameter(npa=45,ipmax=16)
5110  dimension kproj(ipmax)
5111  dimension p(npa),ek(npa),pl(180)
5112  dimension sigma(npa,4)
5113  DATA p /0.13, 0.19, 0.25, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9, 1.0,
5114  +1.1, 1.2, 1.3, 1.4, 1.5, 2.0, 3.0, 4.0, 5.0, 6.0, 10.0, 20., 50.,
5115  +100., 200., 400., 1000., 5000., 10000.,
5116  +20000.,50000.,100000.,200000.,500000.,1000000.,2000000.,
5117  +5000000.,10000000.,20000000.,50000000.,100000000.,
5118  +200000000.,500000000.,1000000000./
5119  DATA kproj / 1, 8, 13, 14, 15, 16, 24, 25, 2, 9, 17, 18, 20, 21,
5120  +22, 23/
5121 C********************************************************************
5122  WRITE(6,'(1H1)')
5123  WRITE(6,'(2A)') ' TEST OF CROSS SECTIONS ROUTINES APPLIED:',
5124  +' SHPTOT, SIHNIN, SIHNEL(SIGEL)'
5125  WRITE(6,'(A,5X,A)') ' PRINTED FOR EACH MOMENTUM/KINETIC ENERGY:',
5126  +' SIHNEL , SIHNIN / (SIHNEL+SIHNIN), SHPTOT'
5127 
5128 C LOOP OVER PROJECTILES
5129 C AA=1.0
5130  DO 50 ipr=1,ipmax
5131  kpro=kproj(ipr)
5132  DO 20 ie=1,npa
5133  ek(ie)=sqrt(p(ie)**2+aam(kpro)**2) - aam(kpro)
5134 C CALL SIGEL(KPRO,AA,P(IE),SIEL1,ZLEL)
5135  CALL sihnel(kpro,1,p(ie),siel)
5136 C CALL NIZL(KPRO,AA,P(IE),SIIN1,ZLIN)
5137  CALL sihnin(kpro,1,p(ie),siin)
5138  sigma(ie,2)=siin
5139  sigma(ie,1)=siel
5140  sigma(ie,4)=siin + siel
5141  sigma(ie,3)=dshpto(kpro,p(ie))
5142  DO 10 im=0,3
5143  iie=im*npa +ie
5144  pl(iie)=log10(p(ie))
5145  10 CONTINUE
5146  20 CONTINUE
5147 C
5148  WRITE(6,'(1H1,A,I3,2A)') ' PROJECTILE IPRO=', kpro, ' - ',
5149  + btype(kpro)
5150  WRITE(6,'(//A/2A/)')
5151  + ' TABLE OF CROSS SECTION VALUES VERSUS PLAB / EKIN:',
5152  + ' PLAB, EKIN / SIG(EL), SIG(INEL) /',
5153  + ' SIG(TOT)-USED,SIG(EL)+SIG(INEL) - TEST PRINT'
5154 C
5155  DO 30 ie=1,npa
5156  WRITE(6,1000) p(ie),ek(ie), (sigma(ie,is),is=1,4)
5157  30 CONTINUE
5158 C
5159  DO 40 im=1,3
5160  DO 40 ie=1,npa
5161  sigma(ie,im)=log10(sigma(ie,im))
5162  40 CONTINUE
5163  WRITE(6,'(///A//)')
5164  + ' DOUBLE-LOG PLOT OF SIGMA(EL/INEL/TOT/SUM EL+INEL) VS PLAB'
5165  npoi=4*npa
5166  CALL plot(pl,sigma,npoi,4,npa,-1.0d0,0.2d0,0.0d0,0.050d0)
5167 C
5168  50 CONTINUE
5169 C*****************
5170  1000 FORMAT(2(1pe10.2),5x,4(1pe12.3))
5171 C
5172  END
c2_transformation::zero
static float_type zero(float_type)
utility function f(x)=0 useful in axis transforms
Definition: c2_function.hh:1203
HepGeom::Transform3D::yy
double yy() const
Definition: Transform3D.h:264
dtwopa
subroutine dtwopa(E1, E2, P1, P2, COD1, COD2, COF1, COF2, SIF1, SIF2, IT1, IT2, UMOO, ECM, P, N, AM1, AM2)
Definition: dpm25hadri.f:3308
dhadri
subroutine dhadri(N, PLAB, ELAB, CX, CY, CZ, ITTA)
Definition: dpm25hadri.f:2433
G4StokesVector::p2
G4double p2() const
Definition: G4StokesVector.hh:75
s
const XML_Char * s
Definition: include/expat.h:262
dchanh
subroutine dchanh
Definition: dpm25hadri.f:2993
z
G4double z
Definition: TRTMaterials.hh:39
dtwopd
subroutine dtwopd(UMO, ECM1, ECM2, PCM1, PCM2, COD1, COF1, SIF1, COD2, COF2, SIF2, AM1, AM2)
Definition: dpm25nuc7.f:3326
p
const char * p
Definition: xmltok.h:285
dhadde
subroutine dhadde
Definition: dpm25hadri.f:3098
dtrafo
subroutine dtrafo(GAM, BGAM, CX, CY, CZ, COD, COF, SIF, P, ECM, PL, CXL, CYL, CZL, EL)
Definition: dpm25nuc3.f:7346
G4CascadeCheckBalance::ekin
G4double ekin(const G4LorentzVector &p) const
Definition: G4CascadeCheckBalance.hh:153
dsige
subroutine dsige(IT, AA, POO, SEL, ZL)
Definition: dpm25hadri.f:606
iefund
function iefund(PL, IRE)
Definition: dpm25hadri.f:3168
sigtes
subroutine sigtes
Definition: dpm25hadri.f:5083
dshnto
double precision function dshnto(KPROJ, KTARG, UMO)
Definition: dpm25diff.f:3503
a
G4double a
Definition: TRTMaterials.hh:39
HepGeom::Plane3D::d
T d() const
Definition: Plane3D.h:86
sihnin
subroutine sihnin(IPROJ, ITAR, PO, SIIN)
Definition: dpm25hadri.f:2176
nmxhkk
const int nmxhkk
Definition: G4DPMJET2_5Interface.hh:78
dsigin
subroutine dsigin(IRE, PLAB, N, IE, AMT, AMN, ECM, SI, ITAR)
Definition: dpm25hadri.f:3209
dtchoi
subroutine dtchoi(T, P, PP, E, EE, I, II, N, AM1, AM2)
Definition: dpm25hadri.f:3250
c2_transformation::one
static float_type one(float_type)
utility function f(x)=1 useful in axis transforms
Definition: c2_function.hh:1201
plot
subroutine plot(X, Y, N, M, MM, XO, DX, YO, DY)
Definition: dpm25nulib.f:176
dshpto
double precision function dshpto(IT, PO)
Definition: dpm25hadri.f:1824
drandm
subroutine drandm(X)
Definition: dpm25hadri.f:3381
fhad
subroutine fhad(IPRMOD, IPRO, PLAB, ELAB, CX, CY, CZ, ITHKK, ITTA, IELINE, IREJFH)
Definition: dpm25hadri.f:4
daltra
subroutine daltra(GA, BGX, BGY, BGZ, PCX, PCY, PCZ, EC, P, PX, PY, PZ, E)
Definition: dpm25nulib.f:542
G4StokesVector::p1
G4double p1() const
Definition: G4StokesVector.hh:74
rexp
double precision function rexp(W)
Definition: dpm25hadri.f:2849
n
const G4int n
Definition: G4UrQMD1_3Interface.hh:144
rndm
double precision function rndm(RDUMMY)
Definition: dpm25nulib.f:1460
elhain
subroutine elhain(IP, PLA, ELAB, CX, CY, CZ, IT, IREJ)
Definition: dpm25hadri.f:335
HepGeom::Transform3D::xy
double xy() const
Definition: Transform3D.h:255
dcosi
subroutine dcosi(SFE, CFE)
Definition: dpm25hadri.f:3349
dcalum
subroutine dcalum(N, ITTA)
Definition: dpm25hadri.f:2946
damg
double precision function damg(IT)
Definition: dpm25hadri.f:2907
dsfecf
subroutine dsfecf(SFE, CFE)
Definition: dpm25nuc7.f:3354
xshpto
double precision function xshpto(IT, PO)
Definition: dpm25hadri.f:1855
c2_factory::log
static c2_log_p< float_type > & log()
make a *new object
Definition: c2_factory.hh:138
G4Abla::tau
G4double tau(G4double bet, G4double homega, G4double ef, G4double t)
Definition: G4Abla.cc:2586
HepGeom::Transform3D::xx
double xx() const
Definition: Transform3D.h:252
c2_factory::sqrt
static c2_sqrt_p< float_type > & sqrt()
make a *new object
Definition: c2_factory.hh:142
G4Abla::f
G4double f(G4double E)
Definition: G4Abla.cc:3026
drtran
subroutine drtran(XO, YO, ZO, CDE, SDE, SFE, CFE, X, Y, Z)
Definition: dpm25nuc7.f:3265
dsihae
subroutine dsihae(KPROJ, EKIN, PLAB, ANUC, SIGELA)
Definition: dpm25hadri.f:1005
dgauss
subroutine dgauss(X, A, S)
Definition: dpm25hadri.f:3365
dthrep
subroutine dthrep(UMO, ECM1, ECM2, ECM3, PCM1, PCM2, PCM3, COD1, COF1, SIF1, COD2, COF2, SIF2, COD3, COF3, SIF3, AM1, AM2, AM3)
Definition: dpm25nuc7.f:2748
tsamcs
subroutine tsamcs(KPROJ, EKIN, CST)
Definition: dpm25hadri.f:4712
sihnel
subroutine sihnel(IPROJ, ITAR, POO, SIEL)
Definition: dpm25hadri.f:448
c2_factory::exp
static c2_exp_p< float_type > & exp()
make a *new object
Definition: c2_factory.hh:140
Generated on Wed Apr 30 2014 15:54:30 for Geant4.10 by   doxygen 1.8.7