Back to home page

Project CMSSW displayed by LXR

 
 

    


File indexing completed on 2021-02-14 13:07:29

0001 c-----------------------------------------------------------------------
0002       subroutine bjinta(ier)
0003 c-----------------------------------------------------------------------
0004 c  fin. state interactions and decays
0005 c-----------------------------------------------------------------------
0006       include 'epos.inc'
0007       double precision tpro,zpro,ttar,ztar,ttaus,detap,detat
0008       common/cttaus/tpro,zpro,ttar,ztar,ttaus,detap,detat /ctimel/ntc
0009       common/col3/ncol,kolpt
0010       double precision ttaun,ttau0,rcproj,rctarg
0011       common/cttaun/ttaun /cttau0/ttau0 /geom1/rcproj,rctarg
0012       logical go,lclean
0013 
0014       call utpri('bjinta',ish,ishini,4)
0015 
0016       ier=0
0017 
0018       if(ncol.eq.0.and.iappl.eq.2)goto1000
0019       if(nevt.ne.1.or.ifrade.eq.0)goto1000
0020 
0021       if(iappl.eq.4.or.iappl.eq.9)then
0022         goto5000
0023       endif
0024 
0025       !if(iappl.eq.1)then
0026       !  tauxx=0.7+0.94*max(radnuc(maproj),radnuc(matarg))/(0.5*engy)
0027       !else
0028       !  tauxx=0.
0029       !endif
0030       !tauzz=max(taumin,tauxx)
0031       !print*,'====',taumin,tauxx,tauzz
0032       !ttaus=dble(tauzz)
0033       ttaus=taumin
0034       ttau0=dsqrt(rcproj*rctarg)
0035       call jtauin   ! initialize hyperbola
0036 
0037       if(iappl.ne.1)goto 5000
0038 
0039 
0040 c     no-secondary-interactions or parton-ladder-fusion
0041 c     -------------------------------------------------
0042       if(iorsce.eq.0.and.iorsdf.eq.0.and.iorshh.eq.0
0043      &      .or.iorsdf.eq.3)then
0044         if(iorsdf.eq.3)then
0045           lclean=.false.
0046           if(nclean.gt.0.and.nptl.gt.mxptl/5)then
0047             ! if nptl already very big, clean up useless particles in cptl list.
0048             !(do not use it when gakstr() is called (some information lost)
0049             nptli=maproj+matarg+1
0050             do iii=nptli,nptl
0051               go=.true.
0052               if(nclean.eq.1.and.istptl(iii).le.istmax)go=.false.
0053               if(go.and.mod(istptl(iii),10).ne.0)istptl(iii)=99
0054             enddo
0055             nptl0=nptl
0056             call utclea(nptli,nptl0)
0057             lclean=.true.
0058           endif
0059           nptlbpo=nptl
0060           call jintpo(lclean,iret)  !parton-ladder-fusion
0061          if(ish.ge.2)call alist('parton-ladder-fusion&',nptlbpo+1,nptl)
0062          if(iret.eq.1)goto 1001
0063         endif
0064         goto 5000
0065       else
0066         stop'bjinta: not supported any more (310305).     '
0067       endif
0068 
0069 5000  continue
0070 
0071       nptlbd=nptl
0072 
0073       call xSpaceTime
0074 
0075       if(ifrade.eq.0)goto779  !skip decay
0076       if(idecay.eq.0)goto779  !skip decay
0077 
0078 
0079       if(ish.ge.2)call alist('final decay&',0,0)
0080       if(iappl.eq.4.or.iappl.eq.7.or.iappl.eq.9)then
0081         nptli=1
0082       else
0083         nptli=maproj+matarg+1
0084       endif
0085       np1=nptli
0086 41    np2=nptl
0087       nptli=np1
0088       ip=np1-1
0089       do while (ip.lt.np2)
0090       ip=ip+1
0091       if(istptl(ip).eq.0)then
0092       call hdecas(ip,iret)
0093       if(iret.eq.1)goto 1001
0094       if(iret.eq.-1)goto 42
0095 c remove useless particles if not enough space
0096       if(nclean.gt.0.and.nptl.gt.mxptl/2)then
0097         nnnpt=0
0098         do iii=nptli,ip
0099           go=.true.
0100           if(nclean.eq.1.and.istptl(iii).le.istmax)go=.false.
0101           if(go.and.mod(istptl(iii),10).ne.0)then
0102             istptl(iii)=99
0103             nnnpt=nnnpt+1
0104           endif
0105         enddo
0106         if(nnnpt.gt.mxptl-nptl)then
0107           nptl0=nptl
0108           call utclea(nptli,nptl0)
0109           np2=np2-nnnpt
0110           ip=ip-nnnpt
0111           nptli=ip
0112         endif
0113       endif
0114       endif
0115 42    continue
0116       enddo
0117       nptli=max(nptli,np1)
0118       np1=np2+1
0119       if(np1.le.nptl)then
0120       if(ish.ge.2)then
0121       if(ish.ge.3)call alist('partial list&',0,0)
0122       do 6 ip=np1,nptl
0123         call alist('&',ip,ip)
0124 6     continue
0125       endif
0126       goto 41
0127       endif
0128   779 continue
0129 
0130 c      if(ish.ge.2)call alist('complete list&',1,nptl)
0131 
0132 c     on shell check
0133 c     --------------
0134 c      if(iappl.eq.1)call jresc
0135 
0136 1000  continue
0137       call utprix('bjinta',ish,ishini,4)
0138       return
0139 
0140 1001  continue
0141       ier=1
0142       goto 1000
0143 
0144       end
0145 
0146 cc----------------------------------------------------------------------
0147 c      subroutine jintcs(i,j,ecm,bij,nq,jc,ics)
0148 cc----------------------------------------------------------------------
0149 cc compare hadron distance with energy dependent cross section
0150 cc data taken from particle data group, durham and juelich
0151 cc input:
0152 cc   i,j: particle indices
0153 cc   ecm: center-of-mass energy
0154 cc   bij: impact parameter
0155 cc   nq: net quark number of fused object
0156 cc   jc: jc of fused object
0157 cc output:
0158 cc   ics=0 if distance larger than sqrt(sig(E_CMS)/pi)
0159 cc   ics=1 else
0160 cc The data are from HEPDATA,
0161 cc the formulas from Rev. Particle Properties 1995
0162 cc----------------------------------------------------------------------
0163 c      include 'epos.inc'
0164 c      integer jci(nflav,2),jcj(nflav,2),jc(nflav,2),kc(nflav)
0165 c     *,kci(nflav),kcj(nflav)
0166 c      common/cxyzt/xptl(mxptl),yptl(mxptl),zptl(mxptl),tptl(mxptl)
0167 c     *,optl(mxptl),uptl(mxptl),sptl(mxptl),rptl(mxptl,3)
0168 c      parameter(npp=249,napp=205,npn=411,napn=31,npip=441)
0169 c      parameter(npim=578,nkmp=299,nkmn=41,nkpp=172,nkpn=91)
0170 cc      parameter(npim=578,nkmp=299,nkmn=41,nkpp=172,nkpn=91,nlp=35)
0171 c      parameter(npi1=12,npi2=12,npi3=18,npi4=21,npi5=9)
0172 cc      real ppecm(npp)
0173 c      real ppbmx(npp)
0174 c      real appecm(napp),appbmx(napp)
0175 c      real pnecm(npn),pnbmx(npn)
0176 c      real apnecm(napn),apnbmx(napn)
0177 c      real pipecm(npip),pipbmx(npip)
0178 c      real pimecm(npim),pimbmx(npim)
0179 c      real kmpecm(nkmp),kmpbmx(nkmp)
0180 c      real kmnecm(nkmn),kmnbmx(nkmn)
0181 c      real kppecm(nkpp),kppbmx(nkpp)
0182 c      real kpnecm(nkpn),kpnbmx(nkpn)
0183 cc      real lpecm(nlp),lpbmx(nlp)
0184 c      real pi1ecm(npi1),pi1bmx(npi1)
0185 c      real pi2ecm(npi2),pi2bmx(npi2)
0186 c      real pi3ecm(npi3),pi3bmx(npi3)
0187 c      real pi4ecm(npi4),pi4bmx(npi4)
0188 c      real pi5ecm(npi5),pi5bmx(npi5)
0189 c
0190 cc      data ppecm/
0191 cc     *    1.8812,   1.8855,   1.8910,   1.8963,   1.9073
0192 cc     *,   1.9108,   1.9145,   1.9224,   1.9244,   1.9352
0193 cc     *,   1.9466,   1.9468,   1.9542,   1.9592,   1.9636
0194 cc     *,   1.9772,   1.9860,   1.9945,   2.0032,   2.0052
0195 cc     *,   2.0070,   2.0272,   2.0275,   2.0302,   2.0333
0196 cc     *,   2.0402,   2.0427,   2.0586,   2.0608,   2.0692
0197 cc     *,   2.0702,   2.0708,   2.0715,   2.0718,   2.0751
0198 cc     *,   2.0797,   2.0813,   2.0829,   2.0843,   2.0846
0199 cc     *,   2.0935,   2.1062,   2.1113,   2.1123,   2.1170
0200 cc     *,   2.1173,   2.1184,   2.1268,   2.1289,   2.1357
0201 cc     *,   2.1467,   2.1511,   2.1522,   2.1553,   2.1618
0202 cc     *,   2.1639,   2.1726,   2.1771,   2.1795,   2.1799
0203 cc     *,   2.1802,   2.1813,   2.1868,   2.2152,   2.2184
0204 cc     *,   2.2212,   2.2254,   2.2395,   2.2405,   2.2532
0205 cc     *,   2.2606,   2.2613,   2.2861,   2.2889,   2.2914
0206 cc     *,   2.2988,   2.3101,   2.3136,   2.3228,   2.3348
0207 cc     *,   2.3490,   2.3525,   2.3529,   2.3800,   2.3842
0208 cc     *,   2.3912,   2.4088,   2.4130,   2.4193,   2.4298
0209 cc     *,   2.4315,   2.4392,   2.4472,   2.4573,   2.5034
0210 cc     *,   2.5131,   2.5268,   2.5743,   2.5848,   2.5916
0211 cc     *,   2.6327,   2.6620,   2.6700,   2.6984,   2.7080
0212 cc     *,   2.7205,   2.7534,   2.7573,   2.7651,   2.7670
0213 cc     *,   2.7844,   2.8024,   2.8092,   2.8127,   2.8533
0214 cc     *,   2.8556,   2.8638,   2.9079,   2.9395,   2.9500
0215 cc     *,   2.9776,   2.9961,   3.0495,   3.0769,   3.0879
0216 cc     *,   3.1358,   3.1547,   3.2251,   3.2371,   3.3020
0217 cc     *,   3.3527,   3.3620,   3.4221,   3.4967,   3.5019
0218 cc     *,   3.5035,   3.5814,   3.5829,   3.6266,   3.8549
0219 cc     *,   3.8742,   4.0503,   4.0663,   4.0698,   4.0732
0220 cc     *,   4.0778,   4.1074,   4.1300,   4.4976,   4.5183
0221 cc     *,   4.5389,   4.5410,   4.5615,   4.6808,   4.9146
0222 cc     *,   4.9336,   5.0088,   5.2993,   5.3011,   5.4731
0223 cc     *,   5.6083,   5.6416,   5.6465,   5.9171,   5.9502
0224 cc     *,   5.9644,   6.1697,   6.1803,   6.2706,   6.3034
0225 cc     *,   6.3390,   6.5627,   6.7040,   6.8424,   6.9105
0226 cc     *,   6.9780,   7.1111,   7.1662,   7.6202,   7.8624
0227 cc     *,   8.2124,   8.7647,   9.0282,   9.2843,   9.5825
0228 cc     *,   9.7763,   9.9851,  10.2447,  10.6927,  10.8926
0229 cc     *,  11.4549,  11.5365,  11.7779,  11.8519,  13.6241
0230 cc     *,  13.6883,  13.7611,  13.8968,  15.0628,  15.1868
0231 cc     *,  16.6595,  16.8275,  17.9077,  18.0121,  18.1677
0232 cc     *,  19.2213,  19.4156,  19.6556,  19.7002,  21.2604
0233 cc     *,  22.9574,  23.3624,  23.4057,  23.4965,  23.4967
0234 cc     *,  23.5964,  23.7605,  23.8787,  24.1521,  25.2904
0235 cc     *,  26.3796,  27.5960,  30.5240,  30.5954,  30.5957
0236 cc     *,  30.6555,  30.6954,  30.7954,  35.1947,  44.6933
0237 cc     *,  44.6937,  44.6938,  44.7706,  44.8228,  44.8933
0238 cc     *,  45.1933,  52.6798,  52.7090,  52.7921,  52.7921
0239 cc     *,  52.7927,  52.8927,  53.1921,  62.2907,  62.3914
0240 cc     *,  62.4907,  62.6907,  62.6913,  62.7906
0241 cc     */
0242 c      data ppbmx/
0243 c     *    3.1615,   2.2212,   1.7113,   1.4927,   1.1631
0244 c     *,   1.0911,   1.0388,    .9525,    .9390,    .8885
0245 c     *,    .8019,    .8956,    .9115,    .8593,    .8840
0246 c     *,    .9062,    .8444,    .8444,    .8482,    .8713
0247 c     *,    .8575,    .8795,    .8795,    .8759,    .8630
0248 c     *,    .8822,    .8593,    .8813,    .9036,    .9150
0249 c     *,    .8740,    .9219,    .8740,    .9253,    .8722
0250 c     *,    .8795,    .9288,    .8704,    .9398,    .9271
0251 c     *,    .9407,    .9373,    .9756,    .9926,   1.0357
0252 c     *,   1.0037,   1.0408,    .9739,   1.0108,   1.0479
0253 c     *,   1.0645,   1.0705,   1.1113,   1.0794,   1.0955
0254 c     *,   1.1085,   1.1256,   1.1535,   1.1731,   1.1424
0255 c     *,   1.0794,   1.1480,   1.1590,   1.1888,   1.2218
0256 c     *,   1.2164,   1.2087,   1.2296,   1.2231,   1.2335
0257 c     *,   1.2322,   1.2309,   1.2114,   1.2296,   1.2293
0258 c     *,   1.2489,   1.2303,   1.2322,   1.2322,   1.2127
0259 c     *,   1.2192,   1.2295,   1.2399,   1.2290,   1.2374
0260 c     *,   1.2205,   1.2278,   1.2284,   1.2061,   1.2296
0261 c     *,   1.2296,   1.2540,   1.2008,   1.2260,   1.2229
0262 c     *,   1.2257,   1.2188,   1.2118,   1.2078,   1.1982
0263 c     *,   1.2039,   1.2012,   1.1991,   1.1808,   1.1969
0264 c     *,   1.1959,   1.1922,   1.1902,   1.1897,   1.1878
0265 c     *,   1.1888,   1.1860,   1.1856,   1.1850,   1.2244
0266 c     *,   1.1782,   1.1790,   1.1718,   1.1696,   1.1726
0267 c     *,   1.1576,   1.1656,   1.1606,   1.1603,   1.1581
0268 c     *,   1.1590,   1.1530,   1.1576,   1.1487,   1.1476
0269 c     *,   1.1447,   1.1794,   1.1448,   1.1507,   1.1507
0270 c     *,   1.1407,   1.1403,   1.1507,   1.1581,   1.1645
0271 c     *,   1.1616,   1.1507,   1.1332,   1.1294,   1.1284
0272 c     *,   1.1227,   1.1284,   1.1298,   1.1261,   1.1199
0273 c     *,   1.1365,   1.1438,   1.1284,   1.1424,   1.1230
0274 c     *,   1.1218,   1.1142,   1.1156,   1.1202,   1.1198
0275 c     *,   1.1099,   1.1099,   1.1175,   1.1241,   1.1168
0276 c     *,   1.1099,   1.1128,   1.1241,   1.1103,   1.1149
0277 c     *,   1.1155,   1.1083,   1.1197,   1.1127,   1.1185
0278 c     *,   1.1113,   1.1128,   1.1113,   1.1083,   1.1056
0279 c     *,   1.1067,   1.1070,   1.1059,   1.1063,   1.1070
0280 c     *,   1.1028,   1.0979,   1.1060,   1.1062,   1.1774
0281 c     *,   1.0805,   1.1039,   1.0940,   1.0955,   1.0940
0282 c     *,   1.0955,   1.1082,   1.1128,   1.1082,   1.0852
0283 c     *,   1.1003,   1.1097,   1.1118,   1.0911,   1.1227
0284 c     *,   1.1070,   1.1206,   1.1142,   1.1213,   1.1174
0285 c     *,   1.1199,   1.1142,   1.1185,   1.1180,   1.1113
0286 c     *,   1.1099,   1.1297,   1.1142,   1.1226,   1.1240
0287 c     *,   1.1251,   1.1368,   1.1403,   1.1319,   1.1296
0288 c     *,   1.1333,   1.1303,   1.1284,   1.1343,   1.1516
0289 c     *,   1.1521,   1.1549,   1.1641,   1.1631,   1.1562
0290 c     *,   1.1631,   1.1697,   1.1726,   1.1756,   1.1659
0291 c     *,   1.1660,   1.1617,   1.1686,   1.1774,   1.1713
0292 c     *,   1.1744,   1.1810,   1.1694,   1.1848
0293 c     */
0294 c      data appecm/
0295 c     *    1.9002,   1.9050,   1.9072,   1.9078,   1.9091
0296 c     *,   1.9129,   1.9157,   1.9162,   1.9174,   1.9176
0297 c     *,   1.9180,   1.9195,   1.9201,   1.9224,   1.9226
0298 c     *,   1.9246,   1.9252,   1.9255,   1.9257,   1.9271
0299 c     *,   1.9282,   1.9293,   1.9301,   1.9310,   1.9319
0300 c     *,   1.9328,   1.9334,   1.9345,   1.9359,   1.9370
0301 c     *,   1.9372,   1.9384,   1.9393,   1.9398,   1.9407
0302 c     *,   1.9426,   1.9430,   1.9433,   1.9452,   1.9454
0303 c     *,   1.9473,   1.9485,   1.9495,   1.9500,   1.9510
0304 c     *,   1.9515,   1.9547,   1.9559,   1.9562,   1.9579
0305 c     *,   1.9610,   1.9615,   1.9644,   1.9680,   1.9718
0306 c     *,   1.9755,   1.9788,   1.9829,   1.9871,   1.9911
0307 c     *,   1.9954,   1.9994,   2.0813,   2.0979,   2.1146
0308 c     *,   2.1180,   2.1316,   2.1487,   2.1660,   2.1834
0309 c     *,   2.1868,   2.1938,   2.1991,   2.2008,   2.2184
0310 c     *,   2.2226,   2.2359,   2.2500,   2.2606,   2.2712
0311 c     *,   2.2889,   2.2995,   2.3066,   2.3243,   2.3419
0312 c     *,   2.3490,   2.3511,   2.3596,   2.3701,   2.3772
0313 c     *,   2.3860,   2.3877,   2.3947,   2.4035,   2.4123
0314 c     *,   2.4298,   2.4472,   2.4629,   2.4820,   2.4993
0315 c     *,   2.5165,   2.5268,   2.5337,   2.5508,   2.5678
0316 c     *,   2.5848,   2.5950,   2.6017,   2.6186,   2.6353
0317 c     *,   2.6377,   2.6520,   2.6654,   2.6687,   2.6852
0318 c     *,   2.7017,   2.7182,   2.7345,   2.7508,   2.7670
0319 c     *,   2.7832,   2.7896,   2.7992,   2.8152,   2.8312
0320 c     *,   2.8439,   2.8470,   2.8565,   2.8628,   2.9377
0321 c     *,   2.9561,   2.9745,   3.0351,   3.0769,   3.0828
0322 c     *,   3.1648,   3.2507,   3.2788,   3.3620,   3.4568
0323 c     *,   3.5492,   3.6266,   3.7893,   3.8501,   3.8597
0324 c     *,   3.8742,   3.9455,   4.1074,   4.3499,   4.3926
0325 c     *,   4.5389,   4.5799,   4.6808,   4.7991,   4.9336
0326 c     *,   4.9901,   5.1742,   5.2993,   5.3520,   5.4731
0327 c     *,   5.6416,   5.6911,   5.8534,   5.9644,   6.0113
0328 c     *,   6.2706,   6.3153,   6.7040,   6.9780,   7.3061
0329 c     *,   7.6202,   7.7422,   7.8624,   7.8743,   8.0393
0330 c     *,   8.2124,   8.4930,   8.7647,   9.0282,   9.2843
0331 c     *,   9.5335,   9.7763,  11.5365,  13.7611,  13.8630
0332 c     *,  15.0628,  16.8275,  17.9077,  19.4156,  21.2604
0333 c     *,  22.9574,  30.4098,  30.5943,  30.6861,  52.5843
0334 c     *,  52.7979,  52.7979,  62.2853,  62.4957,  62.6905
0335 c     *, 539.9198, 546.9191, 899.8658, 900.0000,1803.0007
0336 c     */
0337 c      data appbmx/
0338 c     *    2.7553,   2.6857,   2.6732,   2.6517,   2.6306
0339 c     *,   2.5376,   2.4398,   2.4779,   2.5212,   2.5143
0340 c     *,   2.4573,   2.4799,   2.4495,   2.4286,   2.4521
0341 c     *,   2.3683,   2.4463,   2.4240,   2.4489,   2.3743
0342 c     *,   2.4162,   2.3561,   2.3903,   2.3796,   2.3221
0343 c     *,   2.3689,   2.4181,   2.3221,   2.3823,   2.2987
0344 c     *,   2.3337,   2.3568,   2.3487,   2.2911,   2.3344
0345 c     *,   2.2701,   2.3097,   2.3207,   2.2631,   2.2603
0346 c     *,   2.2666,   2.2412,   2.2319,   2.3097,   2.2327
0347 c     *,   2.2104,   2.2104,   2.2645,   2.2369,   2.1880
0348 c     *,   2.1756,   2.2162,   2.1491,   2.1484,   2.1365
0349 c     *,   2.1320,   2.1027,   2.1065,   2.0913,   2.0776
0350 c     *,   2.0668,   2.0883,   1.9333,   1.9098,   1.8851
0351 c     *,   1.8932,   1.8721,   1.8623,   1.8520,   1.8409
0352 c     *,   1.8678,   1.8575,   1.8325,   1.8429,   1.8088
0353 c     *,   1.7698,   1.7941,   1.7864,   1.7814,   1.7736
0354 c     *,   1.7645,   1.7623,   1.7576,   1.7523,   1.7445
0355 c     *,   1.7419,   1.7019,   1.7342,   1.7311,   1.7271
0356 c     *,   1.7210,   1.7182,   1.7161,   1.7119,   1.7054
0357 c     *,   1.6947,   1.6816,   1.6780,   1.6678,   1.6599
0358 c     *,   1.6509,   1.6328,   1.6449,   1.6396,   1.6319
0359 c     *,   1.6270,   1.5761,   1.6043,   1.6120,   1.6069
0360 c     *,   1.5978,   1.6018,   1.5891,   1.5948,   1.5905
0361 c     *,   1.5849,   1.5778,   1.5736,   1.5679,   1.5785
0362 c     *,   1.5583,   1.5476,   1.5519,   1.5467,   1.5416
0363 c     *,   1.5233,   1.5368,   1.5492,   1.5313,   1.4895
0364 c     *,   1.5579,   1.5107,   1.4680,   1.4725,   1.4586
0365 c     *,   1.3889,   1.4799,   1.4472,   1.4371,   1.3576
0366 c     *,   1.4228,   1.3922,   1.3762,   1.3854,   1.3669
0367 c     *,   1.4161,   1.3623,   1.3638,   1.3530,   1.3762
0368 c     *,   1.3273,   1.2866,   1.2989,   1.3159,   1.2828
0369 c     *,   1.3086,   1.2797,   1.2704,   1.2940,   1.2741
0370 c     *,   1.2514,   1.2540,   1.2803,   1.2653,   1.2603
0371 c     *,   1.2386,   1.2192,   1.2283,   1.2231,   1.2140
0372 c     *,   1.2048,   1.2114,   1.2099,   1.2052,   1.2048
0373 c     *,   1.1984,   1.1928,   1.1901,   1.1902,   1.1888
0374 c     *,   1.1848,   1.1769,   1.1706,   1.1579,   1.1608
0375 c     *,   1.1521,   1.1534,   1.1520,   1.1495,   1.1549
0376 c     *,   1.1550,   1.1580,   1.1672,   1.1562,   1.1743
0377 c     *,   1.1859,   1.1950,   1.1851,   1.1821,   1.1987
0378 c     *,   1.4740,   1.4037,   1.4483,   1.4417,   1.5149
0379 c     */
0380 c      data pnecm/
0381 c     *    1.87867,   1.87869,   1.87872,   1.87875,   1.87878
0382 c     *,   1.87881,   1.87884,   1.87887,   1.87890,   1.87893
0383 c     *,   1.87896,   1.87899,   1.87902,   1.87906,   1.87909
0384 c     *,   1.87913,   1.87916,   1.87920,   1.87923,   1.87927
0385 c     *,   1.87931,   1.87934,   1.87938,   1.87942,   1.87946
0386 c     *,   1.87950,   1.87954,   1.87958,   1.87962,   1.87966
0387 c     *,   1.87970,   1.87975,   1.87979,   1.87983,   1.87988
0388 c     *,   1.87992,   1.87997,   1.88001,   1.88006,   1.88011
0389 c     *,   1.88015,   1.88020,   1.88025,   1.88030,   1.88035
0390 c     *,   1.88040,   1.88045,   1.88050,   1.88055,   1.88061
0391 c     *,   1.88066,   1.88071,   1.88077,   1.88082,   1.88087
0392 c     *,   1.88093,   1.88099,   1.88104,   1.88110,   1.88116
0393 c     *,   1.88121,   1.88127,   1.88133,   1.88139,   1.88145
0394 c     *,   1.88151,   1.88157,   1.88163,   1.88170,   1.88176
0395 c     *,   1.88182,   1.88189,   1.88195,   1.88202,   1.88208
0396 c     *,   1.88215,   1.88221,   1.88228,   1.88235,   1.88241
0397 c     *,   1.88248,   1.88255,   1.88262,   1.88269,   1.88276
0398 c     *,   1.88283,   1.88290,   1.88297,   1.88305,   1.88312
0399 c     *,   1.88319,   1.88327,   1.88334,   1.88342,   1.88349
0400 c     *,   1.88357,   1.88364,   1.88372,   1.88380,   1.88388
0401 c     *,   1.88396,   1.88403,   1.88411,   1.88419,   1.88428
0402 c     *,   1.88436,   1.88444,   1.88452,   1.88460,   1.88469
0403 c     *,   1.88477,   1.88485,   1.88494,   1.88502,   1.88511
0404 c     *,   1.88519,   1.88528,   1.88537,   1.88546,   1.88554
0405 c     *,   1.88563,   1.88572,   1.88581,   1.88590,   1.88599
0406 c     *,   1.88608,   1.88618,   1.88627,   1.88636,   1.88645
0407 c     *,   1.88655,   1.88664,   1.88674,   1.88683,   1.88693
0408 c     *,   1.88702,   1.88712,   1.88722,   1.88731,   1.88741
0409 c     *,   1.88751,   1.88761,   1.88771,   1.88781,   1.88791
0410 c     *,   1.88801,   1.88811,   1.88822,   1.88832,   1.88842
0411 c     *,   1.88852,   1.88863,   1.88873,   1.88884,   1.88894
0412 c     *,   1.88905,   1.88916,   1.88926,   1.88937,   1.88948
0413 c     *,   1.88959,   1.88970,   1.88980,   1.88991,   1.89003
0414 c     *,   1.89014,   1.89025,   1.89036,   1.89047,   1.89058
0415 c     *,   1.89070,   1.89081,   1.89093,   1.89104,   1.89116
0416 c     *,   1.89127,   1.89139,   1.89150,   1.89162,   1.89174
0417 c     *,   1.89186,   1.89198,   1.89209,   1.89221,   1.89233
0418 c     *,   1.89245,   1.89258,   1.89270,   1.89282,   1.89294
0419 c     *,   1.89306,   1.89319,   1.89331,   1.89344,   1.89356
0420 c     *,   1.89369,   1.89381,   1.89394,   1.89406,   1.89419
0421 c     *,   1.89432,   1.89445,   1.89458,   1.89496,   1.89549
0422 c     *,   1.89602,   1.89615,   1.89656,   1.89697,   1.89724
0423 c     *,   1.89766,   1.89780,   1.89850,   1.89893,   1.89922
0424 c     *,   1.89995,   1.90068,   1.90098,   1.90143,   1.90174
0425 c     *,   1.90235,   1.90250,   1.90312,   1.90407,   1.90503
0426 c     *,   1.90519,   1.90616,   1.90732,   1.90749,   1.90833
0427 c     *,   1.90936,   1.91216,   1.91379,   1.91545,   1.91714
0428 c     *,   1.91905,   1.91924,   1.92100,   1.92160,   1.92179
0429 c     *,   1.92259,   1.92319,   1.92421,   1.92502,   1.92543
0430 c     *,   1.92605,   1.92646,   1.92792,   1.93046,   1.93241
0431 c     *,   1.93306,   1.93570,   1.93704,   1.93953,   1.94021
0432 c     *,   1.94183,   1.94699,   1.94723,   1.95206,   1.95329
0433 c     *,   1.95452,   1.95651,   1.96029,   1.96080,   1.97927
0434 c     *,   1.98533,   1.99806,   2.00884,   2.01269,   2.02779
0435 c     *,   2.02963,   2.04329,   2.04643,   2.05915,   2.05947
0436 c     *,   2.05979,   2.07207,   2.07337,   2.07533,   2.09178
0437 c     *,   2.10847,   2.11385,   2.12061,   2.12536,   2.14243
0438 c     *,   2.15308,   2.15343,   2.15964,   2.17072,   2.17698
0439 c     *,   2.18185,   2.19442,   2.21193,   2.21369,   2.22353
0440 c     *,   2.22846,   2.22952,   2.24715,   2.25597,   2.28851
0441 c     *,   2.29134,   2.29382,   2.31293,   2.31328,   2.32673
0442 c     *,   2.34935,   2.35501,   2.36207,   2.38251,   2.39729
0443 c     *,   2.41135,   2.41591,   2.42817,   2.44006,   2.45995
0444 c     *,   2.48220,   2.49952,   2.50643,   2.52951,   2.56750
0445 c     *,   2.58756,   2.63546,   2.64719,   2.66487,   2.67285
0446 c     *,   2.71088,   2.72336,   2.75178,   2.75634,   2.76802
0447 c     *,   2.76867,   2.76996,   2.78741,   2.80542,   2.81567
0448 c     *,   2.85639,   2.85860,   2.86681,   2.91102,   2.94265
0449 c     *,   2.96543,   3.05273,   3.08729,   3.09115,   3.15805
0450 c     *,   3.16821,   3.22857,   3.24053,   3.29551,   3.35628
0451 c     *,   3.42580,   3.50727,   3.55297,   3.58520,   3.58675
0452 c     *,   3.59580,   3.63049,   3.72425,   3.75633,   4.05460
0453 c     *,   4.06219,   4.07412,   4.11175,   4.37426,   4.52314
0454 c     *,   4.54378,   4.74537,   4.93885,   5.12513,   5.30495
0455 c     *,   5.40999,   5.47892,   5.61424,   5.64757,   5.93444
0456 c     *,   5.97071,   6.27732,   6.42517,   6.51227,   6.56970
0457 c     *,   6.71114,   6.87703,   6.98545,   7.18446,   7.23904
0458 c     *,   7.24942,   7.62830,   8.10603,   8.22114,   8.54948
0459 c     *,   8.77406,   9.29418,   9.78673,  10.15712,  10.25566
0460 c     *,  10.70407,  11.13446,  11.54882,  12.33587,  13.77577
0461 c     *,  15.07880,  15.74960,  16.84544,  17.92675,  18.18703
0462 c     *,  18.44365,  19.43624,  20.14863,  21.28302,  22.69375
0463 c     *,  22.98187
0464 c     */
0465 c      data pnbmx/
0466 c     *   10.7613,  10.6195,  10.5290,  10.4010,  10.2901
0467 c     *,  10.1970,  10.1029,  10.0088,   9.9009,   9.7973
0468 c     *,   9.7125,   9.6198,   9.5613,   9.4281,   9.3628
0469 c     *,   9.2801,   9.2068,   9.1103,   9.0239,   8.9609
0470 c     *,   8.8562,   8.8011,   8.7574,   8.6332,   8.5487
0471 c     *,   8.4788,   8.4157,   8.3606,   8.2746,   8.2604
0472 c     *,   8.1583,   8.0778,   8.0127,   7.9567,   7.8691
0473 c     *,   7.8176,   7.8190,   7.7028,   7.6634,   7.5956
0474 c     *,   7.5808,   7.4956,   7.4144,   7.3600,   7.3071
0475 c     *,   7.2947,   7.1947,   7.1389,   7.1333,   7.0404
0476 c     *,   6.9856,   6.9468,   6.9171,   6.8369,   6.7869
0477 c     *,   6.7829,   6.6804,   6.6483,   6.5982,   6.5464
0478 c     *,   6.5060,   6.4541,   6.4539,   6.3684,   6.3219
0479 c     *,   6.2777,   6.2832,   6.1881,   6.1494,   6.1048
0480 c     *,   6.0642,   6.0207,   6.0255,   5.9756,   5.9161
0481 c     *,   5.8717,   5.8276,   5.7878,   5.7481,   5.7319
0482 c     *,   5.6977,   5.6492,   5.6142,   5.5796,   5.5428
0483 c     *,   5.4939,   5.4659,   5.4549,   5.3933,   5.3601
0484 c     *,   5.3311,   5.3037,   5.2760,   5.2429,   5.2381
0485 c     *,   5.2384,   5.1470,   5.1112,   5.0812,   5.0483
0486 c     *,   5.0350,   5.0330,   4.9640,   4.9410,   4.9050
0487 c     *,   4.8714,   4.8408,   4.8482,   4.8518,   4.7611
0488 c     *,   4.7157,   4.7049,   4.6834,   4.6939,   4.6206
0489 c     *,   4.5931,   4.5723,   4.5498,   4.5210,   4.5337
0490 c     *,   4.4726,   4.4898,   4.4251,   4.4013,   4.3784
0491 c     *,   4.3514,   4.3264,   4.3530,   4.2846,   4.2567
0492 c     *,   4.2339,   4.2171,   4.1919,   4.1757,   4.1503
0493 c     *,   4.1329,   4.0924,   4.0797,   4.0624,   4.0446
0494 c     *,   4.0210,   4.0010,   3.9812,   3.9627,   3.9402
0495 c     *,   3.9221,   3.9029,   3.8925,   3.8680,   3.8439
0496 c     *,   3.8244,   3.8094,   3.7816,   3.7719,   3.7396
0497 c     *,   3.7271,   3.7011,   3.6849,   3.6804,   3.6640
0498 c     *,   3.6496,   3.5954,   3.6042,   3.5697,   3.5552
0499 c     *,   3.5463,   3.5265,   3.5212,   3.4992,   3.1432
0500 c     *,   3.4630,   3.4483,   3.4484,   3.4240,   3.4127
0501 c     *,   3.3595,   3.3767,   3.3582,   3.3059,   3.3258
0502 c     *,   3.3182,   3.2582,   3.2740,   3.2621,   3.1984
0503 c     *,   3.2408,   3.2043,   3.2087,   3.1652,   3.1720
0504 c     *,   3.1476,   3.0754,   3.1236,   3.1494,   3.0653
0505 c     *,   3.0757,   3.1030,   3.0692,   3.0466,   3.0392
0506 c     *,   3.0346,   2.9933,   3.0146,   2.8774,   2.7972
0507 c     *,   2.6463,   2.8068,   2.6869,   2.6643,   2.6673
0508 c     *,   2.6684,   2.6409,   2.5520,   2.4341,   2.4978
0509 c     *,   2.4534,   2.4417,   2.4293,   2.3283,   2.4978
0510 c     *,   2.3042,   2.3111,   2.1996,   2.1996,   2.1960
0511 c     *,   2.1469,   2.1223,   2.0791,   2.0599,   1.9891
0512 c     *,   2.0027,   1.8678,   1.7850,   1.7868,   1.7362
0513 c     *,   1.6478,   1.6254,   1.6166,   1.6478,   1.6516
0514 c     *,   1.5554,   1.5727,   1.5656,   1.5290,   1.5149
0515 c     *,   1.5554,   1.5615,   1.5522,   1.4863,   1.4745
0516 c     *,   1.4745,   1.3991,   1.4139,   1.1686,   1.3458
0517 c     *,   1.3587,   1.2425,   1.3171,   1.2828,   1.2153
0518 c     *,   1.2679,   1.2766,   1.1410,   1.2514,   1.0852
0519 c     *,   1.1445,   1.1672,   1.0624,   1.1089,   1.0899
0520 c     *,   1.0171,   1.0399,   1.0645,   1.0417,    .9934
0521 c     *,   1.0403,   1.0029,   1.0357,   1.0388,   1.0337
0522 c     *,   1.0428,   1.0555,   1.0663,   1.0546,   1.0626
0523 c     *,   1.0013,   1.0705,   1.0711,   1.0852,   1.0830
0524 c     *,   1.1119,   1.0940,   1.0976,   1.0675,   1.1205
0525 c     *,   1.0464,   1.0995,    .9508,   1.0972,   1.1170
0526 c     *,   1.1015,   1.1251,   1.1296,   1.1027,   1.1028
0527 c     *,    .9271,   1.1363,   1.1120,   1.1455,   1.1192
0528 c     *,   1.1498,   1.1491,   1.0108,   1.1282,   1.1550
0529 c     *,   1.1617,   1.1354,   1.1586,   1.1631,   1.1378
0530 c     *,   1.1656,   1.1684,   1.1389,   1.1694,   1.1690
0531 c     *,   1.1702,   1.1705,   1.1390,   1.1714,   1.1716
0532 c     *,   1.1326,   1.1517,   1.1697,   1.1731,   1.1716
0533 c     *,   1.0867,   1.1537,   1.1698,   1.1642,   1.1638
0534 c     *,   1.1199,   1.1635,   1.1713,   1.1631,   1.1601
0535 c     *,   1.1340,   1.0823,   1.1598,   1.1754,   1.1572
0536 c     *,   1.1565,   1.1567,   1.1631,   1.1538,   1.0852
0537 c     *,   1.0342,   1.1645,   1.1452,   1.1099,   1.0940
0538 c     *,   1.1185,   1.1470,   1.1388,   1.1424,   1.0705
0539 c     *,   1.1374,   1.1199,   1.1262,   1.1142,   1.1205
0540 c     *,   1.0867,   1.1095,   1.0734,   1.1234,   1.0925
0541 c     *,   1.1135,   1.1076,   1.1070,   1.0955,   1.1027
0542 c     *,   1.1073,   1.0630,   1.1007,   1.1185,   1.1133
0543 c     *,   1.1128,   1.1028,   1.1033,   1.1086,   1.1120
0544 c     *,   1.1013,   1.0991,   1.1086,   1.1028,   1.1027
0545 c     *,   1.1064,   1.1036,   1.1135,   1.1139,   1.1136
0546 c     *,   1.1145,   1.1166,   1.1152,   1.1168,   1.1172
0547 c     *,   1.1230,   1.1187,   1.1254,   1.1224,   1.1329
0548 c     *,   1.1216
0549 c     */
0550 c      data apnecm/
0551 c     *    2.1288,   2.2007,   2.2500,   2.3044,   2.3529
0552 c     *,   2.9284,   3.5136,   3.6305,   3.7933,   4.1117
0553 c     *,   4.5438,   4.9389,   5.1797,   5.3049,   5.4789
0554 c     *,   5.6476,   6.2773,   6.9855,   7.6283,   8.2211
0555 c     *,   8.7741,   9.2942,   9.7867,  11.5488,  13.7758
0556 c     *,  15.0788,  16.8454,  17.9267,  19.4362,  21.2830
0557 c     *,  22.9819
0558 c     */
0559 c      data apnbmx/
0560 c     *    1.9462,   1.7481,   1.8881,   1.8019,   1.8627
0561 c     *,   1.4745,   1.3231,   1.3762,   1.3351,   1.3505
0562 c     *,   1.2841,   1.3086,   1.2565,   1.3038,   1.2218
0563 c     *,   1.2952,   1.2127,   1.2035,   1.1968,   1.1951
0564 c     *,   1.1604,   1.1794,   1.1747,   1.1724,   1.1595
0565 c     *,   1.1637,   1.1477,   1.1520,   1.1510,   1.1478
0566 c     *,   1.1466
0567 c     */
0568 c      data pipecm/
0569 c     *    1.1050,   1.1154,   1.1165,   1.1256,   1.1273
0570 c     *,   1.1333,   1.1370,   1.1382,   1.1394,   1.1438
0571 c     *,   1.1495,   1.1579,   1.1592,   1.1677,   1.1691
0572 c     *,   1.1697,   1.1757,   1.1771,   1.1777,   1.1784
0573 c     *,   1.1798,   1.1838,   1.1892,   1.1906,   1.1926
0574 c     *,   1.1933,   1.1953,   1.1960,   1.1967,   1.1981
0575 c     *,   1.1994,   1.2008,   1.2015,   1.2022,   1.2028
0576 c     *,   1.2056,   1.2063,   1.2069,   1.2097,   1.2104
0577 c     *,   1.2111,   1.2124,   1.2131,   1.2138,   1.2152
0578 c     *,   1.2166,   1.2172,   1.2193,   1.2200,   1.2214
0579 c     *,   1.2221,   1.2255,   1.2262,   1.2269,   1.2276
0580 c     *,   1.2283,   1.2303,   1.2310,   1.2317,   1.2352
0581 c     *,   1.2358,   1.2365,   1.2372,   1.2400,   1.2407
0582 c     *,   1.2421,   1.2434,   1.2462,   1.2476,   1.2503
0583 c     *,   1.2517,   1.2524,   1.2538,   1.2545,   1.2565
0584 c     *,   1.2613,   1.2627,   1.2696,   1.2716,   1.2730
0585 c     *,   1.2751,   1.2799,   1.2819,   1.2833,   1.2860
0586 c     *,   1.2867,   1.2915,   1.2922,   1.2929,   1.2990
0587 c     *,   1.3010,   1.3024,   1.3119,   1.3126,   1.3180
0588 c     *,   1.3200,   1.3220,   1.3254,   1.3261,   1.3321
0589 c     *,   1.3382,   1.3388,   1.3415,   1.3422,   1.3449
0590 c     *,   1.3469,   1.3522,   1.3608,   1.3615,   1.3622
0591 c     *,   1.3655,   1.3661,   1.3767,   1.3786,   1.3813
0592 c     *,   1.3898,   1.3917,   1.3950,   1.4047,   1.4080
0593 c     *,   1.4112,   1.4157,   1.4163,   1.4176,   1.4208
0594 c     *,   1.4215,   1.4285,   1.4298,   1.4304,   1.4336
0595 c     *,   1.4349,   1.4425,   1.4470,   1.4495,   1.4526
0596 c     *,   1.4539,   1.4652,   1.4677,   1.4702,   1.4764
0597 c     *,   1.4777,   1.4857,   1.4863,   1.4870,   1.4882
0598 c     *,   1.4919,   1.4993,   1.4999,   1.5030,   1.5097
0599 c     *,   1.5103,   1.5121,   1.5146,   1.5212,   1.5249
0600 c     *,   1.5285,   1.5327,   1.5351,   1.5429,   1.5435
0601 c     *,   1.5465,   1.5513,   1.5531,   1.5548,   1.5566
0602 c     *,   1.5637,   1.5655,   1.5673,   1.5708,   1.5720
0603 c     *,   1.5732,   1.5761,   1.5790,   1.5849,   1.5866
0604 c     *,   1.5965,   1.5977,   1.5994,   1.6023,   1.6063
0605 c     *,   1.6121,   1.6133,   1.6144,   1.6264,   1.6287
0606 c     *,   1.6327,   1.6344,   1.6406,   1.6417,   1.6429
0607 c     *,   1.6502,   1.6519,   1.6536,   1.6625,   1.6664
0608 c     *,   1.6670,   1.6676,   1.6687,   1.6692,   1.6714
0609 c     *,   1.6792,   1.6825,   1.6853,   1.6913,   1.6935
0610 c     *,   1.6941,   1.6963,   1.6985,   1.6990,   1.7012
0611 c     *,   1.7170,   1.7175,   1.7208,   1.7240,   1.7267
0612 c     *,   1.7391,   1.7417,   1.7423,   1.7428,   1.7503
0613 c     *,   1.7535,   1.7609,   1.7635,   1.7651,   1.7714
0614 c     *,   1.7735,   1.7767,   1.7793,   1.7798,   1.7908
0615 c     *,   1.7923,   1.7949,   1.7960,   1.8032,   1.8063
0616 c     *,   1.8099,   1.8197,   1.8207,   1.8238,   1.8253
0617 c     *,   1.8289,   1.8304,   1.8320,   1.8386,   1.8436
0618 c     *,   1.8497,   1.8507,   1.8537,   1.8643,   1.8673
0619 c     *,   1.8678,   1.8703,   1.8713,   1.8738,   1.8777
0620 c     *,   1.8792,   1.8812,   1.8827,   1.8881,   1.8911
0621 c     *,   1.8916,   1.8936,   1.8980,   1.9039,   1.9073
0622 c     *,   1.9108,   1.9151,   1.9161,   1.9181,   1.9186
0623 c     *,   1.9249,   1.9283,   1.9317,   1.9331,   1.9350
0624 c     *,   1.9384,   1.9423,   1.9519,   1.9571,   1.9614
0625 c     *,   1.9652,   1.9681,   1.9756,   1.9780,   1.9804
0626 c     *,   1.9893,   1.9921,   1.9968,   1.9987,   2.0034
0627 c     *,   2.0085,   2.0196,   2.0344,   2.0358,   2.0385
0628 c     *,   2.0545,   2.0636,   2.0654,   2.0704,   2.0816
0629 c     *,   2.0839,   2.0933,   2.1106,   2.1151,   2.1257
0630 c     *,   2.1279,   2.1388,   2.1545,   2.1606,   2.1761
0631 c     *,   2.1770,   2.1804,   2.1817,   2.1920,   2.2022
0632 c     *,   2.2060,   2.2187,   2.2480,   2.2646,   2.2934
0633 c     *,   2.3056,   2.3339,   2.3499,   2.3535,   2.3538
0634 c     *,   2.3737,   2.3894,   2.4050,   2.4128,   2.4283
0635 c     *,   2.4398,   2.4513,   2.4703,   2.4892,   2.5080
0636 c     *,   2.5266,   2.5451,   2.5561,   2.5634,   2.5816
0637 c     *,   2.5997,   2.6069,   2.6177,   2.6355,   2.6568
0638 c     *,   2.6708,   2.6987,   2.7057,   2.7195,   2.7401
0639 c     *,   2.7469,   2.7606,   2.7741,   2.7977,   2.8010
0640 c     *,   2.8077,   2.8343,   2.8409,   2.8672,   2.8769
0641 c     *,   2.8997,   2.9093,   2.9350,   2.9414,   2.9636
0642 c     *,   2.9731,   3.0013,   3.0045,   3.0107,   3.0355
0643 c     *,   3.0570,   3.0662,   3.0876,   3.0967,   3.1268
0644 c     *,   3.1328,   3.1566,   3.1862,   3.2067,   3.2155
0645 c     *,   3.2445,   3.2733,   3.3018,   3.3216,   3.3329
0646 c     *,   3.3609,   3.3887,   3.4163,   3.4190,   3.4327
0647 c     *,   3.4436,   3.4707,   3.4869,   3.4976,   3.5244
0648 c     *,   3.5509,   3.6033,   3.6550,   3.7059,   3.7462
0649 c     *,   3.9247,   3.9887,   3.9981,   4.4001,   4.4341
0650 c     *,   4.8193,   4.8387,   5.2120,   5.2246,   5.3889
0651 c     *,   5.5535,   5.5603,   5.7265,   5.8880,   5.8912
0652 c     *,   5.9671,   6.1984,   6.2421,   6.5084,   6.6369
0653 c     *,   6.9138,   7.5617,   8.1584,   8.7144,   8.9794
0654 c     *,   9.2369,   9.7314,   9.9412,  10.2020,  10.6517
0655 c     *,  11.4987,  13.7295,  15.0339,  16.6334,  16.8018
0656 c     *,  17.8835,  18.1439,  21.2400,  22.9386,  24.1342
0657 c     *,  25.2733
0658 c     */
0659 c      data pipbmx/
0660 c     *     .4424,    .5585,    .6180,    .7485,    .7092
0661 c     *,    .8058,    .7777,    .9113,    .8974,    .9934
0662 c     *,   1.0896,   1.2653,   1.3078,   1.5076,   1.5472
0663 c     *,   1.5656,   1.7019,   1.7504,   1.7934,   1.7626
0664 c     *,   1.8168,   1.9706,   2.0163,   2.1140,   2.1749
0665 c     *,   2.0576,   2.1851,   2.1148,   2.1924,   2.1851
0666 c     *,   2.3104,   2.3480,   2.2883,   2.1924,   2.3602
0667 c     *,   2.4570,   2.3262,   2.2708,   2.4722,   2.3296
0668 c     *,   2.5124,   2.3194,   2.4476,   2.4033,   2.5497
0669 c     *,   2.5313,   2.5514,   2.5181,   2.5125,   2.5156
0670 c     *,   2.5105,   2.4398,   2.4201,   2.5074,   2.4978
0671 c     *,   2.4463,   2.4863,   2.4856,   2.4469,   2.5231
0672 c     *,   2.3534,   2.5357,   2.4482,   2.3796,   2.3823
0673 c     *,   2.3582,   2.3650,   2.3870,   2.1705,   2.1185
0674 c     *,   2.2341,   2.2057,   2.2284,   2.1178,   2.1705
0675 c     *,   2.0622,   2.0490,   2.0122,   1.9041,   1.8873
0676 c     *,   1.9091,   1.7897,   1.7499,   1.7535,   1.8797
0677 c     *,   1.8455,   1.6087,   1.6381,   1.6361,   1.6737
0678 c     *,   1.5329,   1.5327,   1.4879,   1.4351,   1.4461
0679 c     *,   1.3854,   1.3517,   1.3334,   1.3695,   1.2741
0680 c     *,   1.2989,   1.2183,   1.2361,   1.2074,   1.1456
0681 c     *,   1.1997,   1.1439,   1.1381,   1.0786,   1.1185
0682 c     *,   1.0693,   1.1339,    .9958,   1.0077,   1.0491
0683 c     *,    .9997,    .9611,    .9452,    .9141,    .9190
0684 c     *,    .8806,    .8885,    .9200,    .8618,    .9680
0685 c     *,    .8702,    .8643,    .8263,    .8234,    .7150
0686 c     *,    .8412,    .8101,    .8704,    .7767,    .8766
0687 c     *,    .7722,    .7694,    .7956,    .7590,    .7128
0688 c     *,    .7159,    .6894,    .6894,    .7139,    .6898
0689 c     *,    .7412,    .6784,    .7181,    .6947,    .7695
0690 c     *,    .6704,    .7110,    .6910,    .6699,    .7199
0691 c     *,    .6935,    .6759,    .6843,    .6933,    .7190
0692 c     *,    .7159,    .6865,    .6958,    .7017,    .6794
0693 c     *,    .7081,    .7004,    .7128,    .7569,    .7269
0694 c     *,    .7356,    .7230,    .7332,    .7548,    .7464
0695 c     *,    .7695,    .7703,    .7707,    .8288,    .8117
0696 c     *,    .8170,    .8054,    .7990,    .7878,    .8556
0697 c     *,    .8423,    .8917,    .8664,    .8253,    .8649
0698 c     *,    .8627,    .8813,    .8461,    .8938,    .9288
0699 c     *,    .8759,    .8345,    .8972,    .8625,    .8818
0700 c     *,    .8983,    .8953,    .9080,    .9277,    .9117
0701 c     *,    .9080,    .8579,    .8974,    .8970,    .9184
0702 c     *,    .9267,    .9184,    .9092,    .8704,    .9146
0703 c     *,    .9184,    .9591,    .8649,    .9296,    .9071
0704 c     *,    .9449,    .9407,    .9536,    .9721,    .9608
0705 c     *,    .9837,    .9233,    .9542,   1.0004,    .9853
0706 c     *,    .9934,   1.0005,   1.0061,    .9358,   1.0180
0707 c     *,   1.0280,   1.0573,    .9982,   1.0357,   1.0555
0708 c     *,    .9877,   1.0682,   1.0694,   1.0817,   1.0720
0709 c     *,   1.1046,   1.1041,   1.0596,   1.1013,   1.1217
0710 c     *,   1.1217,   1.1291,   1.1113,   1.1270,   1.1354
0711 c     *,   1.0799,   1.1199,   1.1439,   1.1459,   1.1213
0712 c     *,   1.0907,   1.1368,   1.1488,   1.1008,   1.1500
0713 c     *,   1.1156,   1.1502,   1.0947,   1.1410,   1.1427
0714 c     *,   1.1480,   1.0729,   1.1634,   1.1319,   1.1480
0715 c     *,   1.1295,   1.1213,   1.0783,   1.1044,   1.1027
0716 c     *,   1.1217,   1.0998,   1.0418,   1.1031,   1.0712
0717 c     *,   1.0720,   1.0600,   1.0540,   1.1180,   1.0490
0718 c     *,   1.0464,   1.0380,   1.0124,   1.0202,    .9821
0719 c     *,   1.0013,    .9945,    .9997,   1.0187,    .9805
0720 c     *,    .9873,    .9796,    .9608,   1.0045,    .9756
0721 c     *,    .9695,    .9674,    .9646,    .9662,    .9659
0722 c     *,    .9654,    .9491,    .9643,    .9566,    .9654
0723 c     *,    .9636,    .9619,    .9676,    .9774,    .9747
0724 c     *,    .9916,    .9843,    .9950,    .9932,    .9641
0725 c     *,    .9895,    .9861,    .9871,    .9905,    .9916
0726 c     *,    .9657,    .9872,    .9770,    .9796,    .9751
0727 c     *,    .9637,    .9689,    .9633,    .9635,    .9601
0728 c     *,    .9580,    .9707,    .9581,    .9540,    .9505
0729 c     *,    .9509,    .9422,    .9494,    .9657,    .9478
0730 c     *,    .9513,    .9541,    .9472,    .9439,    .9640
0731 c     *,    .9452,    .9397,    .9440,    .9390,    .9416
0732 c     *,    .9424,    .9394,    .9334,    .9366,    .9348
0733 c     *,    .9338,    .9414,    .9312,    .9115,    .9286
0734 c     *,    .9373,    .9287,    .9190,    .9248,    .9232
0735 c     *,    .9339,    .9214,    .9201,    .9183,    .9181
0736 c     *,    .9170,    .9150,    .9138,    .9071,    .9117
0737 c     *,    .9106,    .9092,    .9084,    .9253,    .9053
0738 c     *,    .9061,    .9052,    .9132,    .9032,    .9029
0739 c     *,    .9008,    .8973,    .8954,    .8928,    .9115
0740 c     *,    .9021,    .8938,    .8997,    .8907,    .8921
0741 c     *,    .8834,    .8831,    .8795,    .8774,    .8755
0742 c     *,    .8745,    .8682,    .8849,    .8649,    .8705
0743 c     *,    .8616,    .8684,    .8691,    .8634,    .8687
0744 c     *,    .8636,    .8616,    .8581,    .8571,    .8575
0745 c     *,    .8582,    .8551,    .8575,    .8582,    .8618
0746 c     *,    .8597,    .8619,    .8634,    .8693,    .8645
0747 c     *,    .8682,    .8538,    .8759,    .8818,    .8831
0748 c     *,    .8853/
0749 c      data (pimecm(i),i=1,400)/
0750 c     *    1.1046,   1.1133,   1.1394,   1.1425,   1.1495
0751 c     *,   1.1579,   1.1585,   1.1592,   1.1598,   1.1677
0752 c     *,   1.1691,   1.1731,   1.1777,   1.1784,   1.1798
0753 c     *,   1.1831,   1.1858,   1.1879,   1.1892,   1.1906
0754 c     *,   1.1940,   1.1967,   1.1994,   1.2008,   1.2015
0755 c     *,   1.2028,   1.2069,   1.2076,   1.2090,   1.2097
0756 c     *,   1.2111,   1.2124,   1.2131,   1.2159,   1.2166
0757 c     *,   1.2179,   1.2186,   1.2200,   1.2214,   1.2234
0758 c     *,   1.2269,   1.2283,   1.2296,   1.2303,   1.2317
0759 c     *,   1.2324,   1.2352,   1.2358,   1.2365,   1.2372
0760 c     *,   1.2407,   1.2421,   1.2441,   1.2462,   1.2476
0761 c     *,   1.2510,   1.2517,   1.2524,   1.2545,   1.2551
0762 c     *,   1.2579,   1.2586,   1.2593,   1.2607,   1.2613
0763 c     *,   1.2627,   1.2634,   1.2641,   1.2662,   1.2668
0764 c     *,   1.2682,   1.2696,   1.2710,   1.2716,   1.2730
0765 c     *,   1.2758,   1.2778,   1.2806,   1.2819,   1.2826
0766 c     *,   1.2833,   1.2847,   1.2888,   1.2915,   1.2922
0767 c     *,   1.2929,   1.2963,   1.3004,   1.3024,   1.3038
0768 c     *,   1.3058,   1.3065,   1.3072,   1.3112,   1.3119
0769 c     *,   1.3126,   1.3146,   1.3180,   1.3187,   1.3200
0770 c     *,   1.3207,   1.3220,   1.3227,   1.3254,   1.3261
0771 c     *,   1.3301,   1.3308,   1.3321,   1.3335,   1.3362
0772 c     *,   1.3375,   1.3388,   1.3415,   1.3422,   1.3455
0773 c     *,   1.3482,   1.3515,   1.3522,   1.3555,   1.3562
0774 c     *,   1.3615,   1.3628,   1.3641,   1.3655,   1.3681
0775 c     *,   1.3694,   1.3760,   1.3773,   1.3786,   1.3898
0776 c     *,   1.3917,   1.3963,   1.3995,   1.4002,   1.4015
0777 c     *,   1.4047,   1.4099,   1.4112,   1.4163,   1.4176
0778 c     *,   1.4183,   1.4196,   1.4208,   1.4228,   1.4234
0779 c     *,   1.4272,   1.4292,   1.4298,   1.4304,   1.4393
0780 c     *,   1.4425,   1.4470,   1.4476,   1.4489,   1.4507
0781 c     *,   1.4539,   1.4589,   1.4596,   1.4608,   1.4652
0782 c     *,   1.4658,   1.4683,   1.4727,   1.4739,   1.4758
0783 c     *,   1.4764,   1.4777,   1.4795,   1.4808,   1.4833
0784 c     *,   1.4851,   1.4857,   1.4876,   1.4882,   1.4894
0785 c     *,   1.4901,   1.4919,   1.4925,   1.4938,   1.4968
0786 c     *,   1.4974,   1.4981,   1.4993,   1.5030,   1.5054
0787 c     *,   1.5060,   1.5066,   1.5072,   1.5097,   1.5103
0788 c     *,   1.5109,   1.5146,   1.5152,   1.5182,   1.5206
0789 c     *,   1.5212,   1.5224,   1.5231,   1.5249,   1.5309
0790 c     *,   1.5327,   1.5345,   1.5357,   1.5387,   1.5405
0791 c     *,   1.5411,   1.5429,   1.5435,   1.5441,   1.5465
0792 c     *,   1.5489,   1.5507,   1.5513,   1.5519,   1.5548
0793 c     *,   1.5590,   1.5614,   1.5637,   1.5655,   1.5673
0794 c     *,   1.5702,   1.5708,   1.5761,   1.5802,   1.5825
0795 c     *,   1.5831,   1.5843,   1.5849,   1.5866,   1.5890
0796 c     *,   1.5936,   1.5948,   1.5977,   1.5994,   1.6017
0797 c     *,   1.6052,   1.6058,   1.6087,   1.6092,   1.6138
0798 c     *,   1.6173,   1.6178,   1.6190,   1.6236,   1.6258
0799 c     *,   1.6276,   1.6287,   1.6298,   1.6315,   1.6327
0800 c     *,   1.6367,   1.6372,   1.6378,   1.6400,   1.6406
0801 c     *,   1.6423,   1.6480,   1.6513,   1.6519,   1.6525
0802 c     *,   1.6547,   1.6553,   1.6614,   1.6631,   1.6637
0803 c     *,   1.6648,   1.6653,   1.6659,   1.6681,   1.6692
0804 c     *,   1.6703,   1.6720,   1.6726,   1.6731,   1.6742
0805 c     *,   1.6792,   1.6798,   1.6803,   1.6820,   1.6825
0806 c     *,   1.6853,   1.6858,   1.6864,   1.6875,   1.6935
0807 c     *,   1.6957,   1.6963,   1.6979,   1.6990,   1.7067
0808 c     *,   1.7072,   1.7121,   1.7127,   1.7132,   1.7186
0809 c     *,   1.7202,   1.7208,   1.7213,   1.7224,   1.7235
0810 c     *,   1.7240,   1.7267,   1.7278,   1.7294,   1.7342
0811 c     *,   1.7348,   1.7391,   1.7407,   1.7428,   1.7476
0812 c     *,   1.7503,   1.7535,   1.7545,   1.7609,   1.7614
0813 c     *,   1.7667,   1.7714,   1.7735,   1.7741,   1.7767
0814 c     *,   1.7772,   1.7798,   1.7824,   1.7835,   1.7871
0815 c     *,   1.7929,   1.7960,   1.8001,   1.8032,   1.8058
0816 c     *,   1.8130,   1.8182,   1.8212,   1.8218,   1.8238
0817 c     *,   1.8253,   1.8258,   1.8289,   1.8320,   1.8370
0818 c     *,   1.8386,   1.8436,   1.8446,   1.8507,   1.8512
0819 c     *,   1.8557,   1.8588,   1.8638,   1.8678,   1.8713
0820 c     *,   1.8762,   1.8777,   1.8792,   1.8807,   1.8827
0821 c     *,   1.8857,   1.8881,   1.8886,   1.8936,   1.8975
0822 c     *,   1.9010,   1.9063,   1.9132,   1.9186,   1.9205
0823 c     *,   1.9249,   1.9254,   1.9273,   1.9283,   1.9317
0824 c     *,   1.9326,   1.9374,   1.9423,   1.9451,   1.9495
0825 c     *,   1.9519,   1.9538,   1.9614,   1.9709,   1.9733
0826 c     *,   1.9747,   1.9799,   1.9884,   1.9903,   1.9987
0827 c     *,   2.0034,   2.0117,   2.0164,   2.0182,   2.0196
0828 c     *,   2.0330,   2.0335,   2.0358,   2.0540,   2.0581
0829 c     *,   2.0636,   2.0654,   2.0798,   2.0812,   2.0816
0830 c     */
0831 c      data (pimecm(i),i=401,578)/
0832 c     *    2.0933,   2.1013,   2.1075,   2.1221,   2.1261
0833 c     *,   2.1305,   2.1375,   2.1445,   2.1588,   2.1658
0834 c     *,   2.1740,   2.1804,   2.1877,   2.2026,   2.2119
0835 c     *,   2.2166,   2.2187,   2.2305,   2.2510,   2.2626
0836 c     *,   2.2688,   2.2717,   2.3040,   2.3121,   2.3315
0837 c     *,   2.3483,   2.3538,   2.3737,   2.3744,   2.3925
0838 c     *,   2.4050,   2.4105,   2.4128,   2.4267,   2.4302
0839 c     *,   2.4513,   2.4627,   2.4892,   2.5069,   2.5266
0840 c     *,   2.5561,   2.5634,   2.5802,   2.5925,   2.5997
0841 c     *,   2.6284,   2.6355,   2.6557,   2.6708,   2.6987
0842 c     *,   2.7057,   2.7401,   2.7673,   2.7741,   2.7966
0843 c     *,   2.8077,   2.8343,   2.8409,   2.8672,   2.8769
0844 c     *,   2.8997,   2.9093,   2.9318,   2.9341,   2.9414
0845 c     *,   2.9636,   2.9731,   3.0045,   3.0262,   3.0355
0846 c     *,   3.0570,   3.0656,   3.0662,   3.0876,   3.0967
0847 c     *,   3.1268,   3.1566,   3.1774,   3.1862,   3.2067
0848 c     *,   3.2155,   3.2445,   3.2733,   3.3018,   3.3216
0849 c     *,   3.3329,   3.3609,   3.3887,   3.4163,   3.4190
0850 c     *,   3.4436,   3.4675,   3.4707,   3.4869,   3.4976
0851 c     *,   3.5509,   3.6033,   3.6550,   3.6575,   3.7059
0852 c     *,   3.7312,   3.7462,   3.8402,   3.8935,   3.9887
0853 c     *,   4.0004,   4.3873,   4.4341,   4.6811,   4.7210
0854 c     *,   4.7408,   4.8387,   4.8406,   5.0288,   5.0844
0855 c     *,   5.2120,   5.2353,   5.3889,   5.4254,   5.5603
0856 c     *,   5.6123,   5.7265,   5.7787,   5.8880,   5.9451
0857 c     *,   5.9671,   5.9953,   6.0792,   6.1984,   6.2241
0858 c     *,   6.3479,   6.5070,   6.6369,   6.8140,   6.9138
0859 c     *,   7.0734,   7.2450,   7.3962,   7.5617,   7.7092
0860 c     *,   7.9841,   7.9865,   8.1584,   8.1814,   8.3628
0861 c     *,   8.4410,   8.6582,   8.6593,   8.7144,   8.9794
0862 c     *,   9.2369,   9.2845,   9.4874,   9.7314,   9.7775
0863 c     *,   9.9694,  10.2020,  10.3580,  10.4293,  10.5988
0864 c     *,  10.6517,  10.8697,  11.0833,  11.4987,  13.7295
0865 c     *,  15.0339,  16.6334,  16.8018,  17.8835,  18.1439
0866 c     *,  19.3933,  19.6336,  21.2400,  22.9386,  24.1342
0867 c     *,  25.2733,  26.0050,  26.3632
0868 c     */
0869 c      data (pimbmx(i),i=1,400)/
0870 c     *     .5314,    .5314,    .6580,    .7092,    .7506
0871 c     *,    .8215,    .8579,    .8406,    .8349,    .9441
0872 c     *,    .9657,   1.0363,   1.0686,   1.1085,   1.1185
0873 c     *,   1.1899,   1.1658,   1.2218,   1.2322,   1.2653
0874 c     *,   1.3273,   1.2374,   1.3611,   1.3716,   1.3267
0875 c     *,   1.3986,   1.4150,   1.3399,   1.4701,   1.4516
0876 c     *,   1.4723,   1.4955,   1.4494,   1.4161,   1.4558
0877 c     *,   1.4625,   1.5006,   1.5128,   1.5160,   1.4584
0878 c     *,   1.4991,   1.4791,   1.4217,   1.4799,   1.4799
0879 c     *,   1.4588,   1.4844,   1.4172,   1.4273,   1.4439
0880 c     *,   1.4166,   1.4127,   1.3739,   1.3624,   1.3971
0881 c     *,   1.3297,   1.3231,   1.3285,   1.2878,   1.2952
0882 c     *,   1.2679,   1.2641,   1.2976,   1.2386,   1.2463
0883 c     *,   1.3025,   1.2489,   1.2239,   1.1902,   1.2114
0884 c     *,   1.1955,   1.2083,   1.1658,   1.1686,   1.1603
0885 c     *,   1.1424,   1.1185,   1.1160,   1.1013,   1.1070
0886 c     *,   1.1041,   1.0823,   1.0645,   1.0779,   1.0295
0887 c     *,   1.0311,    .9950,   1.0155,    .9950,   1.0029
0888 c     *,    .9767,   1.0249,    .9853,    .9657,    .9906
0889 c     *,    .9608,    .9591,    .9805,    .9458,    .9575
0890 c     *,    .9422,    .9407,    .9558,    .9473,    .9271
0891 c     *,    .9132,    .9236,    .9219,    .9219,    .9575
0892 c     *,    .9097,    .9224,    .9094,    .9202,    .8903
0893 c     *,    .9224,    .9160,    .9122,    .9094,    .8956
0894 c     *,    .9167,    .9271,    .9398,    .9184,    .9277
0895 c     *,    .9310,    .9184,    .9354,    .9219,    .9300
0896 c     *,    .9303,    .9508,    .9451,    .9680,    .9399
0897 c     *,    .9420,    .9387,    .9667,    .9248,    .9915
0898 c     *,    .9698,    .9626,   1.0187,    .9659,    .9441
0899 c     *,    .9766,    .9694,   1.0061,    .9789,    .9757
0900 c     *,    .9803,   1.0495,   1.0218,   1.0026,   1.0706
0901 c     *,   1.0277,   1.0302,   1.0690,   1.0552,   1.0406
0902 c     *,   1.0801,   1.0522,   1.1284,   1.1226,   1.1270
0903 c     *,   1.0934,   1.0968,   1.1381,   1.0915,   1.1543
0904 c     *,   1.1775,   1.2101,   1.1247,   1.1506,   1.1781
0905 c     *,   1.1546,   1.1968,   1.1604,   1.1697,   1.2072
0906 c     *,   1.2058,   1.2489,   1.1912,   1.2141,   1.1928
0907 c     *,   1.1986,   1.1978,   1.2256,   1.2565,   1.2029
0908 c     *,   1.2127,   1.1997,   1.2035,   1.1791,   1.1853
0909 c     *,   1.1914,   1.1927,   1.2616,   1.2303,   1.1848
0910 c     *,   1.1507,   1.2399,   1.1510,   1.1898,   1.1499
0911 c     *,   1.1337,   1.1433,   1.1089,   1.1517,   1.2008
0912 c     *,   1.1598,   1.1030,   1.0798,   1.1165,   1.1213
0913 c     *,   1.1190,   1.0861,   1.0776,   1.0653,   1.0730
0914 c     *,   1.1106,   1.0908,   1.0945,   1.0650,   1.0882
0915 c     *,   1.0720,   1.0540,   1.0925,   1.0718,   1.1377
0916 c     *,   1.0867,   1.0802,   1.1090,   1.0936,   1.0915
0917 c     *,   1.1316,   1.1575,   1.1202,   1.1275,   1.0908
0918 c     *,   1.1142,   1.1507,   1.1890,   1.1863,   1.2114
0919 c     *,   1.1142,   1.2001,   1.1312,   1.1930,   1.2563
0920 c     *,   1.2489,   1.2919,   1.2652,   1.2425,   1.2149
0921 c     *,   1.2386,   1.2616,   1.3207,   1.3299,   1.2816
0922 c     *,   1.3296,   1.3562,   1.2957,   1.3831,   1.3028
0923 c     *,   1.3806,   1.3704,   1.3202,   1.4082,   1.3482
0924 c     *,   1.3730,   1.3351,   1.3886,   1.3348,   1.3957
0925 c     *,   1.3929,   1.3790,   1.3791,   1.3946,   1.3641
0926 c     *,   1.3877,   1.3566,   1.3564,   1.3762,   1.3253
0927 c     *,   1.3739,   1.3252,   1.3234,   1.3423,   1.3159
0928 c     *,   1.2643,   1.2700,   1.2584,   1.2466,   1.2841
0929 c     *,   1.2191,   1.2052,   1.2794,   1.2835,   1.2374
0930 c     *,   1.2061,   1.1936,   1.1947,   1.2476,   1.1481
0931 c     *,   1.1496,   1.2187,   1.1427,   1.2101,   1.1192
0932 c     *,   1.1445,   1.1371,   1.1613,   1.0994,   1.1020
0933 c     *,   1.1233,   1.1041,   1.0896,   1.0890,   1.0880
0934 c     *,   1.0802,   1.0946,   1.0940,   1.0670,   1.0761
0935 c     *,   1.0817,   1.0702,   1.0723,   1.0779,   1.0789
0936 c     *,   1.0733,   1.0771,   1.0767,   1.0710,   1.0705
0937 c     *,   1.0720,   1.0729,   1.0472,   1.0959,   1.0788
0938 c     *,   1.0739,   1.0645,   1.0681,   1.0749,   1.0789
0939 c     *,   1.0799,   1.0795,   1.0763,   1.0588,   1.0805
0940 c     *,   1.0724,   1.0660,   1.0663,   1.0801,   1.0988
0941 c     *,   1.0797,   1.0816,   1.0687,   1.0690,   1.0724
0942 c     *,   1.0721,   1.0777,   1.0650,   1.0715,   1.0617
0943 c     *,   1.0690,   1.0678,   1.0714,   1.0323,   1.0672
0944 c     *,   1.0630,   1.0564,   1.0600,   1.0636,   1.0499
0945 c     *,   1.0479,   1.0481,   1.0463,   1.0510,   1.0450
0946 c     *,   1.0171,   1.0517,   1.0498,   1.0510,   1.0412
0947 c     *,   1.0374,   1.0501,   1.0388,   1.0449,   1.0449
0948 c     *,   1.0311,   1.0510,   1.0505,   1.0449,   1.0567
0949 c     *,   1.0572,   1.0495,   1.0632,   1.0461,   1.0403
0950 c     */
0951 c      data (pimbmx(i),i=401,578)/
0952 c     *    1.0629,   1.0642,   1.0525,   1.0709,   1.0585
0953 c     *,   1.0612,   1.0717,   1.0731,   1.0660,   1.0761
0954 c     *,   1.0696,   1.0767,   1.0755,   1.0720,   1.0615
0955 c     *,   1.0665,   1.0660,   1.0714,   1.0670,   1.0650
0956 c     *,   1.0627,   1.0621,   1.0499,   1.0499,   1.0457
0957 c     *,   1.0405,   1.0372,   1.0412,   1.0331,   1.0299
0958 c     *,   1.0299,   1.0241,   1.0321,   1.0306,   1.0232
0959 c     *,   1.0252,   1.0171,   1.0211,   1.0226,   1.0178
0960 c     *,   1.0083,   1.0157,   1.0138,    .9918,   1.0140
0961 c     *,   1.0028,   1.0120,   1.0077,   1.0088,    .9979
0962 c     *,   1.0052,   1.0025,    .9876,    .9987,    .9990
0963 c     *,    .9944,    .9845,    .9918,    .9777,    .9892
0964 c     *,    .9754,    .9856,    .9812,    .9816,    .9831
0965 c     *,    .9674,    .9800,    .9781,    .9679,    .9756
0966 c     *,    .9805,    .9759,    .9739,    .9672,    .9718
0967 c     *,    .9701,    .9682,    .9632,    .9664,    .9538
0968 c     *,    .9647,    .9628,    .9613,    .9596,    .9449
0969 c     *,    .9585,    .9572,    .9553,    .9540,    .9624
0970 c     *,    .9527,    .9468,    .9513,    .9525,    .9503
0971 c     *,    .9479,    .9459,    .9438,    .9424,    .9422
0972 c     *,    .9407,    .9457,    .9399,    .9385,    .9368
0973 c     *,    .9409,    .9248,    .9209,    .9034,    .8974
0974 c     *,    .9150,    .9089,    .9145,    .9146,    .9080
0975 c     *,    .9044,    .9082,    .9069,    .9062,    .8938
0976 c     *,    .9034,    .9045,    .9011,    .8921,    .8979
0977 c     *,    .8925,    .8982,    .8975,    .8976,    .8947
0978 c     *,    .8962,    .8932,    .8916,    .8913,    .8888
0979 c     *,    .8889,    .8892,    .8880,    .8881,    .8842
0980 c     *,    .8815,    .8826,    .8832,    .8813,    .8826
0981 c     *,    .8791,    .8835,    .8831,    .8833,    .8782
0982 c     *,    .8789,    .8813,    .8797,    .8780,    .8744
0983 c     *,    .8782,    .8842,    .8777,    .8777,    .8789
0984 c     *,    .8815,    .8800,    .8839,    .8740,    .8732
0985 c     *,    .8751,    .8784,    .8757,    .8779,    .8630
0986 c     *,    .8802,    .8775,    .8851,    .8874,    .8903
0987 c     *,    .8935,    .8965,    .8965
0988 c     */
0989 c      data kmpecm/
0990 c     *    1.4691,   1.4720,   1.4750,   1.4780,   1.4811
0991 c     *,   1.4837,   1.4843,   1.4860,   1.4876,   1.4910
0992 c     *,   1.4944,   1.4979,   1.5014,   1.5032,   1.5050
0993 c     *,   1.5087,   1.5091,   1.5124,   1.5132,   1.5162
0994 c     *,   1.5170,   1.5200,   1.5220,   1.5239,   1.5278
0995 c     *,   1.5318,   1.5354,   1.5358,   1.5362,   1.5378
0996 c     *,   1.5399,   1.5440,   1.5523,   1.5607,   1.5654
0997 c     *,   1.5688,   1.5775,   1.5784,   1.5863,   1.5916
0998 c     *,   1.5947,   1.6023,   1.6050,   1.6055,   1.6086
0999 c     *,   1.6145,   1.6159,   1.6172,   1.6191,   1.6236
1000 c     *,   1.6319,   1.6328,   1.6332,   1.6420,   1.6461
1001 c     *,   1.6466,   1.6522,   1.6563,   1.6582,   1.6614
1002 c     *,   1.6642,   1.6694,   1.6712,   1.6717,   1.6768
1003 c     *,   1.6806,   1.6811,   1.6839,   1.6843,   1.6867
1004 c     *,   1.6885,   1.6961,   1.6965,   1.7003,   1.7022
1005 c     *,   1.7083,   1.7087,   1.7172,   1.7177,   1.7181
1006 c     *,   1.7229,   1.7243,   1.7276,   1.7342,   1.7374
1007 c     *,   1.7436,   1.7459,   1.7483,   1.7539,   1.7610
1008 c     *,   1.7629,   1.7633,   1.7718,   1.7770,   1.7789
1009 c     *,   1.7793,   1.7817,   1.7840,   1.7873,   1.7892
1010 c     *,   1.8028,   1.8037,   1.8075,   1.8135,   1.8140
1011 c     *,   1.8219,   1.8247,   1.8261,   1.8308,   1.8369
1012 c     *,   1.8401,   1.8406,   1.8410,   1.8475,   1.8480
1013 c     *,   1.8489,   1.8540,   1.8559,   1.8605,   1.8647
1014 c     *,   1.8721,   1.8744,   1.8767,   1.8785,   1.8836
1015 c     *,   1.8951,   1.8955,   1.8983,   1.9001,   1.9029
1016 c     *,   1.9065,   1.9184,   1.9202,   1.9243,   1.9348
1017 c     *,   1.9393,   1.9411,   1.9434,   1.9483,   1.9547
1018 c     *,   1.9628,   1.9637,   1.9659,   1.9699,   1.9798
1019 c     *,   1.9838,   1.9923,   1.9958,   2.0047,   2.0127
1020 c     *,   2.0149,   2.0162,   2.0255,   2.0277,   2.0308
1021 c     *,   2.0417,   2.0430,   2.0487,   2.0579,   2.0653
1022 c     *,   2.0679,   2.0713,   2.0813,   2.0882,   2.0925
1023 c     *,   2.1028,   2.1105,   2.1126,   2.1211,   2.1232
1024 c     *,   2.1258,   2.1351,   2.1444,   2.1507,   2.1528
1025 c     *,   2.1654,   2.1675,   2.1687,   2.1737,   2.1837
1026 c     *,   2.1862,   2.1937,   2.2044,   2.2131,   2.2143
1027 c     *,   2.2274,   2.2356,   2.2478,   2.2546,   2.2659
1028 c     *,   2.2756,   2.2836,   2.2976,   2.2996,   2.3162
1029 c     *,   2.3166,   2.3296,   2.3335,   2.3363,   2.3535
1030 c     *,   2.3562,   2.3725,   2.3729,   2.3748,   2.3887
1031 c     *,   2.3918,   2.3933,   2.4006,   2.4109,   2.4174
1032 c     *,   2.4223,   2.4299,   2.4352,   2.4488,   2.4518
1033 c     *,   2.4675,   2.4705,   2.4861,   2.4887,   2.4936
1034 c     *,   2.5046,   2.5230,   2.5412,   2.5593,   2.5701
1035 c     *,   2.5773,   2.5952,   2.6023,   2.6059,   2.6130
1036 c     *,   2.6306,   2.6447,   2.6482,   2.6656,   2.6795
1037 c     *,   2.6829,   2.7002,   2.7173,   2.7848,   2.8540
1038 c     *,   2.9216,   2.9407,   2.9878,   3.0096,   3.0250
1039 c     *,   3.0526,   3.1783,   3.2191,   3.2993,   3.3887
1040 c     *,   3.5239,   3.6924,   3.7800,   3.9967,   4.0200
1041 c     *,   4.1348,   4.4617,   4.4826,   4.7663,   4.8636
1042 c     *,   4.9779,   5.1080,   5.1263,   5.2349,   5.3237
1043 c     *,   5.4110,   5.5479,   5.5816,   5.8281,   5.9080
1044 c     *,   6.0801,   6.2173,   6.3664,   6.6545,   6.9306
1045 c     *,   7.2610,   7.5770,   7.7605,   7.8207,   7.9985
1046 c     *,   8.1725,   8.2297,   8.4546,   8.7275,   8.9922
1047 c     *,   9.2493,   9.4994,   9.7431,   9.9809,  10.2131
1048 c     *,  11.5086,  13.7378,  15.0415,  16.8085,  17.8898
1049 c     *,  19.3991,  21.2453,  22.9435,  24.1389
1050 c     */
1051 c      data kmpbmx/
1052 c     *    1.9033,   1.7662,   1.7298,   1.7544,   1.5461
1053 c     *,   1.6991,   1.6205,   1.5898,   1.5817,   1.5023
1054 c     *,   1.5554,   1.5086,   1.5065,   1.4948,   1.4799
1055 c     *,   1.4927,   1.4854,   1.6136,   1.6017,   1.7312
1056 c     *,   1.4884,   1.7075,   1.5574,   1.5260,   1.5002
1057 c     *,   1.4571,   1.3991,   1.3219,   1.3434,   1.3635
1058 c     *,   1.3315,   1.2966,   1.2213,   1.1604,   1.1930
1059 c     *,   1.1382,   1.1354,   1.1583,   1.1185,   1.1156
1060 c     *,   1.0645,   1.0247,   1.0969,   1.0779,   1.1083
1061 c     *,   1.0749,   1.0155,   1.0464,   1.0754,   1.0202
1062 c     *,   1.0470,   1.0615,   1.0540,   1.0357,   1.0605
1063 c     *,   1.0428,   1.0265,   1.0187,   1.0611,   1.0615
1064 c     *,   1.0295,   1.0651,   1.0823,   1.0077,   1.0764
1065 c     *,   1.1298,   1.1013,   1.1080,   1.1070,   1.1368
1066 c     *,   1.1382,   1.1410,   1.1418,   1.1312,   1.1466
1067 c     *,   1.1378,   1.1241,   1.0896,   1.1264,   1.0720
1068 c     *,   1.1368,   1.1013,   1.1442,   1.1466,   1.1612
1069 c     *,   1.1726,   1.1755,   1.1576,   1.1726,   1.1848
1070 c     *,   1.1617,   1.2029,   1.1686,   1.2274,   1.2252
1071 c     *,   1.1726,   1.2256,   1.2244,   1.2008,   1.2332
1072 c     *,   1.2828,   1.2548,   1.2412,   1.2887,   1.2853
1073 c     *,   1.2653,   1.2540,   1.2527,   1.2449,   1.2118
1074 c     *,   1.1781,   1.1902,   1.1767,   1.1859,   1.1410
1075 c     *,   1.1594,   1.1800,   1.1185,   1.1256,   1.1354
1076 c     *,   1.1131,   1.1562,   1.1143,   1.1382,   1.0841
1077 c     *,   1.0587,   1.0632,   1.0311,   1.0617,   1.0150
1078 c     *,   1.0309,   1.0174,   1.0110,   1.0171,    .9961
1079 c     *,    .9719,    .9938,    .9869,    .9953,    .9966
1080 c     *,   1.0189,    .9977,    .9918,    .9948,   1.0034
1081 c     *,    .9737,   1.0066,   1.0137,   1.0041,   1.0171
1082 c     *,   1.0303,   1.0223,   1.0322,    .9751,   1.0331
1083 c     *,   1.0118,   1.0403,   1.0399,   1.0429,   1.0171
1084 c     *,   1.0279,   1.0467,   1.0414,   1.0217,   1.0432
1085 c     *,   1.0379,   1.0280,   1.0351,   1.0171,   1.0278
1086 c     *,   1.0314,   1.0213,   1.0133,   1.0240,   1.0080
1087 c     *,   1.0018,    .9964,    .9984,    .9889,    .9910
1088 c     *,    .9903,    .9801,    .9852,    .9853,    .9847
1089 c     *,    .9800,    .9832,    .9770,    .9749,    .9754
1090 c     *,    .9723,    .9741,    .9744,    .9738,    .9751
1091 c     *,    .9780,    .9738,    .9738,    .9684,    .9712
1092 c     *,    .9669,    .9680,    .9671,    .9576,    .9619
1093 c     *,    .9624,    .9585,    .9588,    .9586,    .9525
1094 c     *,    .9253,    .9518,    .9503,    .9491,    .9463
1095 c     *,    .9476,    .9420,    .9458,    .9434,    .9341
1096 c     *,    .9444,    .9412,    .9393,    .9395,    .9210
1097 c     *,    .9370,    .9358,    .8974,    .9400,    .9342
1098 c     *,    .9305,    .9141,    .9271,    .9267,    .9228
1099 c     *,    .9233,    .9219,    .9247,    .9296,    .9253
1100 c     *,    .9089,    .8992,    .8946,    .8992,    .9062
1101 c     *,    .9069,    .8874,    .9219,    .8746,    .8795
1102 c     *,    .8740,    .8704,    .8785,    .8795,    .8667
1103 c     *,    .8849,    .8510,    .8463,    .8612,    .8292
1104 c     *,    .8292,    .8387,    .8273,    .8273,    .8292
1105 c     *,    .8292,    .8349,    .8234,    .8349,    .8176
1106 c     *,    .8292,    .8180,    .8193,    .8154,    .8130
1107 c     *,    .8121,    .8145,    .8078,    .7959,    .8088
1108 c     *,    .8075,    .8064,    .8056,    .8086,    .8048
1109 c     *,    .8080,    .8068,    .8050,    .8042,    .8050
1110 c     *,    .8054,    .8064,    .8096,    .8095,    .8107
1111 c     *,    .8135,    .8234,    .8238,    .8263
1112 c     */
1113 c      data kmnecm/
1114 c     *    1.6212,   1.6781,   1.7053,   1.7863,   1.7882
1115 c     *,   1.8271,   1.9025,   2.0152,   2.1237,   2.2157
1116 c     *,   2.4252,   2.6054,   2.6160,   2.9441,   3.5279
1117 c     *,   3.6965,   4.0245,   4.4666,   4.8690,   5.1136
1118 c     *,   5.2406,   5.4169,   5.5877,   5.9144,   6.2241
1119 c     *,   6.9381,   7.5852,   8.1813,   8.7369,   9.2592
1120 c     *,   9.7536,  10.2241,  11.5209,  13.7525,  15.0575
1121 c     *,  16.8264,  17.9089,  19.4198,  21.2680,  22.9680
1122 c     *,  24.1646
1123 c     */
1124 c      data kmnbmx/
1125 c     *     .9132,    .9966,    .9772,    .9966,   1.1382
1126 c     *,   1.0794,    .9674,    .9167,    .8795,    .8500
1127 c     *,    .8482,    .8444,    .8330,    .8078,    .8349
1128 c     *,    .8368,    .7919,    .8146,    .8019,    .8156
1129 c     *,    .7999,    .7961,    .8038,    .8038,    .7949
1130 c     *,    .7868,    .7864,    .7910,    .7850,    .7870
1131 c     *,    .7906,    .7885,    .7945,    .7971,    .8011
1132 c     *,    .8003,    .8029,    .8082,    .8088,    .8156
1133 c     *,    .8189
1134 c     */
1135 c      data kppecm/
1136 c     *    1.4447,   1.4516,   1.4522,   1.4585,   1.4663
1137 c     *,   1.4750,   1.5036,   1.5050,   1.5091,   1.5239
1138 c     *,   1.5378,   1.5523,   1.5654,   1.5784,   1.5916
1139 c     *,   1.5929,   1.6014,   1.6037,   1.6050,   1.6150
1140 c     *,   1.6159,   1.6191,   1.6259,   1.6264,   1.6268
1141 c     *,   1.6328,   1.6378,   1.6461,   1.6517,   1.6587
1142 c     *,   1.6605,   1.6652,   1.6792,   1.6843,   1.6853
1143 c     *,   1.6928,   1.7073,   1.7101,   1.7210,   1.7294
1144 c     *,   1.7374,   1.7422,   1.7483,   1.7539,   1.7643
1145 c     *,   1.7662,   1.7704,   1.7789,   1.7793,   1.7864
1146 c     *,   1.7897,   1.8028,   1.8070,   1.8135,   1.8191
1147 c     *,   1.8327,   1.8355,   1.8373,   1.8517,   1.8587
1148 c     *,   1.8605,   1.8679,   1.8725,   1.8813,   1.8836
1149 c     *,   1.9038,   1.9070,   1.9289,   1.9298,   1.9321
1150 c     *,   1.9524,   1.9533,   1.9749,   1.9807,   1.9950
1151 c     *,   1.9972,   1.9994,   2.0074,   2.0193,   2.0435
1152 c     *,   2.0492,   2.0635,   2.0653,   2.0851,   2.1040
1153 c     *,   2.1066,   2.1083,   2.1279,   2.1296,   2.1490
1154 c     *,   2.1507,   2.1717,   2.1908,   2.1924,   2.2110
1155 c     *,   2.2131,   2.2213,   2.2319,   2.2335,   2.2538
1156 c     *,   2.2724,   2.2740,   2.2940,   2.3123,   2.3138
1157 c     *,   2.3375,   2.3531,   2.3725,   2.3903,   2.3918
1158 c     *,   2.4109,   2.4197,   2.4299,   2.4413,   2.4488
1159 c     *,   2.4675,   2.4861,   2.5046,   2.5230,   2.5266
1160 c     *,   2.5412,   2.5521,   2.5593,   2.5773,   2.5952
1161 c     *,   2.6130,   2.6306,   2.6482,   2.6656,   2.6829
1162 c     *,   2.7002,   2.7173,   3.0096,   3.0556,   3.1754
1163 c     *,   3.3887,   3.5239,   3.7800,   4.0200,   4.1348
1164 c     *,   4.4617,   4.6469,   4.7663,   4.8636,   4.9591
1165 c     *,   5.1263,   5.2349,   5.4110,   5.5816,   5.7308
1166 c     *,   5.9080,   6.0646,   6.2173,   6.9306,   7.5770
1167 c     *,   7.8207,   8.1725,   8.7275,   9.2493,   9.7431
1168 c     *,  10.2131,  11.5086,  13.7378,  15.0415,  16.6402
1169 c     *,  16.8085,  17.8898,  18.1501,  19.3991,  21.2453
1170 c     *,  22.9435,  24.1389
1171 c     */
1172 c      data kppbmx/
1173 c     *     .5412,    .6308,    .6024,    .6050,    .5971
1174 c     *,    .6037,    .6232,    .6103,    .6482,    .6601
1175 c     *,    .6386,    .6466,    .6438,    .6204,    .6482
1176 c     *,    .6358,    .6333,    .6445,    .6443,    .6346
1177 c     *,    .6410,    .6227,    .6283,    .6308,    .6403
1178 c     *,    .6290,    .6457,    .5984,    .6333,    .5955
1179 c     *,    .5944,    .6295,    .6346,    .6090,    .6433
1180 c     *,    .6383,    .6482,    .6425,    .6543,    .6588
1181 c     *,    .6652,    .6768,    .6730,    .6723,    .6815
1182 c     *,    .7040,    .6898,    .7014,    .7001,    .7181
1183 c     *,    .7130,    .7159,    .7067,    .7440,    .7345
1184 c     *,    .7365,    .7485,    .7382,    .7474,    .7574
1185 c     *,    .7588,    .7559,    .7590,    .7582,    .7668
1186 c     *,    .7592,    .7682,    .7661,    .7697,    .7548
1187 c     *,    .7661,    .7626,    .7626,    .7563,    .7590
1188 c     *,    .7578,    .7611,    .7557,    .7555,    .7506
1189 c     *,    .7498,    .7517,    .7508,    .7540,    .7464
1190 c     *,    .7538,    .7512,    .7527,    .7534,    .7527
1191 c     *,    .7565,    .7521,    .7529,    .7525,    .7444
1192 c     *,    .7517,    .7334,    .7485,    .7491,    .7510
1193 c     *,    .7466,    .7476,    .7478,    .7472,    .7485
1194 c     *,    .7378,    .7451,    .7468,    .7474,    .7476
1195 c     *,    .7459,    .7410,    .7461,    .7457,    .7414
1196 c     *,    .7464,    .7457,    .7444,    .7444,    .7444
1197 c     *,    .7442,    .7291,    .7421,    .7429,    .7421
1198 c     *,    .7397,    .7386,    .7373,    .7389,    .7384
1199 c     *,    .7384,    .7386,    .7378,    .7569,    .7878
1200 c     *,    .7548,    .7356,    .7526,    .7421,    .7715
1201 c     *,    .7568,    .7590,    .7777,    .7421,    .7632
1202 c     *,    .7464,    .7442,    .7548,    .7367,    .7736
1203 c     *,    .7378,    .7421,    .7455,    .7502,    .7510
1204 c     *,    .7653,    .7529,    .7580,    .7544,    .7614
1205 c     *,    .7605,    .7661,    .7703,    .7805,    .7883
1206 c     *,    .7850,    .7907,    .7611,    .7961,    .8023
1207 c     *,    .8068,    .8111
1208 c     */
1209 c      data kpnecm/
1210 c     *    1.6875,   1.7430,   1.7670,   1.7816,   1.7905
1211 c     *,   1.8144,   1.8383,   1.8615,   1.8749,   1.8846
1212 c     *,   1.9080,   1.9308,   1.9345,   1.9535,   1.9760
1213 c     *,   1.9974,   1.9983,   2.0205,   2.0460,   2.0647
1214 c     *,   2.0678,   2.0864,   2.1066,   2.1079,   2.1109
1215 c     *,   2.1292,   2.1322,   2.1504,   2.1533,   2.1743
1216 c     *,   2.1922,   2.1951,   2.2157,   2.2239,   2.2334
1217 c     *,   2.2362,   2.2565,   2.2739,   2.2767,   2.2967
1218 c     *,   2.3138,   2.3166,   2.3402,   2.3559,   2.3753
1219 c     *,   2.3919,   2.3946,   2.4138,   2.4328,   2.4517
1220 c     *,   2.4704,   2.4891,   2.5076,   2.5259,   2.5442
1221 c     *,   2.5551,   2.5623,   2.5803,   2.5982,   2.6160
1222 c     *,   2.6337,   2.6513,   2.6687,   2.6861,   2.7033
1223 c     *,   2.7204,   3.5279,   4.0245,   4.4666,   4.8690
1224 c     *,   5.2406,   5.4169,   5.5877,   5.9144,   6.2241
1225 c     *,   6.9381,   7.5852,   8.1813,   8.7369,   9.2592
1226 c     *,   9.7536,  10.2241,  11.5209,  13.7525,  15.0575
1227 c     *,  16.8264,  17.9089,  19.4198,  21.2680,  22.9680
1228 c     *,  24.1646
1229 c     */
1230 c      data kpnbmx/
1231 c     *     .7024,    .7324,    .7485,    .7527,    .7680
1232 c     *,    .7758,    .8100,    .8224,    .7611,    .8151
1233 c     *,    .8031,    .7915,    .7674,    .7842,    .7822
1234 c     *,    .7590,    .7791,    .7767,    .7758,    .7734
1235 c     *,    .7754,    .7709,    .7674,    .7713,    .7742
1236 c     *,    .7752,    .7748,    .7721,    .7680,    .7707
1237 c     *,    .7674,    .7713,    .7715,    .7695,    .7684
1238 c     *,    .7734,    .7682,    .7709,    .7672,    .7659
1239 c     *,    .7653,    .7653,    .7506,    .7626,    .7624
1240 c     *,    .7701,    .7588,    .7622,    .7592,    .7491
1241 c     *,    .7588,    .7574,    .7592,    .7582,    .7571
1242 c     *,    .7464,    .7559,    .7538,    .7529,    .7529
1243 c     *,    .7534,    .7538,    .7487,    .7487,    .7498
1244 c     *,    .7474,    .7464,    .7485,    .7464,    .7485
1245 c     *,    .7464,    .7565,    .7442,    .7485,    .7545
1246 c     *,    .7555,    .7542,    .7634,    .7653,    .7686
1247 c     *,    .7671,    .7723,    .7695,    .7785,    .7824
1248 c     *,    .7905,    .7927,    .7923,    .8052,    .8100
1249 c     *,    .8137
1250 c     */
1251 cc      data lpecm/
1252 cc     *    2.0577,   2.0583,   2.0593,   2.0595,   2.0609
1253 cc     *,   2.0617,   2.0629,   2.0642,   2.0643,   2.0647
1254 cc     *,   2.0666,   2.0671,   2.0683,   2.0692,   2.0709
1255 cc     *,   2.0720,   2.0783,   2.0818,   2.0935,   2.1022
1256 cc     *,   2.1058,   2.1117,   2.1326,   2.1559,   2.1731
1257 cc     *,   2.1811,   2.2079,   2.2360,   2.2505,   2.3107
1258 cc     *,   2.3733,   2.4534,   2.4695,   2.9278,   5.2476
1259 cc     */
1260 cc      data lpbmx/
1261 cc     *    2.5793,   2.3937,   1.9381,   2.3736,   2.0342
1262 cc     *,   2.2068,   1.9381,   1.8797,   1.7841,   1.7930
1263 cc     *,   1.2676,   1.6641,   1.4604,   1.0403,   1.3470
1264 cc     *,   1.0420,    .8722,    .8368,    .5323,    .5352
1265 cc     *,    .8867,    .5382,    .8106,    .8043,    .8058
1266 cc     *,    .8630,    .7031,    .7777,    .9441,   1.0403
1267 cc     *,    .9772,    .6628,   1.1968,   1.0555,   1.0495
1268 cc     */
1269 c      data pi1ecm/
1270 c     *     .45000,    .55000,    .62500,    .68750,    .73750
1271 c     *,    .78750,    .83750,    .88750,    .95000,   1.02500
1272 c     *,   1.10000,   1.17500
1273 c     */
1274 c      data pi1bmx/
1275 c     *     .48533,    .47873,    .55852,    .58087,    .55279
1276 c     *,    .49185,    .47203,    .46181,    .46181,    .47203
1277 c     *,    .41459,    .40684
1278 c     */
1279 c      data pi2ecm/
1280 c     *     .45000,    .55000,    .62500,    .68750,    .73750
1281 c     *,    .78750,    .83750,    .88750,    .95000,   1.02500
1282 c     *,   1.10000,   1.17500
1283 c     */
1284 c      data pi2bmx/
1285 c     *     .45135,    .80385,    .87767,   1.28779,   1.81771
1286 c     *,   2.07296,   1.55536,    .95912,    .94407,    .77768
1287 c     *,    .70467,    .54408
1288 c     */
1289 c      data pi3ecm/
1290 c     *     .45000,    .55000,    .61250,    .65000,    .67500
1291 c     *,    .70000,    .72500,    .75000,    .77500,    .80000
1292 c     *,    .82500,    .85000,    .87500,    .90000,    .93750
1293 c     *,   1.02500,   1.10000,   1.17500
1294 c     */
1295 c      data pi3bmx/
1296 c     *     .50463,    .79988,   1.13541,   1.30497,   1.34462
1297 c     *,   1.52957,   1.63809,   1.94216,   1.98511,   1.66316
1298 c     *,   1.69163,   1.62933,   1.06152,    .96574,    .83302
1299 c     *,    .71365,    .66517,    .59173
1300 c     */
1301 c      data pi4ecm/
1302 c     *     .28500,    .29500,    .30500,    .31500,    .37000
1303 c     *,    .46000,    .54375,    .61250,    .65000,    .67500
1304 c     *,    .70000,    .72500,    .75000,    .77500,    .80000
1305 c     *,    .82500,    .85000,    .87500,    .90125,    .92750
1306 c     *,    .96000
1307 c     */
1308 c      data pi4bmx/
1309 c     *     .29854,    .46181,    .54115,    .54115,    .51709
1310 c     *,    .72031,    .80976,    .96078,    .90798,   1.07788
1311 c     *,   1.37389,   1.70101,   2.02716,   1.83687,   1.52644
1312 c     *,   1.57469,   1.35640,    .93390,    .98531,    .84062
1313 c     *,    .79188
1314 c     */
1315 c      data pi5ecm/0.75,0.80,0.85,0.90,0.95,1.00,1.05,1.10,1.15/
1316 c      data pi5bmx/0.4,0.5,0.7,0.9,1.1,1.1,0.7,0.6,0.5/
1317 c
1318 c      call utpri('jintcs',ish,ishini,7)
1319 c
1320 c      ics=0
1321 c
1322 c      if(idptl(i).gt.10000)then
1323 c       call idquad(i,nqi,nai,jci)
1324 c       if(nqi.eq.0)then
1325 c        idi=999
1326 c       else
1327 c        idi=9999
1328 c       endif
1329 c      else
1330 c       idi=idptl(i)
1331 c      endif
1332 c
1333 c      if(idptl(j).gt.10000)then
1334 c       call idquad(j,nqj,naj,jcj)
1335 c       if(nqj.eq.0)then
1336 c        idj=999
1337 c       else
1338 c        idj=9999
1339 c       endif
1340 c      else
1341 c       idj=idptl(j)
1342 c      endif
1343 c
1344 c      do k=1,nflav
1345 c       kc(k)=jc(k,1)-jc(k,2)
1346 c       if(nq.lt.0)kc(k)=-kc(k)
1347 c      enddo
1348 c      if(nq.lt.0)nq=-nq
1349 c
1350 c      if(ish.ge.7)then
1351 c       write(ifch,*)'i:',i,' id_i:',idptl(i),' j:',j,' id_j:',idptl(j)
1352 c       write(ifch,*)'E_cm:',ecm,' jc:',(jc(k,1),k=1,6),(jc(k,2),k=1,6)
1353 c       write(ifch,*)'nq:',nq,' kc:',(kc(k),k=1,6)
1354 c      endif
1355 c
1356 cc check minimal kinetic energy
1357 c      ekin=ecm-pptl(5,i)-pptl(5,j)
1358 c      if(ekin.lt.amimel)goto1000
1359 c
1360 cc -------------------------------------------------------------------------
1361 c      if(iabs(idi).gt.1000.or.iabs(idj).gt.1000)then   !baryon involved
1362 cc -------------------------------------------------------------------------
1363 c
1364 c       if(nq.eq.6)then !------------baryon-baryon ----->
1365 c
1366 c        if(kc(1).eq.kc(2))then    !isospin_z=0
1367 cc pn
1368 c         if(ish.ge.7)write(ifch,*)'sig_pn chosen'
1369 c         if(ecm.lt.2)then
1370 c          call utindx(npn,pnecm,ecm,iecm)
1371 c          bmx=pnbmx(iecm)
1372 c         else
1373 c          p=ecm*sqrt((ecm**2/4./.94**2)-1.)
1374 c          if(p.lt.1.)then
1375 c           sig=33.+196.*(abs(0.95-p))**2.5
1376 c          elseif(p.lt.2)then
1377 c           sig=24.2+8.9*p
1378 c          else
1379 c           sig=47.3+.513*(alog(p)**2)-4.27*alog(p)
1380 c          endif
1381 c          bmx=sqrt(sig/10./pi)
1382 c         endif
1383 c        else                      !isospin_z=+-1
1384 cc pp
1385 c         if(ish.ge.7)write(ifch,*)'sig_pp chosen'
1386 c         if(ecm.le.1.882)then
1387 c          bmx=ppbmx(1)
1388 c          if(ish.ge.7)write(ifch,*)'b_mx:',bmx
1389 c         elseif(ecm.le.1.887)then
1390 c          bmx=ppbmx(2)
1391 c          if(ish.ge.7)write(ifch,*)'b_mx:',bmx
1392 c         elseif(ecm.le.1.893)then
1393 c          bmx=ppbmx(3)
1394 c          if(ish.ge.7)write(ifch,*)'b_mx:',bmx
1395 c         elseif(ecm.le.1.899)then
1396 c          bmx=ppbmx(4)
1397 c         elseif(ecm.le.1.909)then
1398 c          bmx=ppbmx(5)
1399 c         elseif(ecm.le.1.913)then
1400 c          bmx=ppbmx(6)
1401 c         elseif(ecm.le.1.918)then
1402 c          bmx=ppbmx(7)
1403 c         else
1404 c          p=ecm*sqrt((ecm**2/4./.94**2)-1.)
1405 c          if(p.lt.0.8)then
1406 c           sig=23.5+1000.*(0.7-p)**4
1407 c          elseif(p.lt.1.5)then
1408 c           sig=23.5+24.6/(1+exp(-(p-1.2)/0.1))
1409 c          elseif(p.lt.5)then
1410 c           sig=41.+60.*(p-0.9)*exp(-1.2*p)
1411 c          else
1412 c           sig=48+.522*(alog(p)**2)-4.51*alog(p)
1413 c          endif
1414 c          bmx=sqrt(sig/10./pi)
1415 c         endif
1416 c        endif
1417 c
1418 c       elseif(nq.eq.0)then !-----------baryon-antibaryon ---->
1419 c
1420 c        if(kc(1).eq.0.and.kc(2).eq.0.and.kc(3).eq.0)then  !p-ap, n-an
1421 cc app
1422 c         if(ish.ge.7)write(ifch,*)'sig_app chosen'
1423 c         if(ecm.lt.2)then
1424 c          call utindx(napp,appecm,ecm,iecm)
1425 c          bmx=appbmx(iecm)
1426 c         else
1427 c          p=ecm*sqrt((ecm**2/4./.94**2)-1.)
1428 c          sig=38.4+77.6*p**(-.64)+.26*(alog(p)**2)-1.2*alog(p)
1429 c          bmx=sqrt(sig/10./pi)
1430 c         endif
1431 c        else                                              !p-an, n-ap
1432 cc apn
1433 c         if(ish.ge.7)write(ifch,*)'sig_apn chosen'
1434 c         if(ecm.lt.2)then
1435 c          call utindx(napn,apnecm,ecm,iecm)
1436 c          bmx=apnbmx(iecm)
1437 c         else
1438 c          p=ecm*sqrt((ecm**2/4./.94**2)-1.)
1439 c          sig=133.6*p**(-.7)-1.22*(alog(p)**2)+13.7*alog(p)
1440 c          bmx=sqrt(sig/10./pi)
1441 c         endif
1442 c        endif
1443 c
1444 c       elseif(nq.eq.3)then !----------baryon-meson ---->
1445 c
1446 c        if(kc(3).eq.0)then
1447 cc no kaons involved(except for K-L)
1448 c         if(kc(1).eq.0.or.kc(2).eq.0)then
1449 cc pip
1450 c          if(ish.ge.7)write(ifch,*)'sig_pip chosen'
1451 c          if(ecm.lt.2.5)then
1452 c           call utindx(npip,pipecm,ecm,iecm)
1453 c           bmx=pipbmx(iecm)
1454 c          else
1455 c           p=sqrt(((ecm**2-0.94**2-0.14**2)/2./0.94)**2.-0.14**2)
1456 c           sig=16.4+19.3*p**(-.42)+.19*(alog(p)**2)
1457 c           bmx=sqrt(sig/10./pi)
1458 c          endif
1459 c         else
1460 cc pim
1461 c          if(ish.ge.7)write(ifch,*)'sig_pim chosen'
1462 c          if(ecm.lt.2.5)then
1463 c           call utindx(npim,pimecm,ecm,iecm)
1464 c           bmx=pimbmx(iecm)
1465 c          else
1466 c           p=sqrt(((ecm**2-0.94**2-0.14**2)/2./0.94)**2.-0.14**2)
1467 c           sig=33.0+14.0*p**(-1.36)+.456*(alog(p)**2)-4.03*alog(p)
1468 c           bmx=sqrt(sig/10./pi)
1469 c          endif
1470 c         endif
1471 c        elseif(kc(3).eq.1)then
1472 cc strange particles involved
1473 c         if(kc(1).eq.0.or.kc(2).eq.0)then
1474 cc kmn
1475 c          if(ish.ge.7)write(ifch,*)'sig_kmn chosen'
1476 c          if(ecm.lt.2.5)then
1477 c           call utindx(nkmn,kmnecm,ecm,iecm)
1478 c           bmx=kmnbmx(iecm)
1479 c          else
1480 c           p=sqrt(((ecm**2-0.94**2-0.49**2)/2./0.94)**2.-0.49**2)
1481 c           sig=25.2+.38*(alog(p)**2)-2.9*alog(p)
1482 c           bmx=sqrt(sig/10./pi)
1483 c          endif
1484 c         else
1485 cc kmp
1486 c          if(ish.ge.7)write(ifch,*)'sig_kmp chosen'
1487 c          if(ecm.lt.2.5)then
1488 c           call utindx(nkmp,kmpecm,ecm,iecm)
1489 c           bmx=kmpbmx(iecm)
1490 c          else
1491 c           p=sqrt(((ecm**2-0.94**2-0.49**2)/2./0.94)**2.-0.49**2)
1492 c           sig=32.1+.66*(alog(p)**2)-5.6*alog(p)
1493 c           bmx=sqrt(sig/10./pi)
1494 c          endif
1495 c         endif
1496 c        elseif(kc(3).eq.-1)then
1497 cc strange particles involved
1498 c         if(kc(1).eq.3.or.kc(2).eq.3)then
1499 cc kpp
1500 c          if(ish.ge.7)write(ifch,*)'sig_kpp chosen'
1501 c          if(ecm.lt.2.5)then
1502 c           call utindx(nkpp,kppecm,ecm,iecm)
1503 c           bmx=kppbmx(iecm)
1504 c          else
1505 c           p=sqrt(((ecm**2-0.94**2-0.49**2)/2./0.94)**2.-0.49**2)
1506 c           sig=18.1+.26*(alog(p)**2)-alog(p)
1507 c           bmx=sqrt(sig/10./pi)
1508 c          endif
1509 c         else
1510 cc kpn
1511 c          if(ish.ge.7)write(ifch,*)'sig_kpn chosen'
1512 c           if(ecm.lt.2.5)then
1513 c           call utindx(nkpn,kpnecm,ecm,iecm)
1514 c           bmx=kpnbmx(iecm)
1515 c          else
1516 c           p=sqrt(((ecm**2-0.94**2-0.49**2)/2./0.94)**2.-0.49**2)
1517 c           sig=18.7+.21*(alog(p)**2)-.89*alog(p)
1518 c           bmx=sqrt(sig/10./pi)
1519 c          endif
1520 c         endif
1521 c        elseif(kc(3).ge.2)then
1522 cc two strange particles involved
1523 c         bmx=1.
1524 c        elseif(kc(3).le.-2)then
1525 cc two strange particles involved
1526 c        bmx=1.
1527 c        endif
1528 c
1529 c       else !-----------baryon_cluster-anything---->
1530 c
1531 c        write(ifch,*)'i:',i,' id_i:',idptl(i),' j:',j,' id_j:',idptl(j)
1532 c        write(ifch,*)'r_i:',radptl(i),' r_j:',radptl(j)
1533 c        write(ifch,*)'E_cm:',ecm,' jc:',(jc(k,1),k=1,6),(jc(k,2),k=1,6)
1534 c        write(ifch,*)'nq:',nq,' kc:',(kc(k),k=1,6)
1535 c        bmx=radptl(i)+radptl(j)
1536 c
1537 c       endif ! <--------------
1538 c
1539 cc -------------------------------------
1540 c      else  !   meson-meson
1541 cc -------------------------------------
1542 c
1543 c       call idquad(i,nqi,nai,jci)
1544 c       call idquad(j,nqj,naj,jcj)
1545 c       do l=1,nflav
1546 c        kci(l)=jci(l,1)-jci(l,2)
1547 c        kcj(l)=jcj(l,1)-jcj(l,2)
1548 c       enddo
1549 c
1550 c       if(kci(3).eq.0.and.pptl(5,i).le.1.0
1551 c     * .and.kcj(3).eq.0.and.pptl(5,j).le.1.0)then
1552 c
1553 c        if(kci(1).eq.0.and.kci(2).eq.0.and.pptl(5,i).le.0.5)then
1554 c         if(kcj(1).eq.0.and.kcj(2).eq.0.and.pptl(5,j).le.0.5)then
1555 cc pi0 pi0
1556 c          goto104
1557 c         elseif(kcj(1).eq.1.and.kcj(2).eq.-1)then
1558 cc pi0 pi+
1559 c          goto102
1560 c         elseif(kcj(1).eq.-1.and.kcj(2).eq.1)then
1561 cc pi0 pi-
1562 c          goto103
1563 c         else
1564 cc pi0 eta
1565 c          goto105
1566 c         endif
1567 c        elseif(kci(1).eq.1.and.kci(2).eq.-1)then
1568 c         if(kcj(1).eq.0.and.kcj(2).eq.0.and.pptl(5,j).le.0.5)then
1569 cc pi+ pi0
1570 c          goto102
1571 c         elseif(kcj(1).eq.1.and.kcj(2).eq.-1)then
1572 cc pi+ pi+
1573 c          goto101
1574 c         elseif(kcj(1).eq.-1.and.kcj(2).eq.1)then
1575 cc pi+ pi-
1576 c          goto104
1577 c         else
1578 cc pi+ eta
1579 c          goto105
1580 c         endif
1581 c        elseif(kci(1).eq.-1.and.kci(2).eq.1)then
1582 c         if(kcj(1).eq.0.and.kcj(2).eq.0.and.pptl(5,j).le.0.5)then
1583 cc pi- pi0
1584 c          goto103
1585 c         elseif(kcj(1).eq.1.and.kcj(2).eq.-1)then
1586 cc pi- pi+
1587 c          goto104
1588 c         elseif(kcj(1).eq.-1.and.kcj(2).eq.1)then
1589 cc pi- pi-
1590 c          goto101
1591 c         else
1592 cc pi- eta
1593 c          goto105
1594 c         endif
1595 c        else
1596 c         if(pptl(5,j).le.0.5)then
1597 cc eta pi
1598 c          goto105
1599 c         else
1600 cc eta eta
1601 c          goto106
1602 c         endif
1603 c        endif
1604 c101     continue
1605 c        if(ish.ge.7)write(ifch,*)'sig_pi+pi+  chosen'
1606 c        call utindx(npi1,pi1ecm,ecm,iecm)
1607 c        bmx=pi1bmx(iecm)
1608 c        goto110
1609 c102     continue
1610 c        if(ish.ge.7)write(ifch,*)'sig_pi+pi0  chosen'
1611 c        call utindx(npi2,pi2ecm,ecm,iecm)
1612 c        bmx=pi2bmx(iecm)
1613 c        goto110
1614 c103     continue
1615 c        if(ish.ge.7)write(ifch,*)'sig_pi-pi0  chosen'
1616 c        call utindx(npi3,pi3ecm,ecm,iecm)
1617 c        bmx=pi3bmx(iecm)
1618 c        goto110
1619 c104     continue
1620 c        if(ish.ge.7)write(ifch,*)'sig_pi-pi+  chosen'
1621 c        call utindx(npi4,pi4ecm,ecm,iecm)
1622 c        bmx=pi4bmx(iecm)
1623 c        goto110
1624 c105     continue
1625 c        if(ish.ge.7)write(ifch,*)'sig_pi_eta  chosen'
1626 c        call utindx(npi5,pi5ecm,ecm,iecm)
1627 c        bmx=pi5bmx(iecm)
1628 c        goto110
1629 c106     continue
1630 c        if(ish.ge.7)write(ifch,*)'sig_eta_eta  chosen'
1631 c        bmx=0.4   ! approx.  sig=5mb
1632 c110     continue
1633 c
1634 c       else !something else involved, strange etc.
1635 c
1636 c        bmx=0.6  ! approx.  sig=10mb
1637 c
1638 c       endif
1639 c
1640 cc --------------------------------
1641 c      endif
1642 cc --------------------------------
1643 c
1644 c      if(bij.le.bmx)ics=1
1645 c      if(ish.ge.7)then
1646 c      write(ifch,*)'b_mx:',bmx,' b_ij:',bij,' ics:',ics
1647 c      endif
1648 c
1649 c1000  continue
1650 c      call utprix('jintcs',ish,ishini,7)
1651 c      return
1652 c      end
1653 c
1654 cc----------------------------------------------------------------------
1655 c      subroutine jintel(i,j,p,amim,xaver)
1656 cc----------------------------------------------------------------------
1657 cc  elastic scattering of ptls i,j
1658 cc----------------------------------------------------------------------
1659 c      include 'epos.inc'
1660 c      real xaver(4)
1661 c      real p(5),u(5),pei(5),pej(5)
1662 c
1663 cc     determine momenta of outgoing particles (pei,pej)
1664 cc     -------------------------------------------------
1665 c           if(p(5).le.(pptl(5,i)+pptl(5,j))*.99)then
1666 c      if(ish.ge.1)then
1667 c      call utmsg('jintel')
1668 c      write(ifch,132)p(5),pptl(5,i)+pptl(5,j)
1669 c132   format(1x,'*****  m_fus < m_i+m_j ---> qcm set zero    ( '
1670 c     *,2f10.3,' )')
1671 c      write(ifch,133)'p_i:  ',(pptl(k,i),k=1,5)
1672 c      write(ifch,133)'p_j:  ',(pptl(k,j),k=1,5)
1673 c      write(ifch,133)'p_fus:',(p(k),k=1,5)
1674 c133   format(1x,a6,3x,5f10.3)
1675 c      call utmsgf
1676 c      endif
1677 c      qcm=0.
1678 c           elseif(p(5).le.pptl(5,i)+pptl(5,j))then
1679 c      qcm=0.
1680 c           else
1681 c      qcm=utpcm(p(5),pptl(5,i),pptl(5,j))
1682 c           endif
1683 c
1684 cc isotropic
1685 c      u(3)=2.*rangen()-1.
1686 c      phi=2.*pi*rangen()
1687 c      u(1)=sqrt(1.-u(3)**2)*cos(phi)
1688 c      u(2)=sqrt(1.-u(3)**2)*sin(phi)
1689 c      do 47 k=1,3
1690 c      pei(k)= qcm*u(k)
1691 c47    pej(k)=-qcm*u(k)
1692 c
1693 cc nonisotropic
1694 cc-c   pt=sqrt(2./pi)*ptq*sqrt(-2*alog(rangen()) !2-dim Gauss
1695 cc-c   if(pt.ge.qcm)pt=rangen()*qcm
1696 cc-c   qpl=sqrt(qcm**2-pt**2)
1697 cc-c   u(3)=qpl
1698 cc-c   phi=2.*pi*rangen()
1699 cc-c   u(1)=pt*cos(phi)
1700 cc-c   u(2)=pt*sin(phi)
1701 cc-c   call utaxis(i,j,a1,a2,a3)
1702 cc-c   ivt=1
1703 cc-c   if(a3.lt.0.)then
1704 cc-c   a1=-a1
1705 cc-c   a2=-a2
1706 cc-c   a3=-a3
1707 cc-c   ivt=-1
1708 cc-c   endif
1709 cc-c   call utrota(-1,a1,a2,a3,u(1),u(2),u(3))
1710 cc-c   do 47 k=1,3
1711 cc-c   pei(k)= u(k)*ivt
1712 cc-c47 pej(k)=-u(k)*ivt
1713 c
1714 c      pei(4)=sqrt(qcm**2+pptl(5,i)**2)
1715 c      pej(4)=sqrt(qcm**2+pptl(5,j)**2)
1716 c      pei(5)=pptl(5,i)
1717 c      pej(5)=pptl(5,j)
1718 c      call utlobo(-1,p(1),p(2),p(3),p(4),p(5)
1719 c     *,pei(1),pei(2),pei(3),pei(4))
1720 c      call utlobo(-1,p(1),p(2),p(3),p(4),p(5)
1721 c     *,pej(1),pej(2),pej(3),pej(4))
1722 c
1723 cc     fill /cptl/
1724 cc     -----------
1725 c      do 49 lo=1,2
1726 c      nptl=nptl+1
1727 c      if(lo.eq.1)ij=i
1728 c      if(lo.eq.2)ij=j
1729 c      do 48 k=1,5
1730 c      if(lo.eq.1)pptl(k,nptl)=pei(k)
1731 c      if(lo.eq.2)pptl(k,nptl)=pej(k)
1732 c48    continue
1733 c      istptl(nptl)=0
1734 c      idptl(nptl)=idptl(ij)
1735 c      ibptl(1,nptl)=ibptl(1,ij)
1736 c      ibptl(2,nptl)=ibptl(2,ij)
1737 c      ibptl(3,nptl)=ibptl(3,ij)
1738 c      ibptl(4,nptl)=ibptl(4,ij)
1739 c      xorptl(1,nptl)=xaver(1)
1740 c      xorptl(2,nptl)=xaver(2)
1741 c      xorptl(3,nptl)=xaver(3)
1742 c      xorptl(4,nptl)=xaver(4)
1743 c      iorptl(nptl)=i
1744 c      jorptl(nptl)=j
1745 c      tivptl(1,nptl)=xaver(4)
1746 c      call idtau(idptl(nptl),pptl(4,nptl),pptl(5,nptl),taugm)
1747 c      tivptl(2,nptl)=tivptl(1,nptl)+taugm*(-alog(rangen()))
1748 c      ifrptl(1,nptl)=0
1749 c      ifrptl(2,nptl)=0
1750 c      ityptl(nptl)=ityptl(ij)
1751 c49    continue
1752 c
1753 c1000  return
1754 c      end
1755 c
1756 cc----------------------------------------------------------------------
1757 c      subroutine jintfs(i,j,p,nq,jc,amim,iret)
1758 cc----------------------------------------------------------------------
1759 cc  input:
1760 cc    i,j: particle indices
1761 cc  output:
1762 cc    p: 5-momentum of fused ptl
1763 cc    nq: net quark number of fused ptl
1764 cc    jc: jc of fused ptl
1765 cc    amim : minimum mass of fused ptl
1766 cc    iret: return code
1767 cc            0=ok
1768 cc            1=mass p(5) less than amim
1769 cc----------------------------------------------------------------------
1770 c      include 'epos.inc'
1771 c      integer jci(nflav,2),jcj(nflav,2),jc(nflav,2)
1772 c      real p(5)
1773 c      double precision ppfus(4),pp52
1774 c
1775 c      iret=0
1776 c
1777 c      do 35 k=1,4
1778 c       p(k)=pptl(k,i)+pptl(k,j)
1779 c35    ppfus(k)=dble(p(k))
1780 c      pp52=ppfus(4)**2-ppfus(3)**2-ppfus(2)**2-ppfus(1)**2
1781 c      if(pp52.le.0.)then
1782 c       if(ish.ge.1)then
1783 c        call utmsg('jintfs')
1784 c        write(ifch,*)'*****  mfus**2 < 0    (',pp52,' )'
1785 c        write(ifch,*)(ppfus(m),m=1,4)
1786 c        call utmsgf
1787 c       endif
1788 c       goto1001
1789 c      endif
1790 c      p(5)=sngl(dsqrt(pp52))
1791 c
1792 c      call idquad(i,nqi,nai,jci)
1793 c      call idquad(j,nqj,naj,jcj)
1794 c      do 29 n=1,nflav
1795 c       do 29 k=1,2
1796 c29    jc(n,k)=jci(n,k)+jcj(n,k)
1797 c      nq=0
1798 c      do 54 n=1,nflav
1799 c54    nq=nq+jc(n,1)-jc(n,2)
1800 c
1801 c      call idcomj(jc)
1802 c      amim=utamnz(jc,5)+amimfs
1803 c      if(p(5).lt.amim)goto1001
1804 c      goto1000
1805 c1001  iret=1
1806 c1000  return
1807 c      end
1808 c
1809 cc----------------------------------------------------------------------
1810 c      subroutine jintfu(i,j,p,jc)
1811 cc----------------------------------------------------------------------
1812 cc input:
1813 cc   i,j: particle indices
1814 cc   p,jc: momentum and jc of fused object
1815 cc outout:
1816 cc   id, ib, ist, ior, jor, ifr, ity of fused particle
1817 cc   written to /cptl/ after increasing nptl by 1
1818 cc----------------------------------------------------------------------
1819 c
1820 c      include 'epos.inc'
1821 c      parameter (mxlook=10000,mxdky=2000)
1822 c      common/dkytab/look(mxlook),cbr(mxdky),mode(5,mxdky)
1823 c      real p(5)
1824 c      integer jc(nflav,2),ic(2),ib(4)
1825 c
1826 c      nptl=nptl+1
1827 c
1828 cc momentum
1829 c      do k=1,5
1830 c       pptl(k,nptl)=p(k)
1831 c      enddo
1832 c      amf=p(5)
1833 c
1834 cc determine idr, ib(1-4)
1835 c      idr=0
1836 c      do 40 nf=1,nflav
1837 c      do 40 ij=1,2
1838 c      if(jc(nf,ij).ge.10)idr=7*10**8
1839 c40    continue
1840 c           if(idr/10**8.ne.7)then
1841 c      call idenco(jc,ic,ireten)
1842 c      if(ireten.eq.1)call utstop('jintfu: idenco ret code = 1&')
1843 c      id=idtra(ic,0,0,3)
1844 c43    amc=amf
1845 c      call idres(id,amc,idr,iadj)
1846 c          if(idr.ne.0)then
1847 c      lid=look(iabs(idr))
1848 c      if((lid.le.0.or.lid.gt.0.and.mode(2,lid).eq.0)
1849 c     *.and.pptl(5,nptl).gt.amc+1e-3)then
1850 c      amf=amf+0.010
1851 c      goto43
1852 c      endif
1853 c      if((lid.le.0.or.lid.gt.0.and.mode(2,lid).eq.0)
1854 c     *.and.abs(amc-pptl(5,nptl)).gt.1e-3)then
1855 c      if(ish.ge.1)then
1856 c      call utmsg('jintfu')
1857 c      write(ifch,*)'*****  not on mass shell after fusion: '
1858 c     *,pptl(5,nptl),amc
1859 c      call utmsgf
1860 c      endif
1861 c      endif
1862 c           endif
1863 c           if(idr.eq.0)then
1864 c      if(mod(ic(1),100).ne.0.or.mod(ic(2),100).ne.0)then
1865 c      idr=9*10**8
1866 c      else
1867 c      idr=8*10**8+ic(1)*100+ic(2)/100
1868 c      endif
1869 c           endif
1870 c           else
1871 c      call idtrbi(jc,ib(1),ib(2),ib(3),ib(4))
1872 c      idr=idr
1873 c     *+mod(jc(1,1)+jc(2,1)+jc(3,1)+jc(4,1),10**4)*10**4
1874 c     *+mod(jc(1,2)+jc(2,2)+jc(3,2)+jc(4,2),10**4)
1875 c      if(ish.ge.7)write(ifch,*)'ib:',(ib(kk),kk=1,4)
1876 c           endif
1877 c
1878 c      n=nptl
1879 c
1880 cc     fill /cptl/
1881 cc     -----------
1882 c      idptl(n)=idr
1883 c      do k=1,4
1884 c      ibptl(k,n)=ib(k)
1885 c      enddo
1886 c      istptl(n)=0
1887 c      iorptl(n)=i
1888 c      jorptl(n)=j
1889 c      ifrptl(1,n)=0
1890 c      ifrptl(2,n)=0
1891 c      ityptl(n)=50
1892 c
1893 c      return
1894 c      end
1895 c
1896 c----------------------------------------------------------------------
1897       subroutine jintpo(lclean,iret)
1898 c----------------------------------------------------------------------
1899 c  parton-ladder-fusion -- 3D grid -- based on string segments
1900 c----------------------------------------------------------------------
1901       include 'epos.inc'
1902       include 'epos.incems'
1903       include 'epos.incico'
1904       common/cxyzt/xptl(mxptl),yptl(mxptl),zptl(mxptl),tptl(mxptl)
1905      *,optl(mxptl),uptl(mxptl),sptl(mxptl),rptl(mxptl,3)
1906       parameter(m1grid=10,kgrid=3,kegrid=3)
1907       parameter(m3xgrid=21*kgrid*kegrid)
1908       parameter(mxcl=4000,mxcli=1000)
1909       integer idropgrid(m1grid,m1grid,m3xgrid)
1910      &       ,jdropgrid(m1grid,m1grid,m3xgrid)
1911      &       ,jclu(m3xgrid),nsegp4(mxcl)
1912      &       ,irep(mxcl),mmji(mxcl,mxcli)
1913      &       ,jccl(mxcl,nflav,2),nseg(mxcl),mseg(mxcl),kclu(mxcl)
1914      &       ,naseg(0:mxcl),nfseg(mxcl),nsegmx(mxcl)
1915      &       ,jc(nflav,2),ke(6),jcjj(nflav,2)
1916      &       ,nsegmt(mxptl),kmean(2,1001:1000+mxcl)
1917      &       ,ncluj(1001:1000+mxptl)   !,ic(2),nclk(m3xgrid)
1918       double precision tpro,zpro,ttar,ztar,ttaus,detap,detat
1919      &                ,pptld(5,mxcl),p4tmp
1920       double precision enp,pzp,ena,pza,ccc,sss,enew,pznew,taa2,pta2
1921      .,pold,pnew,pnew2,p5a2,eeta,enf,pzf 
1922       common   /cttaus/tpro,zpro,ttar,ztar,ttaus,detap,detat
1923       common/cdelzet/delzet,delsgr /cvocell/vocell
1924       common/cranphi/ranphi
1925       parameter(maxp=40*mxcl)
1926       dimension yrad(maxp),phirad(maxp),pe(5),yrad2(maxp),nfrag(mxptl)
1927       logical first,lnew(m1grid,m1grid),lold(m1grid,m1grid),lcont,lpass
1928      &,lclean
1929       double precision ptest(5),ttest,p52,p4mean(4,mxcl),zor,tor,xmxms
1930      &,ppp(5),be(4),energ,bp,rmean(2,mxcl)         !,qqq(5),www(5)
1931       dimension mpair(mamx,mamx)
1932       save ncntpo!,ntrr,ntrt
1933       data ncntpo /0/!,ntrr/0/,ntrt/0/
1934       ncntpo=ncntpo+1
1935       call utpri('jintpo',ish,ishini,4)
1936       tauico=ttaus
1937 
1938       if(kigrid.gt.kgrid)then
1939         write(ifmt,*)'kigrid,kgrid:',kigrid,kgrid
1940         stop'jintpo: kigrid too big.          '
1941       endif
1942 
1943       fegrid=yhaha/5.36                 !rapidity range/rap range at RHIC
1944       if(fegrid.gt.kegrid)then
1945         write(ifmt,*)'fegrid,kegrid:',fegrid,kegrid
1946         stop'jintpo: kegrid too small.       '
1947       endif
1948 
1949       m3grid=m3xgrid /kgrid *kigrid /kegrid *fegrid 
1950 c      if(iLHC.eq.1)m3grid=min(m3xgrid,int(m3grid*0.75))
1951       if(mod(m3grid,2).eq.0)m3grid=m3grid+1
1952 
1953       xgrid=8
1954       sgrid=fsgrid *ttaus  *fegrid *6.0 
1955       delxgr=2*xgrid/m1grid
1956       delsgr=2*sgrid/m3grid
1957       shiftx=(1.-2.*rangen())*rangen()*delxgr/2.
1958       shifts=(1.-2.*rangen())*rangen()*delsgr/2.
1959       vocell= delxgr * delxgr * delsgr
1960       delzet=delsgr/ttaus
1961       nptla=nptl
1962       iflhc=1
1963       if(iLHC.eq.1)iflhc=min(3,max(1,nsegce-1))
1964       nsegsuj=max(nsegce,nint(float(nsegsu/iflhc)*fegrid))
1965       xmxms=150d0      !maximum mass for a subcluster
1966 
1967       if(ncntpo.eq.1)then
1968         write(ifmt,*)'EPOS used with FUSION option'
1969         if(ish.ge.1)then
1970       print*,'+',('-',i=1,57)
1971       print*,'| ttaus sgrid nsegce:',ttaus,fsgrid,'  ',nsegce
1972       print*,'| sgrid  delxgr delsgr vocell:',sgrid,delxgr,delsgr,vocell
1973       print*,'+',('-',i=1,57)
1974         endif
1975       endif
1976 c      print*,'+',('-',i=1,57)
1977 
1978 c...compute x,y,z
1979 
1980       if(ish.ge.6)write(ifch,*)'compute x,y,z'
1981       do n=1,nptla
1982         iaaptl(n)=1
1983         !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1984         ! the following check is important for  ioclude= 4 or 5 
1985         !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1986         if(ioclude.ne.3.and.istptl(n).eq.10)then
1987         stop'\n\n remnant cluster detected in jintpo\n\n'
1988         endif
1989         if(istptl(n).eq.0.or.istptl(n).eq.10)then
1990           call jtain(n,xptl(n),yptl(n),zptl(n),tptl(n),nnn,0)
1991           call idtau(idptl(n),pptl(4,n),pptl(5,n),taurem)
1992           if(abs(taurem).gt.1e-6.and.
1993      .    ityptl(n).ge.40.and.ityptl(n).le.59.and.nnn.eq.1)then
1994            iaaptl(n)=0         !!!!nnn=1: ptl lives later
1995 c           print*,n,ityptl(n),idptl(iorptl(n)),istptl(iorptl(n)),nnn 
1996           endif
1997           call jtaus(zptl(n),tz,sptl(n))
1998           strap=1e10
1999           xpl=tptl(n)+zptl(n)
2000           xmi=tptl(n)-zptl(n)
2001           if(xmi.gt.0.0.and.xpl.gt.0.0)then
2002             strap=0.5*log(xpl/xmi)
2003           else           !particle at eta=inf
2004             iaaptl(n)=0    
2005           endif
2006           dezptl(n)=strap       !space-time-rapidity
2007 c          write(ifch,*)'dez ???',n,nnn,taurem,ityptl(n)
2008 c     & ,pptl(4,n),pptl(3,n),idptl(n),xptl(n),yptl(n),zptl(n),sptl(n)
2009         else
2010           iaaptl(n)=0    
2011           xptl(n)=0.
2012           yptl(n)=0.
2013           zptl(n)=0.
2014           sptl(n)=0.
2015           dezptl(n)=1e10
2016         endif
2017       enddo
2018       ntry=0
2019 
2020 c...valid particles
2021 
2022 c      print *,'start -----------------------------------------'
2023       ptmax=ptclu**2
2024       nptlo=1
2025       if(iLHC.eq.1)nptlo=maproj+matarg+1
2026       do n=1,nptla
2027        !random number calls before if's
2028        !to keep random number sequence for testing
2029         rdm=rangen()
2030         if(istptl(n).eq.0)then
2031           call idquac(n,idum1,idum2,idum3,jc)
2032         else
2033           jc(4,1)=0
2034           jc(4,2)=0
2035         endif
2036        if(iaaptl(n).ne.0)then
2037         if(istptl(n).ne.10)then
2038           pt2=pptl(1,n)**2+pptl(2,n)**2
2039           am2tmp=(pptl(4,n)+pptl(3,n))*(pptl(4,n)-pptl(3,n))-pt2
2040           if(n.le.nptlo)then         !spectators
2041             iaaptl(n)=0
2042           elseif(ityptl(n).eq.47.or.ityptl(n).eq.57)then
2043             iaaptl(n)=0        !no active spectators
2044           elseif(istptl(n).ne.0.or.ityptl(n).ge.60)then
2045             iaaptl(n)=0
2046           elseif(abs(idptl(n)).le.100)then
2047             iaaptl(n)=0         !no fundamental particle (electron...)
2048          !elseif(ityptl(n).eq.41.or.ityptl(n).eq.51)then
2049          !  iaaptl(n)=0     !avoid particles coming from remnant droplet decay
2050          !                       !(already droplet decay products !)
2051           elseif(abs(am2tmp-pptl(5,n)*pptl(5,n)).gt.30.)then
2052             iaaptl(n)=0         !to discard off shell particles
2053           elseif(jc(4,1).ne.0.or.jc(4,2).ne.0)then
2054             iaaptl(n)=0         !to discard charmed particles
2055           elseif(iLHC.eq.1)then
2056             if(pt2.lt.1.e-3)then
2057               iaaptl(n)=0           !to discard slow proton (spectators)
2058             elseif(ptclu.gt.0.)then
2059              if(pt2.gt.(1.5*ptclu)**2)then
2060               ptmax=max(ptmax,pt2)
2061               if(ioquen.eq.0.or.fploss.le.0.)then  !high pt particle escape
2062                 iaaptl(n)=0
2063               elseif(fploss.gt.1.e10)then   !high pt particle absorbed
2064                 iaaptl(n)=1
2065               else                       
2066                 iaaptl(n)=-1                !high pt particle lose energy
2067               endif
2068              elseif(pt2.gt.(0.5*ptclu)**2)then
2069               if(rdm.lt.(sqrt(pt2)-0.5*ptclu)/ptclu)then
2070                 ptmax=max(ptmax,pt2)
2071                 if(ioquen.eq.0.or.fploss.le.0.)then !high pt particle escape
2072                   iaaptl(n)=0
2073                 elseif(fploss.gt.1.e10)then !high pt particle absorbed
2074                   iaaptl(n)=1
2075                 else                       
2076                   iaaptl(n)=-1  !high pt particle lose energy
2077                 endif
2078               endif
2079              endif
2080             else
2081               if(ioquen.eq.0.or.fploss.le.0.)then  !high pt particle escape
2082                 iaaptl(n)=0
2083               elseif(fploss.gt.1.e10)then   !high pt particle absorbed
2084                 iaaptl(n)=1
2085               else                       
2086                 iaaptl(n)=-1                !high pt particle lose energy
2087               endif
2088             endif
2089           elseif(pt2.gt.(1.5*ptclu)**2)then
2090             ptmax=max(ptmax,pt2)
2091             if(maproj.lt.20.or.matarg.lt.20.or.ioquen.eq.0)then
2092               iaaptl(n)=0
2093             endif
2094           elseif(pt2.gt.(0.5*ptclu)**2)then
2095             if(rdm.lt.(sqrt(pt2)-0.5*ptclu)/ptclu)then
2096               if(maproj.lt.20.or.matarg.lt.20.or.ioquen.eq.0)iaaptl(n)=0
2097             endif
2098           endif
2099         endif
2100        endif
2101 c        if(iaaptl(n).eq.0.and.abs(idptl(n)).le.10000.and.abs(idptl(n))
2102 c     &    .ge.100.and.mod(abs(idptl(n)),100).ne.0
2103 c     &   .and.ityptl(n).ne.0.and.ityptl(n).lt.50)
2104 c     &  print*,'not selected',idptl(n),ityptl(n),pptl(4,n)
2105       enddo
2106 
2107 c...Start cluster formation
2108 
2109  8888 continue
2110 
2111       nsegsuj=max(nsegce,nint(nsegsuj/1.08**ntry))
2112       ntry=ntry+1
2113       if(ntry.gt.90)        !do not put more than 100 or change limit for p4mean
2114      &call utstop('jintpo: cluster formation impossible ! &')
2115       nptl=nptla
2116 
2117       do 1 k=1,m3grid
2118       do 1 j=1,m1grid
2119       do 1 i=1,m1grid
2120       idropgrid(i,j,k)=0
2121   1   continue
2122 
2123 c...count string segments in cell
2124 
2125       if(ish.ge.6)write(ifch,*)'count string segments in cell'
2126       do n=1,nptla
2127         if(iaaptl(n).ne.0)then
2128           i=1+(xptl(n)+xgrid+shiftx)/delxgr
2129           j=1+(yptl(n)+xgrid+shiftx)/delxgr
2130           k=1+(sptl(n)+sgrid+shifts)/delsgr
2131           if(  i.ge.1.and.i.le.m1grid
2132      &    .and.j.ge.1.and.j.le.m1grid
2133      &    .and.k.ge.1.and.k.le.m3grid)then
2134             nfrag(n)=1
2135             if(iLHC.eq.1)then  !count number of quarks to absorbe more baryon than mesons
2136               call idquac(n,idum1,idum2,idum3,jc)
2137               nfrag(n)=0
2138               do nj=1,2
2139                 do ni=1,nflav
2140                   nfrag(n)=nfrag(n)+ni*jc(ni,nj)
2141                 enddo
2142               enddo
2143               
2144             endif
2145 c            print *,idptl(n),nfrag(n)
2146             idropgrid(i,j,k)=idropgrid(i,j,k)+nfrag(n)
2147           endif
2148         endif
2149       enddo
2150 
2151 
2152       if(iLHC.eq.1)then
2153 cc...check high pt segments
2154 c      !to use this part one has to define:
2155 c      !...  1 = valid
2156 c      !... -1 = valid but high pt
2157 c      !...  0 = not valid
2158 c
2159 
2160 c      esu=0
2161 c      do i=1,nptla
2162 c      if(istptl(i).eq.0.or.istptl(i).eq.3)esu=esu+pptl(4,i)
2163 c      enddo
2164 c      write(ifmt,'(a,41x,f15.1)')' +++++Eajint+++++',esu
2165 
2166       if(ish.ge.6)write(ifch,*)'check high pt segments'
2167       if(fploss.gt.0.0)then
2168       ein=0
2169       elo=0
2170       do n=1,nptla
2171         delen=0.
2172         if(iaaptl(n).eq.-1)then
2173           i=1+(xptl(n)+xgrid+shiftx)/delxgr
2174           j=1+(yptl(n)+xgrid+shiftx)/delxgr
2175           k=1+(sptl(n)+sgrid+shifts)/delsgr
2176           if(   i.ge.1.and.i.le.m1grid
2177      &     .and.j.ge.1.and.j.le.m1grid
2178      &     .and.k.ge.1.and.k.le.m3grid)then
2179            iescape=0  
2180            xa=xptl(n)
2181            ya=yptl(n)
2182            eta=dezptl(n)
2183            pz=pptl(3,n)
2184            en=pptl(4,n)
2185            taa2=pptl(1,n)**2+pptl(2,n)**2+pptl(5,n)**2
2186            pza=pz   
2187            ena=sqrt(taa2+pza**2)
2188            enaxx=en  
2189            p5a2=pptl(5,n)**2
2190            pta2=pptl(1,n)**2+pptl(2,n)**2
2191            !transform to bjo
2192            eeta=eta
2193            ccc=cosh(eeta)  
2194            sss=sinh(eeta)  
2195            enp= ena*ccc-pza*sss
2196            pzp=-ena*sss+pza*ccc
2197            vz=pzp/enp
2198            vx=pptl(1,n)/enp
2199            vy=pptl(2,n)/enp
2200            !print*,'+++++++',eta,vz,pz/en
2201            if(vx.ne.0.0.or.vy.ne.0.0)then
2202              if(abs(vx).ge.abs(vy))then
2203                ica=1
2204                rat=vy/vx
2205                is=sign(1.,vx)
2206                l=i
2207                va=xa
2208                wa=ya
2209              else
2210                ica=2
2211                rat=vx/vy
2212                is=sign(1.,vy)
2213                l=j
2214                va=ya
2215                wa=xa
2216              endif
2217              if(is.eq.-1)then
2218                imax=1
2219              else                 !if(is.eq. 1)
2220                imax=m1grid
2221              endif
2222              vr=sqrt(vx**2+vy**2)
2223              ratx=vz/vr
2224              qu=fploss*delxgr*sqrt(1+rat**2)*sqrt(1+ratx**2)
2225              do lu=l,imax,is
2226               vu=-(xgrid+shiftx)+(lu-0.5)*delxgr
2227               wu=wa+rat*(vu-va)
2228               mu=1+(wu+xgrid+shiftx)/delxgr
2229               if(mu.ge.1.and.mu.le.m1grid)then
2230                 if(ica.eq.1)then
2231                   ix=lu
2232                   jx=mu
2233                 else
2234                   ix=mu
2235                   jx=lu
2236                 endif 
2237                 if(idropgrid(i,j,k).ge.nsegce)then
2238                   dens=float(idropgrid(ix,jx,k))/float(iflhc)
2239                 else
2240                   dens=0
2241                 endif
2242                 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2243                 ! DeltaE ~ sqrt(T**3*E) * dL (BDMPS2008)
2244                 ! -> DeltaE ~ dens^3/8 * sqrt(E) *dL
2245                 !del=dens**(3./8.)*max(1.,sqrt(pptl(4,n))) 
2246                 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2247                 escale=6
2248                 xen=enp/escale
2249                 del=0.02*dens**(3./8.)*max(1.,sqrt(xen)) 
2250                 delen=delen+del*escale*qu
2251 c                if(k.ge.m3grid/2-2.and.k.le.m3grid/2+4)
2252 c     &               write(ifch,'(2i3,4x,2i3,4x,2i3,4x,i3,3f7.3)')
2253 c     &               k,ica,i,j,ix,jx,idropgrid(ix,jx,k),qu,delen
2254 c     &               ,pptl(4,n)-delen
2255                endif
2256              enddo
2257            endif
2258            pold=sqrt(pta2+pzp**2)
2259            enew=enp-delen
2260            pnew2=enew**2-p5a2
2261            if(enew.gt.0..and.pnew2.gt.0.)iescape=1  
2262            if(iescape.eq.1)then  
2263               iaaptl(n)=0
2264               idropgrid(i,j,k)=idropgrid(i,j,k)-nfrag(n)
2265               if(idropgrid(i,j,k).lt.0)stop'jintpo: not possible.    '
2266               pnew=sqrt(pnew2)
2267               p1=pnew*pptl(1,n)/pold
2268               p2=pnew*pptl(2,n)/pold
2269               pznew=pnew*pzp   /pold      
2270               enf= enew*ccc+pznew*sss
2271               pzf= enew*sss+pznew*ccc
2272               if(ish.ge.1.and.enf.gt.ena.or.enf.ne.enf)then
2273                 if(ish.ge.1.and.(enf-ena.gt.0.1d0.or.enf.ne.enf))then
2274                 write(ifmt,*)'WWWW en gain for eta =',eta
2275                 write(ifmt,*)'e pz bf (lab)',ena,pza,enaxx
2276                 write(ifmt,*)'e pz bf (bjo)',enp,pzp   ,enp**2-pzp**2
2277                 write(ifmt,*)'e pz af (bjo)',enew,pznew,enew**2-pznew**2
2278                 write(ifmt,*)'e pz af (lab)',enf,pzf   ,enf**2-pzf**2
2279 c                stop
2280                 endif
2281               elseif(delen.gt.1e-3)then
2282 c create fake particle with energy lost in cluster
2283                 nptl=nptl+1   
2284                 nptla=nptla+1
2285                 istptl(nptl)=3  !daughter part of cluster
2286                 iaaptl(nptl)=1
2287                 pptl(1,nptl)=pptl(1,n)-p1
2288                 pptl(2,nptl)=pptl(2,n)-p2
2289                 pptl(3,nptl)=pptl(3,n)-pzf
2290                 pptl(4,nptl)=pptl(4,n)-enf
2291                 do l=1,3
2292                   xorptl(l,nptl)=xorptl(l,n)
2293                 enddo
2294           ! mother
2295                 pptl(1,n)=p1
2296                 pptl(2,n)=p2
2297                 pptl(3,n)=pzf     
2298                 tivptl(1,n)=xorptl(4,n)
2299                 pptl(4,n)=sqrt(pptl(1,n)**2+pptl(2,n)**2
2300      &                        +pptl(3,n)**2+pptl(5,n)**2)
2301                 if(abs(pptl(4,n)-enf).gt.0.01*pptl(4,n))
2302      &   print *,'jintpo eloss',pptl(4,n),enf,(pptl(4,n)-enf)/pptl(4,n)
2303                 call idtau(idptl(n),pptl(4,n),pptl(5,n),taugm)
2304                 tivptl(2,n)=tivptl(1,n)+taugm*(-alog(rangen()))
2305                 ifrptl(1,n)=nptl
2306           ! daughter
2307                 pptl(5,nptl)=0.
2308                 pptl(4,nptl)=sqrt(pptl(1,nptl)**2+pptl(2,nptl)**2
2309      &                           +pptl(3,nptl)**2+pptl(5,nptl)**2)
2310                 xorptl(4,nptl)=xorptl(4,n)
2311                 tivptl(1,nptl)=tivptl(1,n)
2312                 iorptl(nptl)=n
2313                 jorptl(nptl)=0
2314                 idptl(nptl)=idptl(n)*100+sign(99,idptl(n))
2315                 ityptl(nptl)=ityptl(n)+2
2316                 xptl(nptl)=xptl(n)
2317                 yptl(nptl)=yptl(n)
2318                 zptl(nptl)=zptl(n)
2319                 sptl(nptl)=sptl(n)
2320                 dezptl(nptl)=dezptl(n)
2321                 if(ish.ge.6)write(ifch,*)'--> Virtual particle : ',nptl
2322      & ,idptl(nptl),iorptl(nptl),ityptl(nptl),(pptl(kk,nptl),kk=1,5)
2323               endif
2324               elo= elo+ena-pptl(4,n)  
2325               !write(ifch,*)n,'      escape'
2326            else
2327               iaaptl(n)=1
2328               ein=ein+pptl(4,n) 
2329               !write(ifch,*)n,'core'
2330            endif
2331           endif
2332         endif
2333       enddo
2334       else
2335       do n=1,nptla
2336         if(iaaptl(n).eq.-1)then
2337           iaaptl(n)=0
2338         endif
2339       enddo
2340       endif
2341 
2342 c      eloss=esu
2343 c      esu=0
2344 c      do i=1,nptla
2345 c      if(istptl(i).eq.0.or.istptl(i).eq.3)esu=esu+pptl(4,i)
2346 c      enddo
2347 c      write(ifmt,'(a,41x,f15.1)')' +++++Eajint+++++',esu
2348 c      eloss=eloss-esu
2349 c      write(ifch,*)'+++++ein,elo,eloss ',ein,elo,eloss
2350 
2351 
2352 c      do n=1,nptla
2353 c        if(iaaptl(n).eq.-1)then
2354 c          i=1+(xptl(n)+xgrid+shiftx)/delxgr
2355 c          j=1+(yptl(n)+xgrid+shiftx)/delxgr
2356 c          k=1+(sptl(n)+sgrid+shifts)/delsgr
2357 c          if(  i.ge.1.and.i.le.m1grid
2358 c     &    .and.j.ge.1.and.j.le.m1grid
2359 c     &    .and.k.ge.1.and.k.le.m3grid)then
2360 c            if(idropgrid(i,j,k).lt.2*nsegce)then  !surface segments
2361 c              iaaptl(n)=0
2362 c              idropgrid(i,j,k)=idropgrid(i,j,k)-1
2363 c              if(idropgrid(i,j,k).lt.0)stop'jintpo: not possible.    '
2364 cc           else
2365 cc             iaaptl(n)=1
2366 c           endif
2367 c          endif
2368 c        endif
2369 c      enddo
2370 
2371       endif
2372 
2373 c...identify clusters
2374 
2375       ifirst=0
2376       if(ish.ge.6)write(ifch,*)'identify clusters'
2377       do k=1,m3grid !~~~~~~k-loop
2378         jjj=0
2379         do j=1,m1grid
2380           first=.true.
2381           do i=1,m1grid
2382             if(idropgrid(i,j,k).ge.nsegce)then
2383               if(first)then
2384                 ifirst=i
2385                 jjj=jjj+1
2386                 if(jjj.gt.mxcl)stop'jintpo: mxcl too small.   '
2387                 irep(jjj)=0
2388                 jj=jjj
2389                 first=.false.
2390               endif
2391               jdropgrid(i,j,k)=jj
2392               if(j.gt.1)then
2393                if(jdropgrid(i,j-1,k).ne.0)then
2394                 jjo=jdropgrid(i,j-1,k)
2395                 if(jjo.lt.jj)then
2396                   if(jj.eq.jjj)jjj=jjj-1
2397                   jjx=jj
2398                   jj=jjo
2399                   do ii=ifirst,i
2400                     jdropgrid(ii,j,k)=jj
2401                     if(jdropgrid(ii,j-1,k).eq.jjx)then
2402                       if(jjx.gt.jjj)jjj=jjj+1
2403                       jja=jjx
2404                       jjb=jj
2405   90                  continue
2406                       if(irep(jja).eq.0.or.irep(jja).eq.jjb)then
2407                         irep(jja)=jjb
2408                       else
2409                         mn=min(irep(jja),jjb)
2410                         mx=max(irep(jja),jjb)
2411                         irep(jja)=mn
2412                         jja=mx
2413                         jjb=mn
2414                         goto 90
2415                       endif
2416                     endif
2417                   enddo
2418                 elseif(jdropgrid(i,j-1,k).gt.jj)then
2419                   irep(jjo)=jj
2420                 endif
2421                endif
2422               endif
2423             else
2424               jdropgrid(i,j,k)=0
2425               first=.true.
2426             endif
2427           enddo
2428         enddo
2429         !~~~~cluster jj ---> cluster irep(jj)
2430         do jj=jjj,1,-1
2431          if(irep(jj).ne.0)then
2432            do j=1,m1grid
2433              do i=1,m1grid
2434                if(jdropgrid(i,j,k).eq.jj)jdropgrid(i,j,k)=irep(jj)
2435              enddo
2436            enddo
2437          endif
2438         enddo
2439         !~~~~~remove empty cluster indices
2440         jjjx=jjj
2441         jjj=0
2442         jj=0
2443         do jjx=1,jjjx
2444          if(irep(jjx).eq.0)then
2445            jj=jj+1
2446            jjj=jjj+1
2447          else
2448            do j=1,m1grid
2449              do i=1,m1grid
2450                if(jdropgrid(i,j,k).gt.jj)
2451      &           jdropgrid(i,j,k)=jdropgrid(i,j,k)-1
2452              enddo
2453            enddo
2454          endif
2455         enddo
2456         !~~~~~
2457         jclu(k)=jjj
2458       enddo !~~~~~~~~~~~~~~~~~ END k-loop
2459 
2460 c...add segments to avoid holes
2461 
2462       if(ish.ge.6)write(ifch,*)'add segments from holes'
2463       if(iohole.eq.1.and.iLHC.eq.1)then
2464       do 83 n=1,nptla
2465         if(iaaptl(n).eq.0)goto 83
2466         ihit=0
2467         i=1+(xptl(n)+xgrid+shiftx)/delxgr
2468         j=1+(yptl(n)+xgrid+shiftx)/delxgr
2469         k=1+(sptl(n)+sgrid+shifts)/delsgr
2470         if(    i.ge.1.and.i.le.m1grid
2471      &          .and.j.ge.1.and.j.le.m1grid
2472      &          .and.k.ge.1.and.k.le.m3grid)then
2473           jgr=jdropgrid(i,j,k)
2474           nplus=idropgrid(i,j,k)
2475           if(jgr.eq.0)then          
2476             isgi=1
2477             if(rangen().gt.0.5)isgi=-1
2478             isgj=1
2479             if(rangen().gt.0.5)isgj=-1
2480             isgk=1
2481             if(rangen().gt.0.5)isgk=-1
2482             do ii=i-isgi,i+isgi,isgi
2483             do jj=j-isgj,j+isgj,isgj
2484             do kk=k-isgk,k+isgk,2*isgk
2485               if(  ii.ge.1.and.ii.le.m1grid
2486      .        .and.jj.ge.1.and.jj.le.m1grid
2487      .        .and.kk.ge.1.and.kk.le.m3grid)then
2488           if(jdropgrid(ii,jj,kk).gt.0)nplus=nplus+1
2489 c                 nplus=idropgrid(ii,jj,kk)+iflhc
2490                  if(nplus.ge.nsegce)then
2491                    ihit=1
2492 c                   goto 84
2493                  endif
2494               endif
2495             enddo
2496             enddo
2497             enddo
2498           endif
2499         endif
2500 c   84   continue
2501         if(ihit.eq.1)then
2502           idropgrid(i,j,k)=nplus!idropgrid(i,j,k)+iflhc
2503 c add cell randomly to adjacent cluster if any
2504           isgi=1
2505           if(rangen().gt.0.5)isgi=-1
2506           isgj=1
2507           if(rangen().gt.0.5)isgj=-1
2508           do ii=i-isgi,i+isgi,2*isgi
2509             do jj=j-isgj,j+isgj,2*isgj
2510               if(  ii.ge.1.and.ii.le.m1grid
2511      .        .and.jj.ge.1.and.jj.le.m1grid)then
2512                 jjj=jdropgrid(ii,jj,k)
2513                 if(jjj.gt.0)then
2514                   jdropgrid(i,j,k)=jjj
2515                   goto 83
2516                 endif
2517               endif
2518             enddo
2519           enddo
2520 c if no adjacent cluster, create a new one
2521           jclu(k)=jclu(k)+1
2522           jdropgrid(i,j,k)=jclu(k)
2523         endif
2524   83  continue
2525       endif
2526 
2527       if(ish.ge.8)then
2528         write(ifch,*)'segment positions'
2529         do k=1,m3grid
2530         write(ifch,*)'k=',k,'  jclu=',jclu(k)
2531      &              ,'  s=',(k-1)*delsgr-sgrid-shifts
2532          do j=m1grid,1,-1
2533         write(ifch,'(10i4,3x,10i4)')(idropgrid(i,j,k),i=1,m1grid)
2534      &                ,(jdropgrid(i,j,k),i=1,m1grid)
2535         enddo
2536         enddo
2537       endif
2538 
2539 c...absolute clusters numbering (for all k)
2540 
2541       if(ish.ge.6)write(ifch,*)'absolute clusters numbering'
2542       if(iLHC.eq.-1)then    !fuse touching clusters along k  (not used)
2543 c        midbin=m3grid/2
2544 c        if(rangen().gt.0.5)midbin=midbin+1
2545         jjj=1000
2546         k=1
2547         jclu(k)=0
2548         do j=1,m1grid
2549           do i=1,m1grid
2550             if(jdropgrid(i,j,k).gt.0)then
2551               jclu(k)=jclu(k)+1
2552               jjj=jjj+1
2553               ncluj(jjj)=0
2554               kmean(1,jjj)=k
2555               kmean(2,jjj)=k
2556               jjx=jdropgrid(i,j,k)
2557               do jj=j,m1grid
2558                 do ii=i,m1grid
2559                   if(jdropgrid(ii,jj,k).eq.jjx)then
2560                     jdropgrid(ii,jj,k)=jjj
2561                     ncluj(jjj)=ncluj(jjj)+idropgrid(ii,jj,k)
2562                   endif
2563                 enddo
2564               enddo
2565             endif
2566           enddo
2567         enddo
2568         do k=2,m3grid
2569           do j=1,m1grid
2570             do i=1,m1grid
2571               lnew(i,j)=.true.
2572               lold(i,j)=.true.
2573             enddo
2574           enddo
2575           jclu(k)=0
2576           do j=1,m1grid
2577             do i=1,m1grid
2578               if(lnew(i,j).and.jdropgrid(i,j,k).gt.0)then
2579                 lcont=.false.
2580                 if(jdropgrid(i,j,k-1).gt.0)then
2581                   jj0=jdropgrid(i,j,k-1)
2582                   nlim=0
2583                   if(jj0.gt.1000)nlim=ncluj(jj0)
2584                   if(nlim.lt.nsegsuj)then
2585                     jclu(k)=jclu(k)+1
2586                     jjx=jdropgrid(i,j,k)
2587                     if(jjx.gt.jj0)then
2588                       do jj=jjx,jjj
2589                         ncluj(jj)=ncluj(jj+1)
2590                         kmean(1,jj)=kmean(1,jj+1)
2591                         kmean(2,jj)=kmean(2,jj+1)
2592                       enddo
2593                       jjj=jjj-1
2594                       jclu(k)=jclu(k)-1
2595                     endif
2596                     kmean(2,jj0)=k
2597                     do jj=1,m1grid
2598                       do ii=1,m1grid
2599                         if(lnew(ii,jj))then
2600                           if(jdropgrid(ii,jj,k).eq.jjx)then
2601                             jdropgrid(ii,jj,k)=jj0
2602                             ncluj(jj0)=ncluj(jj0)+idropgrid(ii,jj,k)
2603                             lnew(ii,jj)=.false.
2604                    elseif(jdropgrid(ii,jj,k).gt.jjx.and.jjx.gt.jj0)then
2605                             jdropgrid(ii,jj,k)=jdropgrid(ii,jj,k)-1
2606                           endif
2607                         endif
2608                       enddo
2609                     enddo
2610                   else
2611                     lcont=.true.
2612                   endif
2613                 else
2614                   lcont=.true.
2615                 endif
2616                 if(lcont.and.lold(i,j))then
2617                   jclu(k)=jclu(k)+1
2618                   jjj=jjj+1
2619                   ncluj(jjj)=0
2620                   kmean(1,jjj)=k
2621                   kmean(2,jjj)=k
2622                   jjx=jdropgrid(i,j,k)
2623                   do jj=j,m1grid
2624                     do ii=i,m1grid
2625                       if(jdropgrid(ii,jj,k).eq.jjx)then
2626                         jdropgrid(ii,jj,k)=jjj
2627                         ncluj(jjj)=ncluj(jjj)+idropgrid(ii,jj,k)
2628                         lold(ii,jj)=.false.
2629                       endif
2630                     enddo
2631                   enddo
2632                 endif
2633               endif
2634             enddo
2635           enddo
2636         enddo
2637         jjs=0
2638         do jj=1001,jjj
2639           jjs=jjs+1
2640           kclu(jjs)=(kmean(1,jj)+kmean(2,jj))/2
2641           nseg(jjs)=0
2642           nsegp4(jjs)=0
2643           p4mean(1,jjs)=0d0   
2644           p4mean(2,jjs)=0d0   
2645           p4mean(3,jjs)=0d0   
2646           p4mean(4,jjs)=0d0   
2647           rmean(1,jjs)=0d0      !cluster distance to center
2648           rmean(2,jjs)=0d0      !cluster maximal radius
2649         enddo
2650         do k=1,m3grid
2651           do j=1,m1grid
2652             do i=1,m1grid
2653               if(jdropgrid(i,j,k).gt.0)then
2654                 jdropgrid(i,j,k)=jdropgrid(i,j,k)-1000
2655               endif
2656             enddo
2657           enddo
2658         enddo
2659         jjj=jjj-1000
2660       else
2661         jjj=jclu(1)
2662         do k=2,m3grid
2663           do j=1,m1grid
2664             do i=1,m1grid
2665               if(jdropgrid(i,j,k).gt.0)
2666      &             jdropgrid(i,j,k)=jdropgrid(i,j,k)+jjj
2667             enddo
2668           enddo
2669           jjj=jjj+jclu(k)
2670         enddo
2671         jjs=0
2672         do k=1,m3grid
2673           do jj=1,jclu(k)
2674             jjs=jjs+1
2675             kclu(jjs)=k
2676             nseg(jjs)=0
2677             nsegp4(jjs)=0
2678             p4mean(1,jjs)=0d0   
2679             p4mean(2,jjs)=0d0   
2680             p4mean(3,jjs)=0d0   
2681             p4mean(4,jjs)=0d0   
2682             rmean(1,jjs)=0d0    !cluster distance to center
2683             rmean(2,jjs)=0d0    !cluster maximal radius
2684           enddo
2685         enddo
2686       endif
2687       do 20 i=1,maproj
2688       do 20 j=1,matarg
2689  20   mpair(j,i)=0   
2690 
2691 
2692 c...calculate mean energy of segments going into in clusters
2693 
2694       if(ish.ge.6)write(ifch,*)
2695      &'calculate mean energy of segments going into in clusters'
2696       rmax=0.
2697       do 95 n=1,nptla
2698         if(iaaptl(n).eq.0)goto 95
2699         i=1+(xptl(n)+xgrid+shiftx)/delxgr
2700         j=1+(yptl(n)+xgrid+shiftx)/delxgr
2701         k=1+(sptl(n)+sgrid+shifts)/delsgr
2702         if(    i.ge.1.and.i.le.m1grid
2703      &          .and.j.ge.1.and.j.le.m1grid
2704      &          .and.k.ge.1.and.k.le.m3grid)then
2705           jj=jdropgrid(i,j,k)
2706           if(jj.gt.0)then
2707             nsegp4(jj)=nsegp4(jj)+1
2708             io=iorptl(n)
2709             if(iLHC.eq.1.and.ityptl(n).lt.40.and.io.gt.0)then !look for corresponding pair of nucleons
2710               if(iorptl(io).gt.0)then
2711                 do while(iorptl(iorptl(io)).ge.0)
2712                   io=iorptl(io)
2713                 enddo
2714                 ip=iorptl(io)
2715                 it=jorptl(io)-maproj
2716                 if(ip.gt.0.and.it.gt.0)mpair(it,ip)=mpair(it,ip)+1
2717               endif
2718             endif
2719             do kk=1,4
2720               p4mean(kk,jj)=p4mean(kk,jj)+dble(pptl(kk,n))
2721             enddo
2722             rr=sqrt(xptl(n)**2+yptl(n)**2)
2723             rmean(1,jj)=rmean(1,jj)+rr
2724             rmax=max(rr,rmax)
2725 c           if(jj.eq.9)write(ifch,*)'after',n
2726 c     & ,pptl(4,n),pptl(3,n),idptl(n),jj,nseg(jj),i,j,k
2727           elseif(istptl(n).eq.3)then   !virtual particle is lost (no cluster here)
2728             iaaptl(n) = 0   !don't use this particle next time
2729             istptl(n) = 5
2730             ior=iorptl(n)
2731             ifrptl(1,ior) = 0
2732             ifrptl(2,ior) = 0
2733             do k=1,3         !restore energy to mother particle
2734               pptl(k,ior)=pptl(k,ior)+pptl(k,n)
2735             enddo
2736             pptl(4,ior)=sqrt(pptl(1,ior)**2+pptl(2,ior)**2
2737      &                          +pptl(3,ior)**2+pptl(5,ior)**2)
2738             call idtau(idptl(ior),pptl(4,ior),pptl(5,ior),taugm)
2739             tivptl(2,ior)=tivptl(1,ior)+taugm*(-alog(rangen()))
2740           endif
2741         endif
2742  95   continue
2743 
2744       ectot=0.
2745       amctot=0.
2746       maptot=0
2747       mapmax=0
2748       npair=0
2749       do jj=1,jjj
2750         ectot=ectot+p4mean(4,jj)
2751         amctot=amctot+(p4mean(4,jj)+p4mean(3,jj))
2752      &     *(p4mean(4,jj)-p4mean(3,jj))-p4mean(1,jj)**2-p4mean(2,jj)**2
2753 
2754         if(nsegp4(jj).ge.nsegce/iflhc)then
2755           p4mean(4,jj)=p4mean(4,jj)/dble(nsegp4(jj))
2756           rmean(1,jj)=rmean(1,jj)/dble(nsegp4(jj))
2757         else
2758           p4mean(4,jj)=1d50
2759           rmean(1,jj)=-1d0
2760         endif
2761       enddo
2762       yco=0.
2763       ycor=1.
2764       if(iLHC.eq.1.and.amctot.gt.0.)then
2765         do ip=1,maproj
2766           do it=1,matarg
2767             if(mpair(it,ip).gt.0)npair=npair+1
2768             mapmax=max(mapmax,mpair(it,ip))
2769             maptot=maptot+mpair(it,ip)
2770           enddo
2771         enddo
2772         amctot=sqrt(amctot)
2773         if(amctot.gt.amuseg**2)then
2774           visco=1.
2775           yrmaxi=yradmx
2776 c          if(fvisco.gt.0)yrmaxi=yrmaxi*(1.-visco)
2777           yrmaxi=yrmaxi*log(exp(yradpi)+amctot**2)
2778 c          yrmaxi=yrmaxi*amctot**yradpi
2779           if(yrmaxi.gt.1e-2)then
2780             yyrmax=dble(yrmaxi)
2781             fradflii=sngl(1d0/
2782      &         ((sinh(yyrmax)*yyrmax-cosh(yyrmax)+1d0)/(yyrmax**2/2d0)))
2783           else
2784             yrmaxi=0.
2785             fradflii=1.
2786           endif
2787         else
2788           amctot=1.
2789           visco=0.
2790           fradflii=1.
2791           yrmaxi=ainfin         !to define ityptl as 19 if mass is too low (aumin=amuseg+yrmaxi in epos-hnb.f)
2792         endif
2793         if(ylongmx.lt.0.)then
2794           delzet=abs(ylongmx)*log(exp(yradmi)+amctot**2)
2795 c          delzet=abs(ylongmx)*log(exp(yradmi)+amctot)
2796 c          delzet=abs(ylongmx)*amctot**yradmi
2797           yco=delzet            !* 1.75
2798         else
2799           yco=ylongmx
2800         endif
2801         ycor=yco
2802         if(fvisco.gt.0.)ycor=0.
2803         if(ycor.gt.1.e-2)then
2804           ycor=sqrt(sinh(ycor)/ycor)/fradflii
2805         else
2806           ycor=1.
2807         endif
2808       else
2809         if(ylongmx.lt.0)delzet=1.75*delzet
2810       endif
2811 
2812 c...mark segments going into in clusters, count them
2813 
2814       if(ish.ge.6)write(ifch,*)'mark segments going into in clusters'
2815       do 96 n=1,nptla
2816         if(iaaptl(n).eq.0)goto 96
2817         i=1+(xptl(n)+xgrid+shiftx)/delxgr
2818         j=1+(yptl(n)+xgrid+shiftx)/delxgr
2819         k=1+(sptl(n)+sgrid+shifts)/delsgr
2820         if(    i.ge.1.and.i.le.m1grid
2821      &          .and.j.ge.1.and.j.le.m1grid
2822      &          .and.k.ge.1.and.k.le.m3grid)then
2823           jj=jdropgrid(i,j,k)
2824           if(jj.gt.0)then
2825           ! count only particles with reasonnable energy
2826             pt2=pptl(1,n)**2+pptl(2,n)**2+pptl(5,n)**2
2827             am2tmp=(pptl(4,n)+pptl(3,n))*(pptl(4,n)-pptl(3,n))-pt2
2828             if(abs(am2tmp).lt.0.1.or.
2829      &         dble(pptl(4,n)).le.100.d0/dble(ntry)*p4mean(4,jj))then
2830               istptl(n) = 3
2831               nseg(jj)=nseg(jj)+1
2832               if(rmean(1,jj).gt.0d0)then
2833                 rmean(2,jj)=max(rmean(2,jj)
2834      &                   ,abs(rmean(1,jj)-sqrt(xptl(n)**2+yptl(n)**2)))
2835 c      print *,'r',jj,rmean(1,jj),sqrt(xptl(n)**2+yptl(n)**2),rmean(2,jj)
2836               endif
2837 c           if(jj.eq.9)write(ifch,*)'after',n
2838 c     & ,pptl(4,n),pptl(3,n),idptl(n),jj,nseg(jj),i,j,k
2839             else
2840 c              write(ifmt,*)'Rejected particle : ',n,idptl(n)
2841              if(ish.ge.1)write(ifch,*)'Rejected particle : ',n,idptl(n)
2842      & ,ityptl(n),(pptl(kk,n),kk=1,5),am2tmp
2843      & ,dble(pptl(4,n))/dble(nsegp4(jj)),p4mean(4,jj),nsegp4(jj),jj
2844               nsegp4(jj)=nsegp4(jj)-1
2845               iaaptl(n)=0
2846 c        if(iaaptl(n).eq.0)print*,'rejected',idptl(n),ityptl(n)
2847 c     &                                         ,pptl(4,n)
2848               if(nsegp4(jj).ge.nsegce/iflhc)then
2849                 p4mean(4,jj)=(p4mean(4,jj)*dble(nsegp4(jj)+1)-pptl(4,n))
2850      &               /dble(nsegp4(jj))
2851               else
2852                 p4mean(4,jj)=1d50
2853               endif
2854             endif
2855          endif
2856         endif
2857   96  continue
2858 
2859 
2860 c...add segments moving towards clusters
2861 
2862       if(ish.ge.6)write(ifch,*)'add segments moving towards clusters'
2863       if(iocluin.eq.1)then
2864       do 93 n=1,nptla
2865         if(iaaptl(n).eq.0)goto 93
2866         ihit=0
2867         i=1+(xptl(n)+xgrid+shiftx)/delxgr
2868         j=1+(yptl(n)+xgrid+shiftx)/delxgr
2869         k=1+(sptl(n)+sgrid+shifts)/delsgr
2870         if(    i.ge.1.and.i.le.m1grid
2871      &          .and.j.ge.1.and.j.le.m1grid
2872      &          .and.k.ge.1.and.k.le.m3grid)then
2873           jgr=jdropgrid(i,j,k)
2874           if(jgr.eq.0)then
2875            if(i.ge.m1grid/2)then
2876             isi=-1
2877            else
2878             isi=1
2879            endif
2880            if(j.ge.m1grid/2)then
2881             jsi=-1
2882            else
2883             jsi=1
2884            endif
2885             do ii=i,i+2*isi,isi
2886              do jj=j,j+2*jsi,jsi
2887                if(.not.(ii.eq.i.and.jj.eq.j))then
2888                 if(ii.ge.1.and.ii.le.m1grid
2889      .          .and.jj.ge.1.and.jj.le.m1grid)then
2890                  jg=jdropgrid(ii,jj,k)
2891                  if(jg.gt.0)then
2892 c                  if(nseg(jg).gt.50)then
2893                    x=xptl(n)
2894                    y=yptl(n)
2895                    vrad=( x*pptl(1,n)/pptl(4,n)+y*pptl(2,n)/pptl(4,n))
2896                     if(vrad.lt.0.)then
2897                      ihit=1
2898                      goto 94
2899                     endif
2900 c                  endif
2901                  endif
2902                 endif
2903                endif
2904              enddo
2905             enddo
2906           endif
2907         endif
2908    94   continue
2909         if(ihit.eq.1)then
2910          delx=delxgr*(ii-i)
2911          dely=delxgr*(jj-j)
2912          xn=xptl(n)+delx
2913          yn=yptl(n)+dely
2914          ix=1+(xn+xgrid+shiftx)/delxgr
2915          jx=1+(yn+xgrid+shiftx)/delxgr
2916          jgrx=jdropgrid(ix,jx,k)
2917          if(jgrx.gt.0)then
2918           xptl(n)=xn
2919           yptl(n)=yn
2920           istptl(n) = 3
2921           nseg(jgrx)=nseg(jgrx)+1
2922           if(rmean(1,jg).gt.0d0)
2923      &         rmean(2,jgrx)=max(rmean(2,jgrx)
2924      &         ,abs(rmean(1,jgrx)-sqrt(xptl(n)**2+yptl(n)**2)))
2925          endif
2926         endif
2927   93  continue
2928       endif
2929 
2930 
2931 c Decay Strings not included in clusters taking into account Z
2932 c do it here to have this particles before the one from cluster 
2933 c (to define maxfra properly)
2934       if(ish.ge.6)write(ifch,*)'decay Strings not included in clusters'
2935       if(ifrade.ne.0.and.ntry.eq.1.and..not.lclean)then
2936         nptlx=nptl+1
2937 c copy decayed strings into new strings if no fragments are used for cluster
2938         do n=1,nptl
2939           if(istptl(n).eq.29.and.ityptl(n).lt.40)then   !fragmented central strings
2940             iused=0
2941             do nn=ifrptl(1,n),ifrptl(2,n)
2942               if(istptl(nn).eq.3.or.ifrptl(1,nn).ne.0)iused=iused+1
2943             enddo
2944             if(iused.eq.0)then   !if no fragment used, reset string
2945               istptl(n)=28
2946               do nn=ifrptl(1,n),ifrptl(2,n)     !suppress product
2947                 istptl(nn)=4
2948                 iaaptl(nn)=0
2949               enddo
2950               do nn=iorptl(n),jorptl(n)         !reinitialize string ends
2951                 istptl(nn)=20
2952               enddo              
2953             endif
2954           endif
2955         enddo
2956         call gakfra(0,iret)      !fragmentation using Z
2957         if(iret.gt.0)goto 1000
2958         do nn=nptlx,nptl  !exclude new particle from cluster formation
2959           iaaptl(nn)=0
2960           call jtain(nn,xptl(nn),yptl(nn),zptl(nn),tptl(nn),nnn,0)
2961           call jtaus(zptl(nn),tz,sptl(nn))
2962           strap=1e10
2963           xpl=tptl(nn)+zptl(nn)
2964           xmi=tptl(nn)-zptl(nn)
2965           if(xmi.gt.0.0.and.xpl.gt.0.0)strap=0.5*log(xpl/xmi)
2966           dezptl(nn)=strap       !space-time-rapidity
2967         enddo
2968         maxfra=nptl
2969         nptla=nptl
2970         if(ish.ge.6.and.nptl.ne.nptlx-1)
2971      &      call alist('list after second fragmentation&',nptlx,nptl)
2972         if(irescl.eq.1)then
2973           call utghost(iret)
2974           if(iret.gt.0)goto 1000
2975         endif
2976       endif
2977 
2978 
2979 c      if(iLHC.eq.1)then
2980 cc...split high pt segment into one part going out of the cluster and one part included in cluster (number of particle in cluster conserved)
2981 c        if(ish.ge.6)
2982 c     &  write(ifch,*)'mark high pt segments going into in clusters'
2983 c        do 100 n=1,nptla
2984 c          if(iaaptl(n).ge.0)goto 100
2985 c          i=1+(xptl(n)+xgrid+shiftx)/delxgr
2986 c          j=1+(yptl(n)+xgrid+shiftx)/delxgr
2987 c          k=1+(sptl(n)+sgrid+shifts)/delsgr
2988 c          if(    i.ge.1.and.i.le.m1grid
2989 c     &          .and.j.ge.1.and.j.le.m1grid
2990 c     &          .and.k.ge.1.and.k.le.m3grid)then
2991 c            jj=jdropgrid(i,j,k)
2992 c            if(jj.gt.0)then
2993 c              if(rmean(1,jj).gt.0d0)then
2994 c          ! path through cluster
2995 c                rp=sngl(rmean(2,jj)
2996 c     &               -abs(sqrt(xptl(n)**2+yptl(n)**2)-rmean(1,jj)))
2997 c          ! energy density (cluster mass approximate as sqrt(E))
2998 c                rh=sngl(sqrt(p4mean(4,jj)*nsegp4(jj))
2999 c     &               /(4d0/3d0*pi*rmean(2,jj)**3))
3000 c          ! Et used as Energy (transverse energy)
3001 c                pt2=pptl(1,n)**2+pptl(2,n)**2
3002 cc                ept=sqrt(pt2+pptl(3,n)**2)
3003 c                ept=sqrt(pt2+pptl(5,n)**2)
3004 c          ! energy loss based on BDMPS (peigne et al.)
3005 c                eloss=fploss*rh**(3./8.)*max(1.,sqrt(ept))*rp
3006 c          ! scaling factor
3007 c                fscal=eloss/ept
3008 cc                print *,ept,eloss,nsegp4(jj),rmean(2,jj),rh,rp,fscal
3009 c                
3010 c                if(fscal.le.0.)then   !exclude fragment from cluster
3011 c                  nseg(jj)=nseg(jj)-1
3012 c                  istptl(n)=0
3013 c                  iaaptl(n)=0
3014 c          ! update cluster mean energy
3015 c                  nsegp4(jj)=nsegp4(jj)-1
3016 c                  if(nsegp4(jj).ge.nsegce/iflhc)then
3017 c                    p4mean(4,jj)=(p4mean(4,jj)*dble(nsegp4(jj)+1)
3018 c     &                         -pptl(4,n))/dble(nsegp4(jj))
3019 c                  else
3020 c                    p4mean(4,jj)=1d50
3021 c                    rmean(1,jj)=-1d0
3022 c                  endif
3023 c                elseif(fscal.lt.1..and.(1.-fscal)**2*pt2.gt.
3024 c     &    (0.5-log(rangen()))**2*(ptclu**2))then
3025 cc     &    (0.5-log(rangen()))**2*(pptl(5,n)**2+ptclu**2))then
3026 cc                  print *,ept,eloss,nsegp4(jj),rmean(2,jj),rh,rp,fscal
3027 c                  if(ish.ge.6)write(ifch,*)'Quenched particle : ',n
3028 c     & ,idptl(n),ityptl(n),(pptl(kk,n),kk=1,5),ept,eloss,nsegp4(jj),jj
3029 c                  iaaptl(n)=0   !mother particle leave cluster
3030 c                  istptl(n)=0
3031 c                  nptl=nptl+1   !create fake particle with energy lost in cluster
3032 c                  nptla=nptla+1
3033 c                  istptl(nptl)=3 !daughter part of cluster
3034 c                  iaaptl(nptl)=1
3035 c                  do l=1,3
3036 c                    pptl(l,nptl)=fscal*pptl(l,n)
3037 c                    pptl(l,n)=(1.-fscal)*pptl(l,n)
3038 c                    xorptl(l,nptl)=xorptl(l,n)
3039 c                  enddo
3040 c! mother
3041 c                  tivptl(1,n)=xorptl(4,n)
3042 c                  pptl(4,n)=sqrt(pptl(1,n)**2+pptl(2,n)**2
3043 c     &                        +pptl(3,n)**2+pptl(5,n)**2)
3044 c                  call idtau(idptl(n),pptl(4,n),pptl(5,n),taugm)
3045 c                  tivptl(2,n)=tivptl(1,n)+taugm*(-alog(rangen()))
3046 c          ! daughter
3047 c                  pptl(5,nptl)=0.
3048 c                  pptl(4,nptl)=sqrt(pptl(1,nptl)**2+pptl(2,nptl)**2
3049 c     &                           +pptl(3,nptl)**2+pptl(5,nptl)**2)
3050 c                  xorptl(4,nptl)=xorptl(4,n)
3051 c                  tivptl(1,nptl)=tivptl(1,n)
3052 c                  iorptl(nptl)=n
3053 c                  idptl(nptl)=idptl(n)*100+sign(99,idptl(n))
3054 c                  call idquac(nptl,idum1,idum2,idum3,jc)
3055 c                  ityptl(nptl)=ityptl(n)+2
3056 c                  xptl(nptl)=xptl(n)
3057 c                  yptl(nptl)=yptl(n)
3058 c                  zptl(nptl)=zptl(n)
3059 c                  sptl(nptl)=sptl(n)
3060 c                  dezptl(nptl)=dezptl(n)
3061 c                if(ish.ge.6)write(ifch,*)'--> Virtual particle : ',nptl
3062 c     & ,idptl(nptl),ityptl(nptl),(pptl(kk,nptl),kk=1,5)
3063 c          ! update cluster mean energy
3064 c                  p4mean(4,jj)=(p4mean(4,jj)*dble(nsegp4(jj))
3065 c     &                         -pptl(4,n)+pptl(4,nptl))/dble(nsegp4(jj))
3066 c                else
3067 c                  istptl(n)=3
3068 c                  iaaptl(n)=1
3069 c                  if(ish.ge.6)write(ifch,*)'Absorbed particle : ',n
3070 c     & ,idptl(n),ityptl(n),(pptl(kk,n),kk=1,5),ept,eloss,nsegp4(jj),jj
3071 c                endif
3072 c              endif
3073 c            endif
3074 c          endif
3075 c 100    continue
3076 c
3077 c
3078 c
3079 c      endif
3080 c
3081 
3082 c      nptlb0=nptl
3083 
3084       nptlb=nptl+jjj
3085 c...prepare /cptl/ for clusters
3086 
3087       if(ish.ge.6)write(ifch,*)'prepare /cptl/ for clusters'
3088       do jj=1,jjj
3089          nptl=nptl+1
3090           istptl(nptl)=12
3091           do l=1,4
3092             pptl(l,nptl)=0.
3093             xorptl(l,nptl)=0
3094           enddo
3095           sptl(nptl)=0
3096           uptl(nptl)=0
3097           optl(nptl)=0
3098           desptl(nptl)=0
3099           iorptl(nptl)=0
3100           jorptl(nptl)=0
3101 c limit the maximum number of subcluster to half the number of particle
3102 c (not to have empty subclusters)
3103           nsegmx(jj)=max(1,nint(float(nseg(jj))/float(nsegsuj)))
3104           if(ish.ge.6)write(ifch,*)'nsegmx',jj,nseg(jj),nsegmx(jj)
3105      &                                                 ,nsegsuj
3106       enddo
3107 
3108 c...prepare /cptl/ for subclusters
3109 
3110       if(ish.ge.6)write(ifch,*)'prepare /cptl/ for subclusters'
3111       mm=0
3112       do jj=1,jjj
3113         do ii=1,nsegmx(jj)
3114           mm=mm+1
3115           if(mm.gt.mxcl)stop'jintpo: mxcl too small.        '
3116           mmji(jj,ii)=mm
3117           mseg(mm)=0
3118           nptl=nptl+1
3119           istptl(nptl)=10
3120           do l=1,4
3121             pptld(l,mm)=0d0
3122             pptl(l,nptl)=0.
3123             xorptl(l,nptl)=0
3124           enddo
3125           sptl(nptl)=0
3126           uptl(nptl)=0
3127           optl(nptl)=0
3128           desptl(nptl)=0
3129           do l=1,nflav
3130             jccl(mm,l,1)=0
3131             jccl(mm,l,2)=0
3132           enddo
3133           iorptl(nptl)=nptla+jj
3134           jorptl(nptl)=0
3135           if(ii.eq.1)ifrptl(1,nptla+jj)=nptlb+mm
3136           ifrptl(2,nptla+jj)=nptlb+mm
3137         enddo
3138       enddo
3139 
3140 c...separate string segments, add dense area segments to clusters
3141 
3142       if(ish.ge.6)write(ifch,*)'separate string segments'
3143       do 98 n=1,nptla
3144         if(istptl(n).ne.3)goto 98
3145         i=1+(xptl(n)+xgrid+shiftx)/delxgr
3146         j=1+(yptl(n)+xgrid+shiftx)/delxgr
3147         k=1+(sptl(n)+sgrid+shifts)/delsgr
3148         if(    i.ge.1.and.i.le.m1grid
3149      &          .and.j.ge.1.and.j.le.m1grid
3150      &          .and.k.ge.1.and.k.le.m3grid)then
3151           jj=jdropgrid(i,j,k)
3152           if(jj.gt.0)then
3153             iimx=nsegmx(jj)
3154             do ii=1,iimx
3155               mm=mmji(jj,ii)
3156               if(mseg(mm).eq.0)goto 10          !not to have an empty cluster
3157             enddo
3158             ii=1+rangen()*iimx
3159             ii=min(ii,iimx)
3160             iini=ii
3161             am2tmpmx=1e30
3162  9          ntmp=mmji(jj,ii)
3163             am2tmp=(pptld(4,ntmp)+pptld(3,ntmp))
3164      &            *(pptld(4,ntmp)-pptld(3,ntmp))
3165             if(am2tmp.gt.xmxms**2/2.)then
3166               if(am2tmp.lt.am2tmpmx)then
3167                 mm=mmji(jj,ii)
3168                 am2tmpmx=am2tmp
3169               endif
3170               ii=ii+1
3171               if(ii.gt.iimx)ii=1
3172               if(ii.ne.iini)then
3173                 goto 9
3174               else
3175                 goto 10
3176               endif
3177             endif
3178             mm=mmji(jj,ii)
3179  10         continue
3180             mseg(mm)=mseg(mm)+1
3181             ifrptl(1,n)=mm      !local use of ifrptl
3182 c           write(ifch,*)'end',n
3183 c     & ,pptl(4,n),pptl(3,n),idptl(n),i,j,k,sptl(n),mm
3184             p4tmp=0d0
3185             do l=1,3
3186              pptld(l,mm)=  pptld(l,mm)  + dble(pptl(l,n))
3187              p4tmp=p4tmp+dble(pptl(l,n))*dble(pptl(l,n))
3188             enddo
3189             p4tmp=sqrt(p4tmp+dble(pptl(5,n)*pptl(5,n)))
3190             pptld(4,mm)=  pptld(4,mm)  + p4tmp
3191 c           if(mm.eq.86)write(ifch,*)'other',n
3192 c     & ,pptl(4,n),pptl(3,n),pptl(5,n),idptl(n),k,p4tmp
3193 c     & ,pptld(4,mm),pptld(3,mm),pptld(2,mm),pptld(1,mm)
3194 c     & ,(pptld(4,mm)+pptld(3,mm))*(pptld(4,mm)-pptld(3,mm))
3195             xorptl(1,nptlb+mm)=xorptl(1,nptlb+mm)+xptl(n)
3196             xorptl(2,nptlb+mm)=xorptl(2,nptlb+mm)+yptl(n)
3197             xorptl(3,nptlb+mm)=xorptl(3,nptlb+mm)+zptl(n)
3198             xorptl(4,nptlb+mm)=xorptl(4,nptlb+mm)+tptl(n)
3199             sptl(nptlb+mm)=sptl(nptlb+mm)+sptl(n)
3200             aa=cos(phievt)
3201             bb=sin(phievt)
3202             cc=-sin(phievt)
3203             dd=cos(phievt)
3204             xrot=xptl(n)*aa+yptl(n)*bb
3205             yrot=xptl(n)*cc+yptl(n)*dd
3206             uptl(nptlb+mm)=uptl(nptlb+mm)+xrot**2
3207             optl(nptlb+mm)=optl(nptlb+mm)+yrot**2
3208             desptl(nptlb+mm)=desptl(nptlb+mm)+xrot*yrot
3209             call idquac(n,idum1,idum2,idum3,jc)
3210 c            id=idptl(n)
3211 c            ida=iabs(id/10)
3212 c            ids=id/iabs(id)
3213 c            if(ida.ne.111.and.ida.ne.222.and.ida.ne.333)id=id/10*10
3214 c            if(ida.eq.111.or. ida.eq.222.or. ida.eq.333)id=id/10*10+ids
3215 c            if(ida.eq.213)id=1230*ids
3216 c            ic(1)=idtrai(1,id,1)
3217 c            ic(2)=idtrai(2,id,1)
3218 c            call iddeco(ic,jc)
3219             do l=1,nflav
3220               jccl(mm,l,1)=jccl(mm,l,1)+jc(l,1)
3221               jccl(mm,l,2)=jccl(mm,l,2)+jc(l,2)
3222             enddo
3223           else
3224             idropgrid(i,j,k)=0
3225           endif
3226         endif
3227   98  continue
3228 
3229 c...associate segments to clusters
3230 
3231       if(ish.ge.6)write(ifch,*)'associate segments to clusters'
3232       naseg(0)=0
3233       do jj=1,jjj
3234         do ii=1,nsegmx(jj)
3235           mm=mmji(jj,ii)
3236           naseg(mm)=naseg(mm-1)+mseg(mm)
3237           nfseg(mm)=0
3238         enddo
3239       enddo
3240       do 97 n=1,nptla
3241         if(istptl(n).ne.3)goto 97
3242         istptl(n) = 2
3243 c        write(ifch,*)'final segments ',n
3244 c     &          ,ityptl(n),istptl(n),idptl(n),dezptl(n),pptl(3,n)
3245         mm=ifrptl(1,n)
3246         nfseg(mm)=nfseg(mm)+1
3247         nsegmt(naseg(mm-1)+nfseg(mm))=n
3248  97   continue
3249       do jj=1,jjj
3250         nst=0
3251         do ii=1,nsegmx(jj)
3252           mm=mmji(jj,ii)
3253           if(mseg(mm).ne.nfseg(mm))stop'jintpo: mseg.ne.nfseg        '
3254           nst=nst+mseg(mm)
3255         enddo
3256         if(nst.ne.nseg(jj))stop'sum(mseg(mm)).ne.nseg(jj)'
3257       enddo
3258 
3259 c...finish cluster storage to /cptl/
3260 
3261       if(ish.ge.6)write(ifch,*)'finish cluster storage to /cptl/'
3262       xx=0.
3263       yy=0.
3264       xy=0.
3265       mjjsegsum=0
3266       do jj=1,jjj
3267        njj=nptla+jj
3268        mjjseg=0
3269        do l=1,nflav
3270          jcjj(l,1)=0
3271          jcjj(l,2)=0
3272        enddo
3273        do ii=1,nsegmx(jj)
3274         mm=mmji(jj,ii)
3275         n=nptlb+mm
3276 
3277         do l=1,nflav
3278           jc(l,1)=jccl(mm,l,1)
3279           jc(l,2)=jccl(mm,l,2)
3280           ke(l)=jc(l,1)-jc(l,2)
3281           jcjj(l,1)=jcjj(l,1)+jc(l,1)
3282           jcjj(l,2)=jcjj(l,2)+jc(l,2)
3283         enddo
3284         call idenct(jc,idptl(n)
3285      *  ,ibptl(1,n),ibptl(2,n),ibptl(3,n),ibptl(4,n))
3286         ttest=0d0
3287         do ji=1,4
3288          ptest(ji)=0d0
3289           do ns=naseg(mm-1)+1,naseg(mm)
3290             ni=nsegmt(ns)
3291             ptest(ji)=ptest(ji)+dble(pptl(ji,ni))
3292           enddo
3293          ptest(ji)=abs(ptest(ji)-pptld(ji,mm))
3294          ttest=ttest+ptest(ji)
3295         enddo
3296         amcmin=1.01*utamnu(ke(1),ke(2),ke(3),ke(4),ke(5),ke(6),4)
3297         p52=((pptld(4,mm)+pptld(3,mm))*(pptld(4,mm)-pptld(3,mm))
3298      &      -pptld(1,mm)**2-pptld(2,mm)**2)
3299         if(iLHC.eq.1)then
3300           amcmin=sqrt(max(amcmin**2,sngl(p52)))
3301           if(amcmin/ycor.gt.amuseg)amcmin=amcmin*ycor
3302 c     &                    **max(0.,min(1.,pptld(4,mm)-2.*amcmin*ycor))
3303         endif
3304           
3305         pptld(5,mm)=0d0
3306         if(p52.gt.0d0)then
3307          pptld(5,mm)=sqrt(p52)
3308          jerr(2)=jerr(2)+1
3309          if(iLHC.eq.1.and.pptld(5,mm).lt.amcmin
3310      &               .and.pptld(4,mm).gt.amcmin)then
3311            pptld(5,mm)=dble(amcmin)
3312            bp=sqrt((pptld(4,mm)+pptld(5,mm))*(pptld(4,mm)-pptld(5,mm))
3313      &            /(pptld(3,mm)*pptld(3,mm)+pptld(2,mm)*pptld(2,mm)
3314      &                                      +pptld(1,mm)*pptld(1,mm)))
3315            pptld(1,mm)=bp*pptld(1,mm)
3316            pptld(2,mm)=bp*pptld(2,mm)
3317            pptld(3,mm)=bp*pptld(3,mm)
3318 c           write(ifch,*)"ici ",n,sqrt(p52),pptld(5,mm),bp,pptld(4,mm),
3319 c     &  sqrt(pptld(3,mm)*pptld(3,mm)
3320 c     &                   +pptld(2,mm)*pptld(2,mm)
3321 c     &                   +pptld(1,mm)*pptld(1,mm)
3322 c     &                   +pptld(5,mm)*pptld(5,mm))
3323 c      write(ifch,*)'droplet uds=',ke(1),ke(2),ke(3),'   E=',pptld(5,mm)
3324          endif
3325         elseif(p52.le.0d0)then
3326          jerr(3)=jerr(3)+1
3327          pptld(5,mm)=dble(amcmin)
3328          pptld(4,mm)=sqrt(pptld(3,mm)*pptld(3,mm)
3329      &                   +pptld(2,mm)*pptld(2,mm)
3330      &                   +pptld(1,mm)*pptld(1,mm)
3331      &                   +pptld(5,mm)*pptld(5,mm))
3332         endif
3333         if(ish.ge.1.and.(abs(ttest).gt.1.d0.or.pptld(5,mm).gt.xmxms))
3334      &    then
3335           call utmsg('jintpo&')
3336           write(ifmt,*)'***** Warning in jintpo !',ntry
3337           write(ifch,*)'***** jintpo: momenta messed up (ttest > 0)'
3338           write(ifch,*)'*****',mm,n,mseg(mm),p52,ttest
3339           write(ifch,*)'*****',jj,nsegp4(jj),p4mean(4,jj)
3340           write(ifch,'(a,10x,4f15.4)')'*****',(pptld(ji,mm),ji=1,4)
3341           do ns=naseg(mm-1)+1,naseg(mm)
3342             ni=nsegmt(ns)
3343             write(ifch,'(a,i5,i9,5f15.4,f12.4)')'*****',ni,idptl(ni)
3344      *     ,(pptl(ji,ni),ji=1,4),pptl(5,ni)**2
3345      *     ,(pptl(4,ni)+pptl(3,ni))*(pptl(4,ni)-pptl(3,ni))
3346      *       -pptl(1,ni)**2-pptl(2,ni)**2
3347           enddo
3348         endif
3349         if(pptld(5,mm).gt.xmxms)then
3350           p4max=0.
3351           nh=0
3352           do ns=naseg(mm-1)+1,naseg(mm)
3353             ni=nsegmt(ns)
3354             if(pptl(4,ni).ge.p4max)then
3355               nh=ni
3356               p4max=pptl(4,ni)
3357             endif
3358           enddo
3359           if(nh.le.0)then
3360             stop'Cannot be in jintpo ...'
3361           else   !put back nh as normal particle
3362             iaaptl(nh) = 0      !don't use this fragment next time
3363 c        if(iaaptl(nh).eq.0)print*,'excluded',idptl(nh),ityptl(nh)
3364 c     &                                         ,pptl(4,nh)
3365             if(mod(abs(idptl(nh)),100).eq.99)then !restore lost energy
3366               istptl(nh) = 5
3367               ior=iorptl(nh)
3368               iaaptl(ior)=0      !don't use this fragment next time
3369               ifrptl(1,ior) = 0
3370               ifrptl(2,ior) = 0
3371               if(istptl(ior).eq.0)then                   
3372                 do k=1,3
3373                   pptl(k,ior)=pptl(k,ior)+pptl(k,n)
3374                 enddo
3375                 pptl(4,ior)=sqrt(pptl(1,ior)**2+pptl(2,ior)**2
3376      &                          +pptl(3,ior)**2+pptl(5,ior)**2)
3377                 call idtau(idptl(ior),pptl(4,ior),pptl(5,ior),taugm)
3378                 tivptl(2,ior)=tivptl(1,ior)+taugm*(-alog(rangen()))
3379               else
3380                 istptl(ior) = 0
3381               endif
3382             elseif(idptl(nh).lt.1e4)then
3383               istptl(nh) = 0     !particle
3384               ifrptl(1,nh) = 0
3385               ifrptl(2,nh) = 0
3386             else
3387               istptl(nh) = 10    !droplet
3388             endif
3389           endif
3390           if(ish.ge.1)
3391      &    write(ifch,*)'***** Redo cluster without heavy particle :'
3392      &                 ,nh,ntry
3393           goto 8888
3394         endif
3395         do l=1,5
3396          pptl(l,n)=sngl(pptld(l,mm))
3397         enddo
3398         mjjseg=mjjseg+mseg(mm)
3399         do l=1,4
3400           pptl(l,njj)=pptl(l,njj)+pptl(l,n)
3401           xorptl(l,njj)=xorptl(l,njj)+xorptl(l,n)
3402           xorptl(l,n)=xorptl(l,n)/float(mseg(mm))
3403         enddo
3404         sptl(njj)=sptl(njj)+sptl(n)
3405         uptl(njj)=uptl(njj)+uptl(n)
3406         optl(njj)=optl(njj)+optl(n)
3407         desptl(njj)=desptl(njj)+desptl(n)
3408         sptl(n)=sptl(n)/float(mseg(mm))
3409         uptl(n)=uptl(n)/float(mseg(mm))
3410         optl(n)=optl(n)/float(mseg(mm))
3411         desptl(n)=desptl(n)/float(mseg(mm))
3412         radptl(n)=0
3413         istptl(n)=10
3414         ifrptl(1,n)=0
3415         ifrptl(2,n)=0
3416         tivptl(1,n)=xorptl(4,n)
3417         tivptl(2,n)=ainfin
3418         ityptl(n)=60
3419         radptl(n)=0
3420         dezptl(n)=0.
3421        enddo !ii
3422        do l=1,4
3423         xorptl(l,njj)=xorptl(l,njj)/float(mjjseg)
3424        enddo
3425        mjjsegsum=mjjsegsum+mjjseg
3426        xx=xx+uptl(njj)
3427        yy=yy+optl(njj)
3428        xy=xy+desptl(njj)
3429        sptl(njj)=sptl(njj)/float(mjjseg)
3430        uptl(njj)=uptl(njj)/float(mjjseg)
3431        optl(njj)=optl(njj)/float(mjjseg)
3432        desptl(njj)=desptl(njj)/float(mjjseg)
3433        pjj52=(pptl(4,njj)+pptl(3,njj))*(pptl(4,njj)-pptl(3,njj))
3434      &    -pptl(1,njj)**2-pptl(2,njj)**2
3435         pptl(5,njj)=0
3436         if(pjj52.gt.0)then
3437           pptl(5,njj)=sqrt(pjj52)
3438         endif
3439         ityptl(njj)=60
3440         call idenct(jc,idptl(njj)
3441      *  ,ibptl(1,njj),ibptl(2,njj),ibptl(3,njj),ibptl(4,njj))
3442       enddo !jj
3443 
3444 
3445 c...ranphi
3446 
3447       ranphi=0
3448       rini=0.
3449       if(mjjsegsum.gt.0)then
3450         xx=xx/float(mjjsegsum)
3451         yy=yy/float(mjjsegsum)
3452         xy=xy/float(mjjsegsum)
3453         dta=0.5*(xx-yy)
3454 c        eba=0.5*(xx+yy)
3455 c        ww=-xy
3456 c        !-------------------------------------------------------
3457 c        !    inertia tensor:
3458 c        !----------------------+-------------------------------+
3459 c        !  <y**2>   -<x*y>     !      with <x**2>=uptl         !
3460 c        !  -<x*y>   <x**2>     !     <y**2>=optl  <xy>=desptl  !
3461 c        !----------------------+-------------------------------+
3462 c        ! Eigenvalues ev1, ev2
3463 c        !-------------------------------------------------------
3464 c        ev1=eba+sqrt(dta**2+ww**2)
3465 c        ev2=eba-sqrt(dta**2+ww**2)
3466         if(xy.lt.0..and.dta.ne.0.)then
3467           ranphi=0.5*atan(-xy/dta)
3468         elseif(xy.gt.0..and.dta.ne.0.)then
3469           ranphi=-0.5*atan(xy/dta)
3470         else
3471           ranphi=0
3472         endif
3473 c        if(dta.ne.0.)then
3474 c         ranphi=0.5*atan(abs(ww)/abs(dta))
3475 c         if(    ww.gt.0..and.dta.gt.0.)then
3476 c          ranphi=ranphi
3477 c         elseif(ww.lt.0..and.dta.gt.0.)then
3478 c          ranphi=-ranphi
3479 c         elseif(ww.gt.0..and.dta.lt.0.)then
3480 c          ranphi=pi-ranphi
3481 c         elseif(ww.lt.0..and.dta.lt.0.)then
3482 c          ranphi=ranphi-pi
3483 c         endif
3484 c        else
3485 c          ranphi=2.*pi*rangen()
3486 c        endif
3487         rini=max(0.01,sqrt(5./3.*(xx+yy))) !<r**2>=3/5*R**2 for sphere of radius R
3488         volu=(4./3.*pi*(xx+yy)**1.5)
3489 c        rho=amctot/volu
3490         flowpp=0.
3491         flowaa=0.
3492 
3493         if(iLHC.eq.1.and.visco.gt.0.)then
3494           if(npair.gt.0)then
3495             fcorr=min(1.,float(mapmax)*abs(fvisco)/float(maptot))
3496             visco=min(1.,2.*float(maptot)/float(npair)/float(mapmax))**2
3497 c     &                 *abs(fvisco))
3498           elseif(lclean)then  !large number of particles, npair can't be calculated
3499             visco=1e-6
3500             fcorr=1.
3501           else          !cluster from remnants only
3502             visco=1.
3503             fcorr=1.
3504           endif
3505           if(visco.ge.1.)yrmaxi=0. !yrmaxi*(1.-visco)
3506 c          visco=exp(-min(50.,max(0.,
3507 c     &         float(koievt)/log(amctot)-abs(fvisco))**yradpi)) !mix flow 
3508 c         &               max(0.,rmax**2-abs(fvisco))))    !mix flow 
3509 c          yrmaxi=log(amctot**2)
3510 c          yrmaxi=yradmx*yrmaxi*(1.-visco)
3511 c          if(visco.lt.1.and.yrmaxi.gt.1e-2)then
3512 c            yyrmax=dble(yrmaxi)
3513 c            fradflii=sngl(1d0/
3514 c     &         ((sinh(yyrmax)*yyrmax-cosh(yyrmax)+1d0)/(yyrmax**2/2d0)))
3515 c          else
3516 c            visco=1.
3517 c            yrmaxi=0.
3518 c            fradflii=1.
3519 c          endif
3520 c          if(visco.gt.1e-5)then
3521 c            yrmaxi=yradmx*(yrmaxi
3522 c     &            +visco*(log(amctot)*yradpx/yradmx-yrmaxi))
3523 c          else
3524 c            yrmaxi=yradmx*yrmaxi
3525 c          endif
3526           fradflii=1.
3527           if(yrmaxi.gt.0)then
3528             flowpp=visco*log(fcorr*amctot)*yradpx
3529             flowaa=yrmaxi
3530             if(rangen().lt.flowaa/flowpp)then
3531               visco=0.
3532               yrmaxi=flowaa+max(0.,flowpp-flowaa)
3533               yyrmax=dble(yrmaxi)
3534               fradflii=sngl(1d0/
3535      &        ((sinh(yyrmax)*yyrmax-cosh(yyrmax)+1d0)/(yyrmax**2/2d0)))
3536             else
3537               yrmaxi=0.
3538               visco=log(fcorr*amctot)/log(amctot)
3539             endif
3540           elseif(fcorr.lt.1.)then
3541             visco=log(fcorr*amctot)/log(amctot)
3542           endif
3543         endif
3544 
3545         if(ish.ge.3)write(ifch,*)'yrmaxi,delzet=',yrmaxi,delzet
3546 c        print *,'->',bimevt,yrmaxi,visco*yradpx*log(amctot),flowaa
3547 c     &        ,flowpp,maptot,log(ectot),visco,log(amctot),rho
3548 c     &        ,mapmax,npair
3549 c     &        ,min(1.,2.*float(maptot)/float(npair)/float(mapmax))**2
3550       endif
3551 
3552 c...print
3553 
3554       if(ish.ge.5)then
3555         write(ifch,*)'print'
3556         do k=1,m3grid
3557         write(ifch,*)'k=',k,'  jclu=',jclu(k)
3558      &              ,'  s=',(k-1)*delsgr-sgrid-shifts
3559          do j=m1grid,1,-1
3560         write(ifch,'(10i4,3x,10i4)')(idropgrid(i,j,k),i=1,m1grid)
3561      &                ,(jdropgrid(i,j,k),i=1,m1grid)
3562         enddo
3563         enddo
3564         write(ifch,'(a,a)')
3565      &    '    k   jj  nseg      mm  mseg     n      mass'
3566      &   ,'         s         y         z         t '
3567         do jj=1,jjj
3568          do ii=1,max(1,nint(1.*nseg(jj)/nsegsuj))
3569            mm=mmji(jj,ii)
3570            n=nptlb+mm
3571            sg=pptl(3,n)/abs(pptl(3,n))
3572            tm=sqrt(pptl(5,n)**2+pptl(1,n)**2+pptl(2,n)**2)
3573            y=sg*alog((pptl(4,n)+sg*pptl(3,n))/tm)
3574 c           if(kclu(jj).eq.44)print *,tm,pptl(4,n),pptl(3,n),iorptl(n)
3575            write(ifch,'(2i5,i6,i8,2i6,5f10.3)')
3576      &       kclu(jj),jj,nseg(jj),mm,mseg(mm),n,pptl(5,n)
3577      &      ,sptl(n),y,xorptl(3,n),xorptl(4,n)
3578          enddo
3579         enddo
3580       endif
3581 
3582 c...decay
3583       iret=0
3584       if(jjj.gt.0)then     !decay only if some cluster produced
3585       if(4-abs(typevt).gt.0.0001)typevt=-typevt    !typevt < 0 if fusion but only if not SD (sign used for something else for SD ... and no fusion produced for SD events)
3586       if(ish.ge.5)write(ifch,*)'decay ...'
3587       if(ifrade.eq.0.or.ispherio.gt.0)goto1000
3588       if(jdecay.eq.0)goto1000
3589       nptlbcf=nptl
3590       nptl0=nptl
3591       if(hydt.ne.'---')then
3592         call HydroFO(ier)
3593       else
3594         nclu=0
3595         ptest(1)=0d0
3596         ptest(2)=0d0
3597         ptest(3)=0d0
3598         ptest(4)=0d0
3599         ptest(5)=0d0
3600         do jj=1,jjj
3601           do ii=1,max(1,nint(1.*nseg(jj)/nsegsuj))
3602            mm=mmji(jj,ii)
3603            np=nptlb+mm
3604 c           print *,'decay',jj
3605            if(ioclude.eq.3)then
3606              call hnbaaa(np,iret)
3607            else
3608              call DropletDecay(np,iret)
3609            endif
3610            if(iret.eq.1)then
3611              istptl(np)=istptl(np)+2
3612              do ns=naseg(mm-1)+1,naseg(mm)
3613                n=nsegmt(ns)
3614                if(mod(abs(idptl(n)),100).eq.99)then   !restore lost energy
3615                  istptl(n) = 5
3616                  ior=iorptl(n)
3617                  ifrptl(1,ior) = 0
3618                  ifrptl(2,ior) = 0
3619                  if(istptl(ior).eq.0)then                   
3620                    do k=1,3
3621                      pptl(k,ior)=pptl(k,ior)+pptl(k,n)
3622                    enddo
3623                    pptl(4,ior)=sqrt(pptl(1,ior)**2+pptl(2,ior)**2
3624      &                             +pptl(3,ior)**2+pptl(5,ior)**2)
3625                    call idtau(idptl(ior),pptl(4,ior),pptl(5,ior),taugm)
3626                    tivptl(2,ior)=tivptl(1,ior)+taugm*(-alog(rangen()))
3627                  else
3628                    istptl(ior) = 0
3629                  endif
3630                elseif(idptl(n).lt.1e4)then
3631                  istptl(n) = 0     !particle
3632                  ifrptl(1,n) = 0
3633                  ifrptl(2,n) = 0
3634                else
3635                  istptl(n) = 10    !droplet
3636                endif
3637              enddo
3638            elseif(ioclude.eq.3)then
3639              do i=nptl0+1,nptl
3640                if(ityptl(i).eq.60)then
3641                  nclu=nclu+1
3642                  ptest(1)=ptest(1)+dble(pptl(1,i))
3643                  ptest(2)=ptest(2)+dble(pptl(2,i))
3644                  ptest(3)=ptest(3)+dble(pptl(3,i))
3645                  ptest(4)=ptest(4)+dble(pptl(4,i))
3646                endif
3647              enddo
3648              nptl0=nptl
3649            endif
3650           enddo
3651         enddo
3652       endif
3653       do jj=1,jjj
3654        do ii=1,max(1,nint(1.*nseg(jj)/nsegsuj))
3655         mm=mmji(jj,ii)
3656         np=nptlb+mm
3657         istptl(np)=istptl(np)+1
3658         ifrptl(1,np)=nptlbcf+1
3659         ifrptl(2,np)=nptl
3660         rinptl(np)=kclu(jj)-m3grid/2
3661        enddo
3662       enddo
3663 c add global flow on all particles of all decayed cluster
3664       if(iLHC.eq.1)then
3665         yrmax=0.
3666         if(fvisco.gt.0.)yrmax=yradpx*visco
3667       else
3668         yrmax=yradpx
3669       endif
3670 c      print *,bimevt,rini,yrmax,yrmaxi,delzet,np,ptmax,visco
3671       if(ioclude.eq.3.and.yrmax.gt.1e-3.and.nclu.gt.0)then
3672 c set angular informations
3673         fecc=0
3674         aa=1
3675         bb=0
3676         cc=0
3677         dd=1
3678         dta=0.5*abs(xx-yy)
3679         ev1=(xx+yy)/2+sqrt(dta**2+xy**2)
3680         ev2=(xx+yy)/2-sqrt(dta**2+xy**2)
3681         ecc=(ev1-ev2)/(ev1+ev2)
3682 c        fecc=facecc*ecc!/(1.+yrmax)
3683 c        print*,'pp',ecc,ranphi
3684         fecc=min(facecc,ecc)   !be careful : fecc change <pt> since it is the elliptical deformation of the sub cluster (give strength of v2)
3685 
3686         phiclu=mod(phievt+ranphi,2.*pi) !do not change otherwise v2 is gone
3687         if(phiclu.lt.-pi)phiclu=phiclu+2*pi
3688         if(phiclu.gt.pi)phiclu=phiclu-2*pi
3689         aa=cos(phiclu)
3690         bb=sin(phiclu)
3691         cc=-sin(phiclu)
3692         dd=cos(phiclu)
3693         errlim=0.00005
3694 c loop on particles for each main cluster
3695 c        ncl=nptlb0
3696         npass=max(1,min(nclu/5,jjj)) !to have the same number of group of particles than original clusters but different repartition of particles
3697         npart=nclu/npass
3698         if(npart*npass-nclu.gt.max(5,npart/2))npass=npass+1
3699 c        print *,'ici',nclu,npass,npart
3700 c        lcont=.true.
3701 c        if(nclu.lt.50)lcont=.false.
3702         lcont=.false.
3703         ncl=0
3704         nmin=nptlbcf+1
3705         nmax=nptl
3706         idrc=-1+2.*int(0.5+rangen())
3707         ntot=nclu
3708 
3709 c       prepare debug output for flow
3710         nall=0
3711         if(ish.ge.5)then
3712           nall=nmax-nmin+1
3713           do ii=1,nall
3714             idptl(nptl+ii)=idptl(nptlbcf+ii)
3715           enddo
3716           iorptl(nptl+nall+1)=nptl+1
3717           jorptl(nptl+nall+1)=nptl+nall
3718           do k=1,5
3719             pptl(k,nptl+nall+1)=0
3720             do ii=1,nall
3721               pptl(k,nptl+ii)=pptl(k,nptlbcf+ii)
3722               pptl(k,nptl+nall+1)=pptl(k,nptl+nall+1)+pptl(k,nptlbcf+ii)
3723             enddo
3724           enddo
3725         endif
3726         
3727 c initialization for rescaling on ipart particles    
3728         ipart=0
3729         tecm0=0.
3730         tecm=0.
3731         ini0=0
3732         ifi0=0
3733 
3734 c        do 900 while (ncl.le.nptlb-1)
3735         do while (ntot.gt.0)
3736           ncl=ncl+1
3737           if(iLHC.eq.1)then
3738             yrmax=yradpx*visco
3739           else
3740             yrmax=yradpx
3741           endif
3742 c         cms frame of all particles from same cluster
3743           do k=1,5
3744             ppp(k)=0d0
3745           enddo
3746           ini=nptl
3747           ifi=1
3748           if(idrc.gt.0)then
3749             imax=nmax
3750             imin=nmin-1
3751             if(ipart.eq.0)ini0=nmin
3752           else
3753             imax=nmin
3754             imin=nmax+1
3755             if(ipart.eq.0)ifi0=nmax
3756           endif
3757 c          npclu=0
3758 c 880      ncl=ncl+1
3759           n=0
3760           i=imin
3761           lpass=.true.
3762           do while ((n.lt.npart.or.ncl.eq.npass)
3763      &              .and.idrc*i.lt.idrc*imax.and.lpass)
3764             i=i+idrc
3765 c            if(jorptl(i).eq.ncl)then
3766 c            if(jorptl(i).eq.ncl.and.ityptl(i).eq.60)then
3767             
3768             if(ityptl(i).eq.60)then
3769               n=n+1
3770               ntot=ntot-1
3771               ini=min(ini,i)
3772               ifi=max(ifi,i)
3773 c              if(ityptl(i).eq.60)npclu=npclu+1
3774               do k=1,4
3775                 ppp(k)=ppp(k)+dble(pptl(k,i))
3776               enddo
3777             elseif(.not.lcont.and.n.gt.0)then
3778               lpass=.false.
3779             endif
3780 c            print *,ityptl(i),i,imin,imax,idrc,n,npart,ncl,nclu,nptl
3781           enddo
3782           np=n
3783           if(idrc.gt.0)then
3784             nmin=nmin+i-imin
3785             ifi0=i
3786           else
3787             nmax=nmax+i-imin
3788             ini0=i
3789           endif
3790           
3791 c          if(ncl.lt.nptlb.and.npclu.lt.int(0.2*(nptl-nptlbcf+1)))goto880
3792           if(ifi.le.ini)goto 900
3793 
3794 c record info for rescaling
3795           ipart=ipart+np
3796 
3797 c test mass
3798           ppp(5)=(ppp(4)-ppp(3))*(ppp(4)+ppp(3))-ppp(2)**2-ppp(1)**2
3799           if(ppp(5).gt.0d0)then
3800             ppp(5)=sqrt(ppp(5))
3801           else
3802             if(ish.ge.1)write(ifch,*)'Precision problem in jintpo, p:',
3803      &           (ppp(k),k=1,5)
3804             ppp(5)=0d0
3805           endif
3806             if(ish.ge.4)
3807      &           write(ifch,*)'Group of particle: ',
3808      &                        idrc,ini,ifi,ncl,'/',npass,npart,nclu
3809           if(ppp(5).gt.0d0)then    ! here all particle should have flow
3810             do i=ini,ifi
3811              if(ityptl(i).eq.60)then
3812               tecm=tecm+pptl(4,i)  !use energy in collision frame as reference
3813               call utlob4(1,ppp(1),ppp(2),ppp(3),ppp(4),ppp(5)
3814      $             ,pptl(1,i),pptl(2,i),pptl(3,i),pptl(4,i))
3815              endif
3816             enddo
3817             if(tecm.gt.0.)then
3818               yrmax=yrmax*log(amctot) !/rini**yradpi
3819             else
3820               yrmax=0.
3821             endif
3822 c           print *,bimevt,rini,ppp(5),yrmax,yrmaxi,delzet,np,ptmax,visco
3823             if(ish.ge.4)
3824      &      write(ifch,*)'Radial flow: ',yrmax,tecm,visco,yradpx,yradpp
3825             if(yrmax.gt.0.)then
3826               if(np.gt.maxp)stop'maxp too small in jintpo'
3827               i=0
3828               if(ish.ge.8)call clist('list before flow&',ini,ifi,60,60)
3829               do ii=ini,ifi
3830                if(ityptl(ii).eq.60)then
3831                 i=i+1
3832                 yrad(i)=sqrt(rangen())
3833                 phirad(i)=2.*pi*rangen()
3834                 pt2=(pptl(1,ii)**2+pptl(2,ii)**2)!+pptl(5,ii)**2)
3835                 bex=sinh(yrad(i)*yrmax)*cos(phirad(i))
3836      &             *(1+fecc/(1.+pt2))
3837                 bey=sinh(yrad(i)*yrmax)*sin(phirad(i))
3838      &             *(1-fecc/(1.+pt2))
3839                 be(1)=aa*bex+cc*bey
3840                 be(2)=bb*bex+dd*bey
3841                 be(3)=0d0
3842                 be(4)=sqrt(1+be(1)**2+be(2)**2)
3843 c                call utlob4(1,be(1),be(2),be(3),be(4),1d0
3844 c     *         , pptl(1,ii), pptl(2,ii), pptl(3,ii), pptl(4,ii))
3845 c mimic boost transformation but protect against to high values of p(3) (p(3)~p(4)) 
3846                 pt2=pptl(1,ii)**2+pptl(2,ii)**2
3847                 bet=-(pptl(1,ii)*be(1)+pptl(2,ii)*be(2))/(be(4)+1.)
3848                 
3849                 pt=yradpp**max(1.,pptl(5,ii))
3850                 fac=1./(1.+sqrt(pt2/pptl(5,ii)**2))**pt
3851                 bet=bet+sqrt(pt2+(pptl(3,ii)**2+pptl(5,ii)**2)*fac)
3852                 
3853                 pptl(1,ii)=pptl(1,ii)-bet*be(1)
3854                 pptl(2,ii)=pptl(2,ii)-bet*be(2)
3855                 pptl(4,ii)=sqrt(pptl(1,ii)**2+pptl(2,ii)**2
3856      *                   +pptl(3,ii)**2+pptl(5,ii)**2)
3857               else
3858                 yrad(i)=0.
3859                 phirad(i)=0.
3860                endif
3861               enddo
3862               if(ish.ge.8)call clist('list after flow&',ini,ifi,60,60)
3863 
3864 
3865 c           boost back
3866               pe(1)=0.
3867               pe(2)=0.
3868               pe(4)=0.
3869               do i=ini,ifi
3870                 if(ityptl(i).eq.60)then
3871                   call utlob4(-1,ppp(1),ppp(2),ppp(3),ppp(4),ppp(5)
3872      $             ,pptl(1,i),pptl(2,i),pptl(3,i),pptl(4,i))
3873                   pe(1)=pe(1)+pptl(1,i)
3874                   pe(2)=pe(2)+pptl(2,i)
3875                   pe(4)=pe(4)+pptl(4,i)
3876                 endif
3877               enddo
3878 
3879 
3880 
3881 cc random rescaling
3882 c rescaling has to be done for different bins in eta to conserve
3883 c energy flow (if everything is done at the end on all particles,
3884 c the energy flow is concentred at mid-rapidity in contradiction
3885 c with ATLAS data
3886 c On the other hand, a sufficient number of particles is necessary
3887 c to have proper eta distribution in particular at high pt.
3888 c Since the clusters are ordered in rapidity we can do the rescaling on
3889 c group of clusters having enough particles for the rescaling but
3890 c not too much to keep the eta dependence of the energy flow.
3891 
3892 c set ipart.ge.1 to do rescaling for each subclusters
3893 
3894               if((ipart.ge.1.and.ntot.ge.ipart/2).or.ntot.eq.0)then
3895 
3896                 ini=ini0
3897                 ifi=ifi0
3898 
3899                 if(ish.ge.8)
3900      &          call clist('list before flow rescaling&',ini,ifi,60,60)
3901 
3902                 if(fplmin.gt.0)then
3903 
3904 c                  ntrt=ntrt+1
3905 
3906                   niter=0
3907  611              energ=0.
3908                   energ0=0.
3909                   niter=niter+1
3910                   i=0
3911                   ptmax=0.
3912                   plmax=0.
3913                   do  j=ini,ifi
3914                     if(ityptl(j).eq.60)then
3915                       i=i+1
3916                       pt2=pptl(1,j)**2+pptl(2,j)**2
3917                       pz2=pptl(3,j)**2
3918                       pp2=pt2+pz2
3919 c                      et2=(pp2+pptl(5,j)**2)*pt2/pp2
3920                       pt=sqrt(pt2)
3921 c                      pp=sqrt(pp2)
3922 c base necessary to avoid peak at pt or pl=0
3923 c epsi change the shape of eta distributions and pt for
3924 c identified particles (shift the maximum of the distribution)
3925 c                      epsi=min(0.99,fplmin*rangen()**0.3)
3926                       base=0. !sqrt(1./(1.-epsi)**2-1.)*pptl(5,j)/pp
3927                       finc=2.
3928                       if(energ0.lt.tecm)then
3929                         finc=finc*sqrt(float(max(1,niter-300)))
3930 c                        base=base+min(tecm/pe(4),
3931 c     &                           (max(0,niter-300))*0.3*pptl(5,j)/pp)
3932                       else
3933 c                        base=base/log10(max(10.,float(niter-300)))
3934                         finc=finc/sqrt(max(1.,float(niter-300)))
3935                       endif
3936 c                      if(1.-pptl(5,j)/pptl(4,j).ge.epsi
3937 c     &                   .and.1.+pptl(5,j)**2*(1./pp2-1./pt2).gt.0.)then
3938                       if(1.+pptl(5,j)**2*(1./pp2-1./pt2).gt.0.)then
3939                         ptmax=max(pt,ptmax)
3940                         plmax=max(abs(pptl(3,j)),plmax)
3941                         yrad2(i)=rangen()
3942                         yrad2(i)=yrad2(i)*
3943      &                       max(0.,min(1.,finc*tecm/pe(4))-base)
3944 
3945 
3946 c necessary even with epsi cut to smooth eta distribution
3947 c and since sumEt has to be conserved, we can constrain scaling for pt
3948 c and pz :
3949 c                        ytmp=yrad2(i)
3950                         yrad2(i)= yrad2(i)**((1.-(pptl(5,j)
3951      &    /sqrt((min(1.,yrad2(i)*float(max(1,niter-100))))**2
3952      &         *(pt**2+pptl(3,j)**2)+pptl(5,j)**2))**1.)
3953      &    *exp(-fplmin*max(0.,pt**2-(pe(4)/tecm)**2)))
3954 
3955                         yrad2(i)=min(1.,base+yrad2(i)) !should be here to avoid peak at eta=0.
3956                       else
3957                         yrad2(i)=1.
3958 c                        ytmp=yrad2(i)
3959                       endif
3960                       be(1)= pptl(1,j)*yrad2(i)
3961                       be(2)= pptl(2,j)*yrad2(i)
3962                       be(3)= pptl(3,j)*yrad2(i)                
3963 
3964 c      print *,niter,i,ntry,yrad2(i),energ/tecm,pt,pptl(3,j),finc,base
3965 c     *       ,ytmp,(1.-(pptl(5,j)
3966 c     &    /sqrt((min(1.,yrad2(i)*float(max(1,niter-100))))**2
3967 c     &         *(pt**2+pptl(3,j)**2)+pptl(5,j)**2))**0.1)
3968 
3969                       energ=energ+sqrt(be(1)**2+be(2)**2
3970      *                       +be(3)**2+pptl(5,j)**2)
3971                     endif
3972                   enddo
3973                   energ0=energ
3974 c          print *,'fin',niter,energ/tecm
3975                   if(abs(energ-tecm)/tecm.gt.1..and.niter.lt.1000)then
3976                     goto 611
3977                   elseif(niter.ge.1000)then
3978 c      print *,'Rescaling failed:',pe(4),tecm,ptmax,plmax,ipart,ini0,ifi
3979                     if(ish.ge.2)write(ifch,*)'Random rescaling failed:'
3980      &                   ,energ,tecm,ptmax,plmax,ipart,ini0,ifi
3981 c                    ntrr=ntrr+1
3982                     goto 200
3983                   endif
3984 c      print *,'done',niter,energ/tecm,ipart,ini0,ifi,finc
3985                   if(ish.ge.5)write(ifch,*)'Rescaling done:'
3986      &               ,tecm,energ/tecm,niter,ptmax,plmax,ipart,ini0,ifi
3987                   i=0
3988                   do  j=ini,ifi
3989                     if(ityptl(j).eq.60)then
3990                       i=i+1
3991                       pptl(1,j)= pptl(1,j)*yrad2(i)
3992                       pptl(2,j)= pptl(2,j)*yrad2(i)
3993                       pptl(3,j)= pptl(3,j)*yrad2(i)                
3994                       pptl(4,j)=sqrt(pptl(1,j)**2+pptl(2,j)**2
3995      *                     +pptl(3,j)**2+pptl(5,j)**2)
3996                     endif
3997                   enddo
3998                 endif
3999 
4000  200            continue
4001 
4002 
4003               if(ish.ge.8)
4004      &        call clist('list after flow rescaling&',ini,ifi,60,60)
4005 
4006               tecm0=tecm0+tecm
4007               tecm=0.
4008               ipart=0
4009 
4010             endif
4011 
4012           endif                 ! yrmax
4013 
4014         endif     !p(5)>0
4015 
4016 
4017  900  continue
4018       enddo
4019 
4020 c rescale momentum precisely and globaly to avoid artefacts for matrix
4021 c but only at 10% level to keep dependence of sumEt with eta 
4022       if(tecm0.gt.0)then
4023         ini=nptlbcf+1
4024         ifi=nptl
4025         esoll=tecm0
4026         scal=1.
4027         do ipass=1,2000
4028           sum=0.
4029           n=0
4030           do  j=ini,ifi
4031             if(ityptl(j).eq.60)then
4032               n=n+1
4033 c             this part is EXTREMELY important for the pseudorapidity shape at various pt
4034 c             if nothing special a broad peak appear at eta=0
4035 c             to avoid that, scal has to be reduced when p3 or pt reach 0
4036               if(scal.lt.1.)then
4037                 scal0=scal
4038                 pt=sqrt(pptl(1,j)**2+pptl(2,j)**2)
4039                 if(fplmin.le.0.)then
4040                   pt=abs(fplmin)/sqrt(pptl(5,j))*pt
4041 c                  pt=abs(fplmin)*pt
4042                 else
4043                   pt=5.*pt
4044                 endif
4045                 pow=sqrt(pptl(5,j)**2+scal**2*(pt**2
4046      *                           +pptl(3,j)**2))
4047                 pow=(1.-(1./sqrt(pptl(5,j))+pptl(5,j))
4048      *                 /(1./sqrt(pptl(5,j))+pow))
4049                 pow=rangen()*pow
4050               else
4051                 pow=1.-2.*pptl(4,j)/engy  !to avoid particle with energy larger than beam energy
4052                 if(pow.lt.0.)then
4053                   scal0=1./((1.-pow)
4054      *                     *exp(-0.25*max(-4.,log(rangen()))))
4055                   pow=1.
4056 c                  print *,j,pptl(4,j),pow,scal0,scal
4057 c     *                              ,pptl(3,j)*scal0**pow
4058                 else
4059                   scal0=scal
4060                   pow=rangen()*pow
4061                 endif
4062               endif
4063 
4064               do k=1,3
4065                 pptl(k,j)=pptl(k,j)*scal0**pow !to smooth distributions   
4066               enddo
4067               pptl(4,j)=sqrt(pptl(1,j)**2+pptl(2,j)**2
4068      *             +pptl(3,j)**2+pptl(5,j)**2)
4069               sum=sum+pptl(4,j)
4070             endif
4071           enddo
4072           scal=esoll/sum
4073 c         write(ifmt,*)'ipass,scal,e,esoll:'
4074 c     $             ,ipass,scal,sum,esoll
4075           if(abs(scal-1.).le.errlim) goto 300
4076         enddo
4077  300    continue
4078 c         write(ifmt,*)'ipass,scal,e,esoll:'
4079 c     $             ,ipass,scal,sum,esoll
4080 
4081 c adjust pt to have pt conservation in cms of particles having flow
4082         if(nclu.gt.0)then
4083           ptest(5)=(ptest(4)-ptest(3))*(ptest(4)+ptest(3))-ptest(2)**2
4084      &            -ptest(1)**2
4085           if(ptest(5).gt.0d0)then
4086             ptest(5)=sqrt(ptest(5))
4087           else
4088             if(ish.ge.1)write(ifch,*)'Precision problem in jintpo, p:',
4089      &           (ptest(k),k=1,5)
4090             ptest(5)=0d0
4091           endif
4092           be(1)=0.d0
4093           be(2)=0.d0
4094           do i=ini,ifi
4095             if(ityptl(i).eq.60)then
4096               call utlob4(1,ptest(1),ptest(2),ptest(3),ptest(4),ptest(5)
4097      $             ,pptl(1,i),pptl(2,i),pptl(3,i),pptl(4,i))
4098               be(1)=be(1)+dble(pptl(1,i))
4099               be(2)=be(2)+dble(pptl(2,i))
4100             endif
4101           enddo
4102 c shift nclu particles to have sum_pt=0. and boost back in global cms
4103           pt1shift=-sngl(be(1)/dble(nclu))
4104           pt2shift=-sngl(be(2)/dble(nclu))
4105           do i=ini,ifi
4106             if(ityptl(i).eq.60)then
4107               pptl(1,i)=pptl(1,i)+pt1shift
4108               pptl(2,i)=pptl(2,i)+pt2shift
4109               pptl(4,i)=sqrt(pptl(1,i)**2+pptl(2,i)**2
4110      &             +pptl(3,i)**2+pptl(5,i)**2)
4111              call utlob4(-1,ptest(1),ptest(2),ptest(3),ptest(4),ptest(5)
4112      &             ,pptl(1,i),pptl(2,i),pptl(3,i),pptl(4,i))
4113             endif
4114           enddo
4115         endif
4116 
4117       endif
4118 
4119 
4120 c      if(ntrt.gt.0)print *,"jintpo rescaling :",float(ntrr)/float(ntrt)
4121 c     define life time
4122       n=0
4123       do i=ini,ifi
4124         if(ityptl(i).eq.60)then
4125           n=n+1
4126           r=1.15*rini*yrad(n)   !yrad=y/ymax
4127           tau=2.25/sqrt(yrad(n)**2+0.04)-0.75
4128           z=xorptl(3,i)
4129           t=xorptl(4,i)
4130 !         zeta=0.5*log((t+z)/(t-z))-0.5*delzet+2*0.5*delzet*rangen()
4131         test=(pptl(4,i)-pptl(3,i))*(pptl(4,i)+pptl(3,i))
4132         if(test.gt.0.)then
4133           zeta=0.5*log((pptl(4,i)+pptl(3,i))
4134      &         /(pptl(4,i)-pptl(3,i)))
4135         else    !in case of precision problem (but not always good neither for p<0
4136           pt=sqrt(pptl(2,i)**2+pptl(1,i)**2)
4137           zeta=0.5*log(1+2*pptl(3,i)*(pptl(4,i)+pptl(3,i))
4138      &   /(pt*pt+pptl(5,i)**2))
4139         endif
4140           z=tau*sinh(zeta)
4141           t=tau*cosh(zeta)
4142           xorptl(1,i)=xorptl(1,i)+r*cos(phirad(n))
4143           xorptl(2,i)=xorptl(2,i)+r*sin(phirad(n))
4144           xorptl(3,i)=z
4145           xorptl(4,i)=t
4146         endif
4147       enddo
4148 
4149 
4150       if(ish.ge.5)then
4151         do k=1,5
4152           pptl(k,nptl+nall+2)=0
4153           do ii=nptlbcf+1,nptl
4154             pptl(k,nptl+nall+2)=pptl(k,nptl+nall+2)+pptl(k,ii)
4155           enddo
4156         enddo
4157         iorptl(nptl+nall+2)=nptlbcf+1
4158         jorptl(nptl+nall+2)=nptl
4159         call alist2('longitudinal and radial flow&',nptl+1
4160      &       ,nptl+nall,nptlbcf+1,nptl)
4161         call alist2('momentum sum&',nptl+nall+1,nptl+nall+1
4162      &       ,nptl+nall+2,nptl+nall+2)
4163         write(ifch,'(1x,50a1/)')('-',k=1,50)
4164       endif
4165       
4166 
4167       endif      !ioclude=3 and flow
4168 
4169 
4170       do n=nptlbcf+1,nptl
4171         if(ioclude.ne.3)then
4172           iorptl(n)=nptlb+1
4173           jorptl(n)=nptlbcf
4174           rinptl(n)=rinptl((iorptl(n)+jorptl(n))/2)
4175         else
4176           rinptl(n)=rinptl(iorptl(n))
4177         endif
4178         istptl(n)=0
4179         ifrptl(1,n)=0
4180         ifrptl(2,n)=0
4181         tivptl(1,n)=xorptl(4,n)
4182         call idtau(idptl(n),pptl(4,n),pptl(5,n),taugm)
4183         r=rangen()
4184         tivptl(2,n)=tivptl(1,n)+taugm*(-alog(r))
4185         radptl(n)=0.
4186         dezptl(n)=0.
4187         itsptl(n)=0
4188       enddo
4189 
4190       endif
4191 
4192 c Decay droplets not included in clusters
4193       iret=0
4194       do mm=1,nptla
4195         nptlb=nptl
4196         if(istptl(mm).eq.10)then
4197           if(ish.ge.5)write(ifch,*)'Decay remaining droplet :',mm
4198           if(nptlb.gt.mxptl-10)
4199      &    call utstop('jintpo: mxptl too small (2)&')
4200           if(ioclude.eq.3)then
4201             call hnbaaa(mm,iret)
4202           else
4203             call DropletDecay(mm,iret) !Decay remn
4204             iret=0
4205           endif
4206           if(iret.eq.0.and.nptl.ne.nptlb)then ! ---successful decay---
4207             istptl(mm)=istptl(mm)+1
4208             ifrptl(1,mm)=nptlb+1
4209             ifrptl(2,mm)=nptl
4210             t=tivptl(2,mm)
4211             x=xorptl(1,mm)+(t-xorptl(4,mm))*pptl(1,mm)/pptl(4,mm)
4212             y=xorptl(2,mm)+(t-xorptl(4,mm))*pptl(2,mm)/pptl(4,mm)
4213             z=xorptl(3,mm)+(t-xorptl(4,mm))*pptl(3,mm)/pptl(4,mm)
4214             do 21 n=nptlb+1,nptl
4215               iorptl(n)=mm
4216               jorptl(n)=0
4217               istptl(n)=0
4218               ifrptl(1,n)=0
4219               ifrptl(2,n)=0
4220               radius=0.8*sqrt(rangen())
4221               phi=2*pi*rangen()
4222               ti=t
4223               zi=z
4224               xorptl(1,n)=x + radius*cos(phi)
4225               xorptl(2,n)=y + radius*sin(phi)
4226               xorptl(3,n)=zi
4227               xorptl(4,n)=ti
4228               iioo=mm
4229               zor=dble(xorptl(3,iioo))
4230               tor=dble(xorptl(4,iioo))
4231               r=rangen()
4232               tauran=-taurea*alog(r)
4233               call jtaix(n,tauran,zor,tor,zis,tis)
4234               tivptl(1,n)=amax1(ti,tis)
4235               call idtau(idptl(n),pptl(4,n),pptl(5,n),taugm)
4236               r=rangen()
4237               tivptl(2,n)=t+taugm*(-alog(r))
4238               radptl(n)=0.
4239               dezptl(n)=0.
4240               itsptl(n)=0
4241               rinptl(nptl)=-9999
4242    21       continue
4243           else                  ! Unsuccessful decay
4244             if(ish.ge.1)write(ifch,*)
4245      *         '***** Unsuccessful remnant cluster decay'
4246      *             ,' --> redo event.'
4247           endif
4248         endif
4249       enddo
4250 
4251 
4252 
4253  1000 continue
4254       call utprix('jintpo',ish,ishini,4)
4255       end
4256 
4257 cc-----------------------------------------------------------------------
4258 c      subroutine jrad(i,nq,na,jc,rad)
4259 cc-----------------------------------------------------------------------
4260 cc     return hadron radius (data taken from huefner and povh)
4261 cc-----------------------------------------------------------------------
4262 c      include 'epos.inc'
4263 c      integer jc(nflav,2),kc(nflav)
4264 c
4265 c      id=iabs(idptl(i))
4266 c      am=pptl(5,i)
4267 c      if(id.lt.10000)then
4268 c       k=mod(id,10)
4269 c      else
4270 c       k=1
4271 c      endif
4272 c      do l=1,nflav
4273 c       kc(l)=iabs(jc(l,1)-jc(l,2))
4274 c      enddo
4275 c
4276 c      if(nq.eq.0)then   ! mesons
4277 c       if(kc(1).eq.0.and.kc(2).eq.0.and.kc(3).eq.0.and.kc(4).eq.0)then
4278 c        if(k.eq.0)then           ! flavor singlet pseudoscalar mesons
4279 c         if(am.ge.0.000)then
4280 c          rad=0.64                 ! pi0
4281 c          if(am.ge.0.500)then
4282 c           rad=0.60                ! eta
4283 c           if(am.ge.0.900)then
4284 c            rad=0.40               ! eta prime
4285 c            if(am.ge.2.900)then
4286 c             rad=0.17              ! eta charm
4287 c            endif
4288 c           endif
4289 c          endif
4290 c         else
4291 c          write(ifch,*)
4292 c     *    'i:',i,' id:',idptl(i),' k:',k,' m:',am
4293 c          write(ifch,*)'jc:',(jc(l,1),l=1,6),(jc(l,2),l=1,6)
4294 c          call utstop('jrad: meson radius not defined&')
4295 c         endif
4296 c        else                    ! flavor singlet vector mesons
4297 c         if(am.ge.0.000)then
4298 c          rad=0.72                ! rho,omega
4299 c          if(am.ge.1.000)then
4300 c           rad=0.46               ! phi
4301 c           if(am.ge.3.000)then
4302 c            rad=0.20              ! J/psi
4303 c           endif
4304 c          endif
4305 c         else
4306 c          write(ifch,*)
4307 c     *    'i:',i,' id:',idptl(i),' k:',k,' m:',am
4308 c          write(ifch,*)'jc:',(jc(l,1),l=1,6),(jc(l,2),l=1,6)
4309 c          call utstop('jrad: meson radius not defined&')
4310 c         endif
4311 c        endif
4312 c       elseif(kc(3).eq.0.and.kc(4).eq.0)then  ! nonstrange, noncharmed
4313 c        if(k.eq.0)then
4314 c         rad=0.64  ! pi
4315 c        else
4316 c         rad=0.72  ! resonances
4317 c        endif
4318 c       elseif(kc(3).ne.0.and.kc(4).eq.0)then  ! strange
4319 c        if(k.eq.0)then
4320 c         rad=0.59  ! kaons
4321 c        else
4322 c         rad=0.68  ! kaon resonances
4323 c        endif
4324 c       else                                   ! charmed
4325 c        write(ifch,*)'i:',i,' id:',idptl(i)
4326 c        call utstop('jrad: radius of meson not defined&')
4327 c       endif
4328 c      else   !baryons
4329 c       if(kc(4).gt.0)then       ! charmed
4330 c        write(ifch,*)
4331 c     *  'i:',i,' id:',idptl(i),' k:',k,' m:',am
4332 c        write(ifch,*)'i:',i,' id:',idptl(i)
4333 c        call utstop('jrad: radius of charmed baryon not defined&')
4334 c       elseif(kc(3).eq.0)then   ! nonstrange
4335 c        if(k.eq.0)then
4336 c         rad=0.82  !nucleons
4337 c        else
4338 c         rad=1.00  !resonances
4339 c        endif
4340 c       elseif(kc(3).eq.1)then   ! strange
4341 c        if(k.eq.0)then
4342 c         rad=0.76  !lambda, sigma
4343 c        else
4344 c         rad=0.93  !resonances
4345 c        endif
4346 c       elseif(kc(3).eq.2)then   ! double strange
4347 c        if(k.eq.0)then
4348 c         rad=0.71  !cascades
4349 c        else
4350 c         rad=0.87  !resonances
4351 c        endif
4352 c       elseif(kc(3).ge.3)then   ! triple strange
4353 c        rad=0.79  !omega
4354 c       else
4355 c        write(ifch,*)
4356 c     *  'i:',i,' id:',idptl(i),' k:',k,' m:',am
4357 c        write(ifch,*)
4358 c     *  'q:',(jc(l,1),l=1,6),' qbar:',(jc(l,2),l=1,6),
4359 c     *  ' |q-qbar|:',(kc(l),l=1,6)
4360 c        call utstop('jrad: should not happen&')
4361 c       endif
4362 cc string fragments with |#q|>3
4363 c       if(na.gt.3)then
4364 c        a=(na/3.)**(1./3.)
4365 c        if(ish.ge.7)then
4366 c         call utmsg('jrad ')
4367 c         write(ifch,*)
4368 c     *   'i:',i,' id:',idptl(i),' k:',k,' m:',am
4369 c         write(ifch,*)
4370 c     *   'q:',(jc(l,1),l=1,6),' qbar:',(jc(l,2),l=1,6),
4371 c     *   ' |q-qbar|:',(kc(l),l=1,6)
4372 c         write(ifch,*)'nq:',nq,' na:',na,' r:',rad,' ar:',a*rad
4373 c         call utmsgf
4374 c        endif
4375 c        rad=rad*a
4376 c       endif
4377 c      endif
4378 c
4379 c      if(ish.ge.7)then
4380 c       write(ifch,*)
4381 c     * 'i:',i,' id:',idptl(i),' k:',k,' m:',am,' rad:',rad
4382 c       write(ifch,*)'jc:',(jc(l,1),l=1,6),(jc(l,2),l=1,6)
4383 c      endif
4384 c
4385 c      return
4386 c      end
4387 c
4388 c-----------------------------------------------------------------------
4389       subroutine jresc
4390 c-----------------------------------------------------------------------
4391       include 'epos.inc'
4392       double precision pa(5),pj(5)
4393       integer ipptl(mxptl)
4394 
4395       call utpri('jresc ',ish,ishini,4)
4396 
4397       iret=0
4398       nptlpt=maproj+matarg
4399       np=0
4400       do i=nptlpt+1,nptl
4401        if(istptl(i).eq.0
4402      * .and.idptl(i).lt.10000.and.pptl(5,i).gt.0.01)then
4403         np=np+1
4404         ipptl(np)=i
4405        endif
4406       enddo
4407       if(np.lt.2)goto1001
4408       do ii=1,np
4409        i=ipptl(ii)
4410        if(mod(iabs(idptl(i)),10).lt.2)then
4411         call idmass(idptl(i),ami)
4412         dm=abs(ami-pptl(5,i))
4413         if(dm.gt.0.001)then
4414          ntry=0
4415 1        continue
4416          ntry=ntry+1
4417 2        jj=1+int(rangen()*np)
4418          j=ipptl(jj)
4419          if(ish.ge.4)write(ifch,*)i,j,istptl(j)
4420          if(j.eq.i)goto2
4421          if(mod(iabs(idptl(j)),10).lt.2)then
4422           call idmass(idptl(j),amj)
4423          else
4424           amj=pptl(5,j)
4425          endif
4426          do l=1,5
4427           pa(l)=dble(pptl(l,i))
4428           pj(l)=dble(pptl(l,j))
4429          enddo
4430          if(ish.ge.4)write(ifch,'(70a1)')('-',l=1,70)
4431          if(ish.ge.4)write(ifch,11)i,idptl(i),'before:',pa,'want:',ami
4432          if(ish.ge.4)write(ifch,11)j,idptl(j),'before:',pj,'want:',amj
4433          call jrescl(pa,dble(ami),pj,dble(amj),iret)
4434          if(iret.eq.1)then
4435           if(ntry.le.50)then
4436            goto1
4437           else
4438            goto1001
4439           endif
4440          endif
4441          if(ish.ge.4)write(ifch,11)i,idptl(i),' after:',pa
4442          if(ish.ge.4)write(ifch,11)j,idptl(j),' after:',pj
4443          if(ish.ge.4)write(ifch,'(70a1)')('-',l=1,70)
4444          do l=1,5
4445           pptl(l,i)=sngl(pa(l))
4446           pptl(l,j)=sngl(pj(l))
4447          enddo
4448         endif
4449        endif
4450       enddo
4451 11    format(i5,1x,i5,1x,a,1x,5(d8.2,1x),a,1x,e8.2)
4452 
4453 1000  continue
4454       call utprix('jresc ',ish,ishini,4)
4455       return
4456 
4457 1001  continue
4458       if(ish.ge.1)then
4459         write(ifmt,'(a)')'jresc: could not put on shell'
4460       endif
4461       goto1000
4462 
4463       end
4464 
4465 c-----------------------------------------------------------------------
4466       subroutine jrescl(p1,am1,p2,am2,iret)
4467 c-----------------------------------------------------------------------
4468 c rescale momenta of two particles such that the masses assume given
4469 c values.
4470 c input:
4471 c   p1, p2: momenta of the two particles
4472 c   am1, am2: desired masses of the two particles
4473 c output:
4474 c   p1, p2: new momenta of the two particles
4475 c-----------------------------------------------------------------------
4476       include 'epos.inc'
4477       double precision p1(5),p2(5)
4478      *                ,p1n(5),p2n(5)
4479      *                ,a1,a2,a12,am1,am2
4480      *                ,b1,b2,c,d,e,f,g,p,q,r
4481 
4482       call utpri('jrescl',ish,ishini,7)
4483 
4484       iret=0
4485       a1=p1(5)**2
4486       a2=p2(5)**2
4487       a12=p1(4)*p2(4)-p1(3)*p2(3)-p1(2)*p2(2)-p1(1)*p2(1)
4488       if(a12.le.(a1+a2))then
4489        if(ish.ge.7)write(ifch,*)'a_12 < a_1 + a_2'
4490        if(ish.ge.7)write(ifch,*)a12,' < ',a1+a2
4491 c      goto1001
4492       endif
4493 
4494 11    format(5(d9.3,1x))
4495       if(ish.ge.7)write(ifch,11)p1,a1
4496       if(ish.ge.7)write(ifch,11)p2,a2
4497       if(ish.ge.7)write(ifch,*)a12
4498 
4499       c=(a1+a12)/(a2+a12)
4500       d=(a1-am1**2-a2+am2**2)/(a2+a12)*0.5d0
4501 
4502       e=a1-2d0*a12*c+a2*c**2
4503       f=2d0*(a1-a12*(c+d)+a2*c*d)
4504       g=a1-2d0*a12*d+a2*d**2-am1**2
4505 
4506       p=f/e
4507       q=g/e
4508       r=p**2-4d0*q
4509 
4510       if(ish.ge.7)write(ifch,*)'c:',c,' d:',d
4511       if(ish.ge.7)write(ifch,*)'e:',e,' f:',f,' g:',g
4512       if(ish.ge.7)write(ifch,*)'p:',p,' q:',q,' r:',r
4513       if(r.lt.0d0)goto1001
4514 
4515       b1=-0.5d0*(p-dsqrt(r))
4516 
4517       b2=b1*c+d
4518 
4519       if(ish.ge.7)write(ifch,*)'b_1:',b1,' b_2:',b2
4520 
4521       do i=1,4
4522        p1n(i)=(1d0+b1)*p1(i)-b2*p2(i)
4523        p2n(i)=(1d0+b2)*p2(i)-b1*p1(i)
4524       enddo
4525 
4526       a1=p1n(4)**2-p1n(3)**2-p1n(2)**2-p1n(1)**2
4527       a2=p2n(4)**2-p2n(3)**2-p2n(2)**2-p2n(1)**2
4528       if(a1.gt.0d0.and.a2.gt.0d0)then
4529        do i=1,4
4530         p1(i)=p1n(i)
4531         p2(i)=p2n(i)
4532        enddo
4533        p1(5)=dsqrt(a1)
4534        p2(5)=dsqrt(a2)
4535        if(ish.ge.7)write(ifch,11)p1,a1
4536        if(ish.ge.7)write(ifch,11)p2,a2
4537       else
4538        goto1001
4539       endif
4540 
4541       if(p1(4).lt.0..or.p2(4).lt.0.)goto1001
4542 
4543 1000  continue
4544       call utprix('jrescl',ish,ishini,7)
4545       return
4546 
4547 1001  continue
4548       iret=1
4549       goto1000
4550       end
4551 
4552 c-----------------------------------------------------------------------
4553       subroutine jtain(i,x,y,z,t,n,iopt)
4554 c-----------------------------------------------------------------------
4555 c returns intersection (x,y,z,t) of ptl-i-trajectory with taus-line.
4556 c input:
4557 c   i: particle number
4558 c   iopt: formation time considered (0) or not (1)
4559 c output:
4560 c   x,y,z,t: 4-vector of intersection point
4561 c   n: exit code
4562 c       n=0: ok
4563 c       n=1: ptl lives later
4564 c       n=2: ptl lives earlier
4565 c       n=9: tiv1>tiv2
4566 c-----------------------------------------------------------------------
4567       include 'epos.inc'
4568       double precision tpro,zpro,ttar,ztar,ttaus,detap,detat
4569       common/cttaus/tpro,zpro,ttar,ztar,ttaus,detap,detat
4570       double precision vv,zza,zz,tt,xo3,xo4,ti1,ti2,derr,dd
4571       double precision ttp,zzp,ttt,zzt,vvt,vvp,spt2m2E,p4
4572       common/ctfi/tin,tfi
4573       double precision ttau0
4574       common/cttau0/ttau0
4575 
4576       n=0
4577 
4578       tin=0
4579       tfi=0
4580 
4581       derr=1d-2
4582       ttp=tpro*ttaus
4583       zzp=zpro*ttaus
4584       ttt=ttar*ttaus
4585       zzt=ztar*ttaus
4586       vv=sign(min(1.d0,abs(dble(pptl(3,i)))/dble(pptl(4,i)))
4587      &                ,dble(pptl(3,i)))
4588 
4589 
4590       if(abs(vv).ge.1.d0)then
4591         spt2m2E=dble(pptl(1,i)*pptl(1,i)+pptl(2,i)*pptl(2,i)
4592      &              +pptl(5,i)*pptl(5,i))
4593 c        if(pptl(4,i).le.0.)then
4594           p4=sqrt(dble(pptl(3,i)*pptl(3,i))+spt2m2E)
4595 c        else
4596 c          p4=dble(pptl(4,i))
4597 c        endif
4598 ctp to avoid precision problem, replace abs(p3)/p4 by sqrt(1-(pt2+m2)/E2)
4599         spt2m2E=min(1.d0,sqrt(spt2m2E)/p4)
4600         vv=sign(sqrt((1d0+spt2m2E)*(1d0-spt2m2E)),dble(pptl(3,i)))
4601       endif
4602       xo3=dble(xorptl(3,i))
4603       xo4=dble(xorptl(4,i))
4604       zza=xo3-xo4*vv
4605       if(iopt.eq.0)then
4606         ti1=dble(tivptl(1,i))
4607       elseif(iopt.eq.1)then
4608         ti1=dble(xo4)
4609       else
4610         ti1=0
4611         call utstop("Wrong iopt in jtain !&")
4612       endif
4613       ti2=dble(tivptl(2,i))
4614 
4615       if(ti1.gt.ti2)then
4616         n=9
4617         goto1
4618       endif
4619 
4620       zfi=sngl(xo3+(ti2-xo4)*vv)
4621       call jtaus(zfi,tzfi,szfi)
4622       tfi=tzfi
4623       if(tfi.ge.sngl(ti2))then
4624         n=2
4625         goto1
4626       endif
4627 
4628       zin=sngl(xo3+(ti1-xo4)*vv)
4629       call jtaus(zin,tzin,szin)
4630       tin=tzin
4631       if(tin.le.sngl(ti1))then
4632         n=1
4633         goto1
4634       endif
4635 
4636 
4637     1 continue
4638 
4639            if(ttaus.le.ttau0)then
4640       tt=ttaus
4641       zz=xo3+(tt-xo4)*vv
4642       if(tt.lt.ti1.and.n.eq.0)n=1
4643       if(tt.ge.ti2.and.n.eq.0)n=2
4644       goto1000
4645            else
4646       vvt=zzt/ttt
4647       vvp=zzp/ttp
4648       tt=(ttt+(zza-zzt)*vvt)/(1-vv*vvt)
4649       zz=xo3+(tt-xo4)*vv
4650       if(zz.le.zzt)then
4651       if(tt.lt.ti1.and.n.eq.0)n=1
4652       if(tt.ge.ti2.and.n.eq.0)n=2
4653       goto1000
4654       endif
4655       tt=(ttp+(zza-zzp)*vvp)/(1-vv*vvp)
4656       zz=xo3+(tt-xo4)*vv
4657       if(zz.ge.zzp)then
4658       if(tt.lt.ti1.and.n.eq.0)n=1
4659       if(tt.ge.ti2.and.n.eq.0)n=2
4660       goto1000
4661       endif
4662       dd=1-vv**2
4663       if(sngl(dd).eq.0..and.vv.gt.0.)then
4664       tt=-(ttaus**2+zza**2)/2d0/zza
4665       elseif(sngl(dd).eq.0..and.vv.lt.0.)then
4666       tt=(ttaus**2+zza**2)/2d0/zza
4667       else
4668       tt=(zza*vv+dsqrt(zza**2+ttaus**2*dd))/dd
4669       endif
4670       zz=xo3+(tt-xo4)*vv
4671       if(tt.lt.ti1.and.n.eq.0)n=1
4672       if(tt.ge.ti2.and.n.eq.0)n=2
4673         if(dabs(ttaus**2-(tt+zz)*(tt-zz)).gt.derr*ttaus**2.and.
4674      *dabs(ttaus**2-(tt+zz)*(tt-zz)).gt.derr)then
4675       if(ish.ge.1)then
4676       call utmsg('jtain')
4677       write(ifch,*)'*****  ttaus**2 .ne. (tt+zz)*(tt-zz)'
4678       write(ifch,*)sngl(ttaus**2),sngl((tt+zz)*(tt-zz))
4679       call utmsgf
4680       endif
4681       goto1000
4682         endif
4683            endif
4684 
4685 1000  t=sngl(tt)
4686       z=sngl(zz)
4687       x=xorptl(1,i)+(t-xorptl(4,i))*pptl(1,i)/pptl(4,i)
4688       y=xorptl(2,i)+(t-xorptl(4,i))*pptl(2,i)/pptl(4,i)
4689       return
4690       end
4691 
4692 c-----------------------------------------------------------------------
4693       subroutine jtaix(i,tau,zor,tor,z,t)
4694 c-----------------------------------------------------------------------
4695 c     returns intersection z,t of ptl-i-trajectory with hyperbola h.
4696 c        h: (t-tor)**2-(z-zor)**2=tau**2 .
4697 c        zor, tor double precision.
4698 c-----------------------------------------------------------------------
4699       include 'epos.inc'
4700       double precision tor,zor,tors,zors,vv,cc,dd,ttau,derr,tt,zz
4701       derr=1d-3
4702       ttau=dble(tau)
4703       zors=dble(xorptl(3,i))-zor
4704       tors=dble(xorptl(4,i))-tor
4705       vv=dble(pptl(3,i)/pptl(4,i))
4706       vv=dmin1(vv,1d0)
4707       vv=dmax1(vv,-1d0)
4708       cc=zors-tors*vv
4709       dd=1d0-vv**2
4710       dd=dmax1(dd,0d0)
4711            if(dd.eq.0d0.and.cc.eq.0d0)then
4712       if(tau.eq.0.)tt=0d0
4713       if(tau.ne.0.)tt=dble(ainfin)
4714       zz=tt
4715       goto1000
4716            elseif(dd.eq.0d0)then
4717       tt=-(ttau**2+cc**2)/2d0/cc/vv
4718            elseif(dd.lt.1e-8)then
4719       tt=-(ttau**2+cc**2)/2d0/cc/vv
4720       call utmsg('jtaix')
4721       write(ifch,*)'*****  dd = ',dd,'    treated as zero'
4722       call utmsgf
4723            else
4724       tt=(cc*vv+dsqrt(cc**2+ttau**2*dd))
4725       tt=tt/dd
4726            endif
4727       zz=cc+tt*vv
4728       if(dabs(ttau**2-(tt+zz)*(tt-zz)).gt.derr*ttau**2
4729      *.and.dabs(ttau**2-(tt+zz)*(tt-zz)).gt.derr
4730      *.and.tors**2-zors**2.lt.1e6)then
4731       if(ish.ge.2)then
4732       call utmsg('jtaix')
4733       write(ifch,*)'*****  ttau**2 .ne. (tt+zz)*(tt-zz)'
4734       write(ifch,*)sngl(ttau**2),sngl((tt+zz)*(tt-zz))
4735       write(ifch,*)'tau,t,z:'
4736       write(ifch,*)tau,tt,zz
4737       write(ifch,*)'#,id(ptl):',i,idptl(i)
4738       write(ifch,*)'zor,tor(str):',zor,tor
4739       write(ifch,*)'zors,tors,p,e(ptl):'
4740       write(ifch,*)sngl(zors),sngl(tors),pptl(3,i),pptl(4,i)
4741       call utmsgf
4742       endif
4743       endif
4744 1000  z=sngl(zz+zor)
4745       t=sngl(tt+tor)
4746       return
4747       end
4748 
4749 c-----------------------------------------------------------------------
4750       subroutine jtaug(su,so,g,y)
4751 c-----------------------------------------------------------------------
4752 c  returns g factor and rapidity y for given su, so
4753 c-----------------------------------------------------------------------
4754       include 'epos.inc'
4755       double precision tpro,zpro,ttar,ztar,ttaus,detap,detat
4756       common/cttaus/tpro,zpro,ttar,ztar,ttaus,detap,detat
4757       double precision ttp,zzp,ttt,zzt,ssp,sst,ssu,sso,ss1,ss2,gg
4758      *,ssav,yyav,hh
4759       double precision ttau0
4760       common/cttau0/ttau0
4761 
4762       ssu=dble(su)
4763       sso=dble(so)
4764 
4765       if(ssu.ge.sso)then
4766       sso=(ssu+sso)*0.5d0 + dble(abs(dezzer))*ttaus*0.5d0
4767       ssu=(ssu+sso)*0.5d0 - dble(abs(dezzer))*ttaus*0.5d0
4768       so=real(sso)
4769       su=real(ssu)
4770       endif
4771       if(ssu.ge.sso)then
4772         print*,ssu,sso,dble(abs(dezzer))*ttaus*0.5d0
4773         stop'STOP: sr jtaug: ssu.ge.sso'
4774       endif
4775 
4776       g=1
4777 
4778       if(ttaus.le.ttau0)return
4779 
4780       ttp=tpro*ttaus
4781       zzp=zpro*ttaus
4782       ttt=ttar*ttaus
4783       zzt=ztar*ttaus
4784       ssp=ttaus*0.5d0*dlog((ttp+zzp)/(ttp-zzp))
4785       sst=ttaus*0.5d0*dlog((ttt+zzt)/(ttt-zzt))
4786 
4787       ssav=(ssu+sso)/2d0
4788       yyav=ssav/ttaus
4789       if(ssav.ge.ssp)yyav=detap
4790       if(ssav.le.sst)yyav=detat
4791 
4792       gg=0
4793       if(ssu.lt.sst)gg=gg + dcosh(detat-yyav) * (dmin1(sst,sso)-ssu)
4794       if(sso.gt.ssp)gg=gg + dcosh(detap-yyav) * (sso-dmax1(ssp,ssu))
4795       if(ssu.lt.ssp.and.sso.gt.sst)then
4796       ss1=dmax1(ssu,sst)
4797       ss2=dmin1(sso,ssp)
4798       gg=gg+ttaus*( dsinh(ss2/ttaus-yyav)-dsinh(ss1/ttaus-yyav) )
4799       endif
4800       gg=gg/(sso-ssu)
4801 
4802       hh=0
4803       if(ssu.lt.sst)hh=hh + dsinh(detat-yyav) * (dmin1(sst,sso)-ssu)
4804       if(sso.gt.ssp)hh=hh + dsinh(detap-yyav) * (sso-dmax1(ssp,ssu))
4805       if(ssu.lt.ssp.and.sso.gt.sst)then
4806       ss1=dmax1(ssu,sst)
4807       ss2=dmin1(sso,ssp)
4808       hh=hh+ttaus*( dcosh(ss2/ttaus-yyav)-dcosh(ss1/ttaus-yyav) )
4809       endif
4810       hh=hh/(sso-ssu)
4811 
4812       yyav=yyav+0.5d0*dlog((gg+hh)/(gg-hh))
4813 
4814       gg=0
4815       if(ssu.lt.sst)gg=gg + dcosh(detat-yyav) * (dmin1(sst,sso)-ssu)
4816       if(sso.gt.ssp)gg=gg + dcosh(detap-yyav) * (sso-dmax1(ssp,ssu))
4817       if(ssu.lt.ssp.and.sso.gt.sst)then
4818       ss1=dmax1(ssu,sst)
4819       ss2=dmin1(sso,ssp)
4820       gg=gg+ttaus*( dsinh(ss2/ttaus-yyav)-dsinh(ss1/ttaus-yyav) )
4821       endif
4822       gg=gg/(sso-ssu)
4823 
4824       g=sngl(gg)
4825       y=sngl(yyav)
4826       return
4827       end
4828 
4829 c-----------------------------------------------------------------------
4830       subroutine jtaui(s,ts,zs)
4831 c-----------------------------------------------------------------------
4832 c  returns time ts and coord zs corresponding to ttaus and inv. length s
4833 c-----------------------------------------------------------------------
4834 
4835       double precision tpro,zpro,ttar,ztar,ttaus,detap,detat
4836       common/cttaus/tpro,zpro,ttar,ztar,ttaus,detap,detat
4837       double precision ttau0
4838       common/cttau0/ttau0
4839 
4840       double precision ttp,zzp,ttt,zzt,ssp,sst,ss,zeta
4841 
4842       zs=s
4843       ts=sngl(ttaus)
4844 
4845       if(ttaus.le.ttau0)return
4846 
4847       ttp=tpro*ttaus
4848       zzp=zpro*ttaus
4849       ttt=ttar*ttaus
4850       zzt=ztar*ttaus
4851       ssp=ttaus*0.5d0*dlog((ttp+zzp)/(ttp-zzp))
4852       sst=ttaus*0.5d0*dlog((ttt+zzt)/(ttt-zzt))
4853       ss=dble(s)
4854 
4855            if(ss.le.sst)then
4856       zs=sngl(zzt+ttar*(ss-sst))
4857       ts=sngl(ttt+(dble(zs)-zzt)*zzt/ttt)
4858            elseif(ss.ge.ssp)then
4859       zs=sngl(zzp+tpro*(ss-ssp))
4860       ts=sngl(ttp+(dble(zs)-zzp)*zzp/ttp)
4861            else
4862       zeta=ss/ttaus
4863       ts=sngl(ttaus*dcosh(zeta))
4864       zs=sngl(ttaus*dsinh(zeta))
4865            endif
4866 
4867       return
4868       end
4869 
4870 c-----------------------------------------------------------------------
4871       subroutine jtauin
4872 c-----------------------------------------------------------------------
4873 c initializes equal time hyperbola at ttaus
4874 c-----------------------------------------------------------------------
4875       include 'epos.inc'
4876       double precision tpro,zpro,ttar,ztar,ttaus,detap,detat
4877       common/cttaus/tpro,zpro,ttar,ztar,ttaus,detap,detat
4878       double precision ttau0,rcproj,rctarg
4879       common/geom1/rcproj,rctarg
4880       common/cttau0/ttau0
4881 
4882       call utpri('jtauin',ish,ishini,6)
4883 
4884       if(ttaus.gt.ttau0)then
4885        if(rcproj.gt.1d-10)then
4886         detap=dmin1(dble((ypjtl-yhaha)*etafac),dlog(ttaus/rcproj))
4887        else
4888         detap=dble((ypjtl-yhaha)*etafac)
4889        endif
4890        if(rctarg.gt.1d-10)then
4891         detat=dmax1(dble(-yhaha*etafac),dlog(rctarg/ttaus))
4892        else
4893         detat=dble(-yhaha*etafac)
4894        endif
4895        tpro=dcosh(detap)
4896        zpro=dsinh(detap)
4897        ttar=dcosh(detat)
4898        ztar=dsinh(detat)
4899       else
4900        detap=0d0
4901        detat=0d0
4902        tpro=0d0
4903        zpro=0d0
4904        ttar=0d0
4905        ztar=0d0
4906       endif
4907 
4908       if(ish.ge.6)then
4909        write(ifch,*)'hyperbola at tau=',ttaus
4910        write(ifch,*)'r_p:',rcproj,' r_t:',rctarg
4911        write(ifch,*)'y_p:',detap,' y_t:',detat
4912        write(ifch,*)'t_p:',tpro,' z_p:',zpro
4913        write(ifch,*)'t_t:',ttar,' z_t:',ztar
4914       endif
4915 
4916       call utprix('jtauin',ish,ishini,6)
4917       return
4918       end
4919 
4920 c-----------------------------------------------------------------------
4921       subroutine jtaus(z,tz,sz)
4922 c-----------------------------------------------------------------------
4923 c  returns time tz and inv length sz corresponding to ttaus and z
4924 c-----------------------------------------------------------------------
4925       include 'epos.inc'
4926       double precision tpro,zpro,ttar,ztar,ttaus,detap,detat
4927       common/cttaus/tpro,zpro,ttar,ztar,ttaus,detap,detat
4928       double precision ttau0
4929       common/cttau0/ttau0
4930 
4931       double precision ttp,zzp,ttt,zzt,zz,tzz
4932 
4933       tz=sngl(ttaus)
4934       sz=z
4935 
4936       if(ttaus.le.ttau0)return
4937 
4938       ttp=tpro*ttaus
4939       zzp=zpro*ttaus
4940       ttt=ttar*ttaus
4941       zzt=ztar*ttaus
4942       zz=dble(z)
4943 
4944            if(zz.le.zzt)then
4945       tz=sngl(ttt+(zz-zzt)*zzt/ttt)
4946       sz=sngl(ttaus*detat+(zz-zzt)/ttar)
4947            elseif(zz.ge.zzp)then
4948       tz=sngl(ttp+(zz-zzp)*zzp/ttp)
4949       sz=sngl(ttaus*detap+(zz-zzp)/tpro)
4950            else
4951       if(sngl(ttaus).ge.ainfin)then
4952       tz=sngl(ttaus)
4953       sz=0.
4954       if(ish.ge.1)then
4955       call utmsg('jtaus')
4956       write(ifch,*)'*****  large ttaus; set tz=ttaus, sz=0'
4957       write(ifch,*)'ttaus=',ttaus,'zz=',zz
4958       call utmsgf
4959       endif
4960       else
4961       tzz=dsqrt(ttaus**2+zz**2)
4962       tz=sngl(tzz)
4963       sz=sngl(ttaus*0.5d0*dlog((tzz+zz)/(tzz-zz)))
4964       endif
4965            endif
4966 
4967       return
4968       end
4969 
4970 c-----------------------------------------------------------------------
4971       subroutine jtaux(t,z,ttaux)
4972 c-----------------------------------------------------------------------
4973 c  returns ttaux (-> tau-line) for given t and z.
4974 c  ttaux: double precision.
4975 c-----------------------------------------------------------------------
4976       double precision ttaux,tt,zz,rcproj,rctarg,zt1,zp1,zt2,zp2,ttau0
4977       common/geom1/rcproj,rctarg
4978       common/cttau0/ttau0
4979       double precision tpro,zpro,ttar,ztar,ttaus,detap,detat
4980       common/cttaus/   tpro,zpro,ttar,ztar,ttaus,detap,detat
4981 
4982       tt=dble(t)
4983       zz=dble(z)
4984 
4985       if(tt.gt.ttau0)then
4986        zt1=rctarg-tt
4987        zp1=tt-rcproj
4988        zt2=ztar/ttar*tt
4989        zp2=zpro/tpro*tt
4990        if(zz.le.dmax1(zt1,zt2))then
4991         if(zt1.gt.zt2)then
4992          ttaux=rctarg*dsqrt((tt-zz)/(2d0*rctarg-tt-zz))
4993         else
4994          ttaux=(ttar*tt-ztar*zz)/(ttar**2-ztar**2)
4995         endif
4996        elseif(zz.ge.dmin1(zp1,zp2))then
4997         if(zp1.lt.zp2)then
4998          ttaux=rcproj*dsqrt((tt+zz)/(2d0*rcproj-tt+zz))
4999         else
5000          ttaux=(tpro*tt-zpro*zz)/(tpro**2-zpro**2)
5001         endif
5002        else
5003         ttaux=dsqrt(tt**2-zz**2)
5004        endif
5005       else
5006        ttaux=tt
5007       endif
5008 
5009       return
5010       end
5011 
5012 c-----------------------------------------------------------------------
5013       subroutine xjden1(ii,itau,x,y,rad,o,u)
5014 c-----------------------------------------------------------------------
5015 c ii=0: initialization
5016 c ii=1: determining dense regions in space of individual events
5017 c       x,y,rad: tranverse coordinates and radius of particle i
5018 c       o,u: specifies long range: u < s < o (s: long coordinate)
5019 c ii=2: plot of individual event
5020 c       xpar1: itau ; valid: 1,..,10
5021 c       xpar2: z-range: -xpar2 < z < xpar2
5022 c       xpar3, x-range: -xpar3 < x < xpar3
5023 c       xpar4, y-range: -xpar4 < y < xpar4
5024 c-----------------------------------------------------------------------
5025       include "epos.inc"
5026       double precision tpro,zpro,ttar,ztar,ttaus,detap,detat
5027       common/cttaus/   tpro,zpro,ttar,ztar,ttaus,detap,detat
5028 
5029       if(idensi.ne.1)stop'STOP in xjden1: idensi must be set 1'
5030 
5031       dlcoox=0.5
5032       dlcooy=0.5
5033 
5034            if(ii.eq.0)then
5035 
5036       do i=1,nzeta
5037       do j=1,mxcoox
5038       do k=1,mxcooy
5039       kdensi(itau,i,j,k)=0
5040       enddo
5041       enddo
5042       enddo
5043 
5044            elseif(ii.eq.1)then
5045 
5046       if(itau.lt.1.or.itau.gt.mxtau)return
5047 
5048       tau=sngl(ttaus)
5049       zu=u/tau
5050       zo=o/tau
5051 
5052             do 1 i=1,nzeta
5053       zi=-nzeta*dlzeta/2-dlzeta/2+i*dlzeta
5054       if(zu.gt.zi.or.zo.lt.zi)goto1
5055       do 2 j=1,mxcoox
5056       xj=-mxcoox*dlcoox/2-dlcoox/2+j*dlcoox
5057       do 3 k=1,mxcooy
5058       yk=-mxcooy*dlcooy/2-dlcooy/2+k*dlcooy
5059       if((x-xj)**2+(y-yk)**2.gt.rad**2)goto3
5060       kdensi(itau,i,j,k)=1
5061     3 continue
5062     2 continue
5063     1 continue
5064 
5065            elseif(ii.eq.2)then
5066 
5067       itaux=nint(xpar1)
5068       if(itaux.gt.mxtau)stop'STOP in xjden1: itaux too large'
5069 
5070       iz=nint(xpar2/dlzeta)
5071       ix=nint(xpar3/dlcoox)
5072       iy=nint(xpar4/dlcooy)
5073       if(iz.gt.nzeta/2)stop'STOP in xjden1: zeta-range too large'
5074       if(ix.gt.mxcoox/2)stop'STOP in xjden1: x-range too large'
5075       if(iy.gt.mxcooy/2)stop'STOP in xjden1: y-range too large'
5076 
5077       do k=mxcooy/2+1-iy,mxcooy/2+iy
5078       write(ifhi,'(a,f7.2)')      '! tau: ',tauv(itaux)
5079       write(ifhi,'(a)')      'openhisto'
5080       write(ifhi,'(a,2f7.2)')'xrange',-iz*dlzeta,iz*dlzeta
5081       write(ifhi,'(a,2f7.2)')'yrange',-ix*dlcoox,ix*dlcoox
5082       write(ifhi,'(a)')      'set ityp2d 3'
5083       write(ifhi,'(a)') 'txt  "xaxis space-time rapidity [z]"'
5084       write(ifhi,'(a)') 'txt  "yaxis transverse coordinate x (fm)"'
5085       write(ifhi,'(a,i4)')   'array2d',2*iz
5086       do j=mxcoox/2+1-ix,mxcoox/2+ix
5087       write(ifhi,'(40i2)')    (kdensi(itaux,i,j,k),
5088      *                        i=nzeta/2+1-iz,nzeta/2+iz)
5089       enddo
5090       write(ifhi,'(a)')       '  endarray'
5091       write(ifhi,'(a)')       'closehisto plot2d'
5092       enddo
5093 
5094            else
5095 
5096       stop'STOP in xjden1: wrong option'
5097 
5098            endif
5099 
5100       return
5101       end
5102 
5103 c-----------------------------------------------------------------------
5104       subroutine xjden2(ii,itau,x,y,rad,s)
5105 c-----------------------------------------------------------------------
5106 c ii=0: initialization
5107 c ii=1: determining dense regions in space of individual events
5108 c       x,y,rad: tranverse coordinates and radius of particle i
5109 c       s: long coordinate
5110 c ii=2: plot of individual event
5111 c       xpar1: itau ; valid: 1,..,10
5112 c       xpar2: s-range: -xpar2 < s < xpar2
5113 c       xpar3, x-range: -xpar3 < x < xpar3
5114 c       xpar4, y-range: -xpar4 < y < xpar4
5115 c-----------------------------------------------------------------------
5116       include "epos.inc"
5117       double precision tpro,zpro,ttar,ztar,ttaus,detap,detat
5118       common/cttaus/   tpro,zpro,ttar,ztar,ttaus,detap,detat
5119       parameter (mxcoos=60)
5120       common/cdensh/kdensh(matau,mxcoos,mxcoox,mxcooy),ktot(matau)
5121       character cy*3
5122 
5123       dlcoox=0.5
5124       dlcooy=0.5
5125       dlcoos=0.5
5126 
5127            if(ii.eq.0)then
5128 
5129       do i=1,mxcoos
5130       do j=1,mxcoox
5131       do k=1,mxcooy
5132       kdensh(itau,i,j,k)=0
5133       enddo
5134       enddo
5135       enddo
5136       ktot(itau)=0
5137 
5138            elseif(ii.eq.1)then
5139 
5140       if(itau.lt.1.or.itau.gt.mxtau)return
5141 
5142       tau=sngl(ttaus)
5143       z=s/tau
5144 
5145       do 1 i=1,mxcoos
5146       si=-mxcoos*dlcoos/2-dlcoos/2+i*dlcoos
5147       do 2 j=1,mxcoox
5148       xj=-mxcoox*dlcoox/2-dlcoox/2+j*dlcoox
5149       do 3 k=1,mxcooy
5150       yk=-mxcooy*dlcooy/2-dlcooy/2+k*dlcooy
5151       if(((x-xj)**2+(y-yk)**2+(z-si)**2).gt.rad**2)goto3
5152       kdensh(itau,i,j,k)=kdensh(itau,i,j,k)+1
5153       ktot(itau)=ktot(itau)+1
5154     3 continue
5155     2 continue
5156     1 continue
5157 
5158            elseif(ii.eq.2)then
5159 
5160       itaux=nint(xpar1)
5161       if(itaux.gt.mxtau)stop'STOP in xjden2: itaux too large'
5162 
5163       is=nint(xpar2/dlcoos)
5164       ix=nint(xpar3/dlcoox)
5165       iy=nint(xpar4/dlcooy)
5166       if(is.gt.mxcoos/2)stop'STOP in xjden2: s-range too large'
5167       if(ix.gt.mxcoox/2)stop'STOP in xjden2: x-range too large'
5168       if(iy.gt.mxcooy/2)stop'STOP in xjden2: y-range too large'
5169 
5170       do k=mxcooy/2+1-iy,mxcooy/2+iy
5171       write(cy,'(f3.1)')-mxcooy*dlcooy/2-dlcooy/2+k*dlcooy
5172       write(ifhi,'(a)')      'openhisto'
5173       write(ifhi,'(a,2f7.2)')'xrange',-is*dlcoos,is*dlcoos
5174       write(ifhi,'(a,2f7.2)')'yrange',-ix*dlcoox,ix*dlcoox
5175       write(ifhi,'(a)')      'set ityp2d 5'
5176       write(ifhi,'(a)') 'txt  "xaxis [z] "'
5177       write(ifhi,'(a)')
5178      *'txt  "yaxis  x (fm), y='//cy//' fm"'
5179       write(ifhi,'(a,i4)')   'array2d',2*is
5180       do j=mxcoox/2+1-ix,mxcoox/2+ix
5181       do i=mxcoos/2+1-is,mxcoos/2+is
5182       write(ifhi,'(e11.3)')
5183      *kdensh(itaux,i,j,k)/dlcooy/dlcoos/dlcoox/ktot(itaux)
5184       enddo
5185       enddo
5186       write(ifhi,'(a)')       '  endarray'
5187       write(ifhi,'(a)')       'closehisto plot2d'
5188       enddo
5189 
5190            else
5191 
5192       stop'STOP in xjden2: wrong option'
5193 
5194            endif
5195 
5196       return
5197       end
5198 
5199 cc-----------------------------------------------------------------------
5200 c      subroutine postscript(iii,ii,ic)
5201 cc-----------------------------------------------------------------------
5202 c      include 'epos.inc'
5203 c      character*10 color(10)
5204 c      if(iii.eq.0)then
5205 c      ifps=21
5206 c      open(unit=ifps,file='zzz.ps',status='unknown')
5207 c      WRITE(ifps,'(a)') '%!PS-Adobe-2.0'
5208 c      WRITE(ifps,'(a)') '%%Title: tt2.fig'
5209 c      WRITE(ifps,'(a)') '%%Orientation: Portrait'
5210 c      WRITE(ifps,'(a)') '%%BeginSetup'
5211 c      WRITE(ifps,'(a)') '%%IncludeFeature: *PageSize A4'
5212 c      WRITE(ifps,'(a)') '%%EndSetup'
5213 c      WRITE(ifps,'(a)') '%%EndComments'
5214 c      WRITE(ifps,*) '/l {lineto} bind def'
5215 c      WRITE(ifps,*) '/rl {rlineto} bind def'
5216 c      WRITE(ifps,*) '/m {moveto} bind def'
5217 c      WRITE(ifps,*) '/rm {rmoveto} bind def'
5218 c      WRITE(ifps,*) '/s {stroke} bind def'
5219 c      WRITE(ifps,*) '/gr {grestore} bind def'
5220 c      WRITE(ifps,*) '/gs {gsave} bind def'
5221 c      WRITE(ifps,*) '/cp {closepath} bind def'
5222 c      WRITE(ifps,*) '/tr {translate} bind def'
5223 c      WRITE(ifps,*) '/sc {scale} bind def'
5224 c      WRITE(ifps,*) '/sd {setdash} bind def'
5225 c      WRITE(ifps,*) '/sdo {[.01 .05] 0 sd} bind def'
5226 c      WRITE(ifps,*) '/sdf {[1 .0] 0 sd} bind def'
5227 c      WRITE(ifps,*) '/n {newpath} bind def'
5228 c      WRITE(ifps,*) '/slw {setlinewidth } bind def'
5229 c      write(ifps,*) '/srgb {setrgbcolor} bind def'
5230 c      write(ifps,*) '/lgrey      { 0 0.95 0.95 srgb} bind def'
5231 c      write(ifps,*) '/black      { 0 0 0 srgb} bind def'
5232 c      write(ifps,*) '/red        { 1 0 0 srgb} bind def  '
5233 c      write(ifps,*) '/green      { 0 1 0  srgb} bind def  '
5234 c      write(ifps,*) '/blue       { 0 0 1  srgb} bind def  '
5235 c      write(ifps,*) '/yellow     { 1 0.5 0  srgb} bind def  '
5236 c      write(ifps,*) '/turquoise  { 0 1 1  srgb} bind def  '
5237 c      write(ifps,*) '/purple     { 1 0 1  srgb} bind def  '
5238 cc      write(ifps,*) '/  {   srgb} bind def  '
5239 cc      write(ifps,*) '/  {   srgb} bind def  '
5240 c      write(ifps,*) '/ef {eofill} bind def'
5241 c      WRITE(ifps,'(a)') '%%EndProlog'
5242 c      WRITE(ifps,*) 'gsave'
5243 c      WRITE(ifps,*) '/Helvetica findfont 10 scalefont setfont'
5244 c      color(9)='lgrey     '
5245 c      color(1)='black     '
5246 c      color(2)='red       '
5247 c      color(3)='green     '
5248 c      color(4)='blue      '
5249 c      color(7)='yellow    '
5250 c      color(5)='turquoise '
5251 c      color(6)='purple    '
5252 c      np=0
5253 c         elseif(iii.eq.1)then
5254 c      np=np+1
5255 c      write(ifps,'(a,i4)') '%%Page: number ',np
5256 c      write(ifps,'(a)') 'gsave'
5257 c      WRITE(ifps,*) '100 700 tr'
5258 c      scale=0.125
5259 c      WRITE(ifps,*) 1./scale,1./scale,' sc'
5260 c      WRITE(ifps,*) scale/2.,' slw'
5261 c      WRITE(ifps,*) '/Helvetica findfont ',15.*scale
5262 c     &     ,' scalefont setfont'
5263 c      write(ifps,*) color(1),' n ',smin,xmin,' m ( tau:',tau,') show '
5264 c
5265 c      WRITE(ifps,*) '/Helvetica findfont ',5.*scale
5266 c     &     ,' scalefont setfont'
5267 c
5268 c
5269 c      yb=-2.
5270 c      dy=4./12.
5271 c      yb=yb-dy/2
5272 c      do iyb=0,11
5273 c        yb=yb+dy
5274 c        WRITE(ifps,*) 'gsave'
5275 c        WRITE(ifps,*) (xmax-xmin)*1.1*float(int(iyb/4))
5276 c     &       ,-(xmax-xmin)*1.1*mod(iyb,4),' tr'
5277 c        write(ifps,*) ' n ',smin,xmin,' m ',smax,xmin,' l '
5278 c     &       ,smax,xmax,' l ',smin,xmax,' l cp s '
5279 cc.......particles in layer iyb.............
5280 c        do i=1,nptl
5281 c          if(ii.gt.0)then
5282 c              write(ifps,*)  color(mod(i,5)+2)
5283 c     &             ,' n ',u,x-r,' m ',o,x-r,' l '
5284 c     &             ,o,x+r,' l ',u,x+r,' l cp s '
5285 c              write(ifps,*) ' n ',u,x-r,' m (',i,ior,') show '
5286 c          else
5287 c              write(ifps,*) ' n ',s,x,r,0,360,' arc ',color(ic),' s '
5288 c              write(ifps,*) ' n ',s-r,x,' m (',i,io,') show '
5289 c          endif
5290 c 10     enddo
5291 c        write(ifps,*) color(1),' n ',smin,xmin,' m (',yb,') show '
5292 c        WRITE(ifps,*) 'grestore'
5293 c      enddo                    !yb bin
5294 c      write(ifps,'(a)') 'grestore'
5295 c      write(ifps,*) 'showpage'
5296 c          elseif(iii.eq.2)then
5297 c       write(ifps,*) 'gr'
5298 c
5299 c       write(ifps,'(a)') '%%Trailer'
5300 c       write(ifps,'(a,i4)') '%%Pages: ',np
5301 c       write(ifps,'(a)') '%%EOF'
5302 c       close(unit=ifps)
5303 c          endif
5304 c
5305 c      return
5306 c      end
5307 c
5308 
5309 c------------------------------------------------------------------------------
5310       subroutine xtauev(iii)
5311 c------------------------------------------------------------------------------
5312       jdum=iii
5313       end
5314 c------------------------------------------------------------------------------
5315       subroutine wimi
5316 c------------------------------------------------------------------------------
5317       end
5318 c------------------------------------------------------------------------------
5319       subroutine wimino
5320 c------------------------------------------------------------------------------
5321       end
5322 c------------------------------------------------------------------------------
5323       subroutine xspace(iii)
5324 c------------------------------------------------------------------------------
5325       jdum=iii
5326       end
5327 c------------------------------------------------------------------------------
5328       subroutine wclu
5329 c------------------------------------------------------------------------------
5330       end
5331 c------------------------------------------------------------------------------
5332       subroutine wclufi
5333 c------------------------------------------------------------------------------
5334       end
5335 c------------------------------------------------------------------------------
5336       subroutine wtime(iii)
5337 c------------------------------------------------------------------------------
5338       jdum=iii
5339       end