File indexing completed on 2024-04-06 12:14:09
0001
0002
0003
0004
0005
0006
0007
0008
0009
0010
0011
0012
0013
0014
0015
0016
0017
0018
0019
0020
0021
0022
0023
0024
0025
0026
0027
0028
0029
0030
0031
0032
0033
0034
0035
0036
0037
0038
0039
0040
0041
0042
0043
0044
0045
0046
0047
0048
0049
0050
0051
0052
0053
0054
0055
0056
0057
0058
0059
0060
0061
0062
0063 subroutine qgset
0064
0065
0066
0067 implicit double precision (a-h,o-z)
0068 integer debug
0069 character*7 ty
0070 character*2 tyq
0071 parameter(iapmax=208)
0072 common /qgarr1/ ia(2),icz,icp
0073 common /qgarr2/ scm,wp0,wm0
0074 common /qgarr3/ rmin,emax,eev
0075 common /qgarr6/ pi,bm,amws
0076 common /qgarr7/ xa(iapmax,3),xb(iapmax,3),b
0077 common /qgarr8/ wwm,be(4),dc(5),deta,almpt,ptdif,ptndi
0078 common /qgarr10/ am0,amn,amk,amc,amlamc,amlam,ameta,ammu
0079 common /qgarr11/ b10
0080 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
0081 common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
0082 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
0083 common /qgarr18/ alm,qt0,qtf,betp,dgqq
0084 common /qgarr19/ ahl(3)
0085 common /qgarr20/ spmax
0086 common /qgarr21/ dmmin(3),wex(3),dmres(3),wdres(3)
0087 common /qgarr28/ arr(5)
0088 common /qgarr26/ factk,fqscal
0089 common /qgarr41/ ty(6)
0090 common /qgarr42/ tyq(16)
0091 common /qgarr43/ moniou
0092 common /qgarr51/ epsxmn
0093 common /opt/ jopt
0094 common /qgdebug/ debug
0095 common /qgsIInex1/xan(iapmax,3),xbn(iapmax,3) !used to link with nexus
0096 *,bqgs,bmaxqgs,bmaxnex,bminnex
0097
0098 moniou=6 !output channel for debugging
0099 debug=0 !debugging level
0100 !(0 - no debugging, 1 - very geheral,
0101 !2 - more detailed, 3 - all function calls,
0102 !4 - all returned values, 5 - technical)
0103 if(debug.ge.1)write (moniou,210)
0104
0105 bqgs=0.d0 !used to link with nexus
0106 bmaxqgs=0.d0 !used to link with nexus
0107 bmaxnex=-1.d0 !used to link with nexus
0108 bminnex=0.d0 !used to link with nexus
0109
0110 jopt=1 !parameter option
0111
0112 if(jopt.eq.1)then !tunable parameters
0113
0114 dels=.165d0 !overcriticality
0115 alfp=.135d0 !trajectory slope
0116 sigs=1.01d0 !soft parton cross section
0117
0118 qt0=3.d0 !q**2 cutoff
0119 betp=2.2d0 !gluon distribution hardness for soft Pomeron
0120 dgqq=.16d0 !sea quark/gluon relative weight
0121
0122 r3p=.0076d0 !triple-Pomeron coupling (/4/pi)
0123 g3p=.35d0 !factor for multu-Pomeron couplings
0124 sgap=exp(1.5d0) !minimal rap-gap between 3P-vertices
0125
0126 rq(1,1)=1.d0 !pion: vertex slope for 1st diffr. eigenst.
0127 rq(2,1)=.15d0 !pion: vertex slope for 2nd diffr. eigenst.
0128 cd(1,1)=1.75d0 !pion: relat. strenth for 1st diffr. eigenst.
0129 rq(1,2)=2.52d0 !proton: vertex slope for 1st diffr. eigenst.
0130 rq(2,2)=.2d0 !proton: vertex slope for 2nd diffr. eigenst.
0131 cd(1,2)=1.58d0 !proton: relat. strenth for 1st diffr. eigenst.
0132 rq(1,3)=.75d0 !kaon: vertex slope for 1st diffr. eigenst.
0133 rq(2,3)=.15d0 !kaon: vertex slope for 2nd diffr. eigenst.
0134 cd(1,3)=1.75d0 !kaon: relat. strenth for 1st diffr. eigenst.
0135
0136
0137
0138 qtf=.15d0 !q**2 cutoff for timelike cascades
0139 almpt=1.5d0 !string fragmentation parameter
0140 wwm=1.d0 !switching to 2-particle string decay (threshold)
0141
0142 ahl(1)=0.d0 !pion
0143 ahl(2)=1.3d0 !proton
0144 ahl(3)=-0.5 !kaon
0145
0146 wex(1)=.5d0 !pion
0147 wex(2)=.4d0 !proton
0148 wex(3)=.5d0 !kaon
0149
0150 dc(1)=.077d0 !udu~d~
0151 dc(2)=.08d0 !ss~
0152 dc(4)=.4d0 !ss~ (intrinsic)
0153
0154 be(1)=.225d0 !uu~(dd~)
0155 be(2)=.43d0 !qqq~q~
0156 be(3)=.48d0 !ss~
0157 ptdif=.15d0 !diffractive momentum transfer
0158 ptndi=.19d0 !non-diffractive momentum transfer
0159
0160
0161
0162 rmin=3.35d0 !coupling radius squared (fm^2)
0163 emax=.11d0 !relative critical energy ( / <E_ex>, <E_ex>~12.5 MeV )
0164 eev=.25d0 !relative evaporation energy ( / <E_ex>, <E_ex>~12.5 MeV )
0165
0166 else
0167 stop'wrong option!!!'
0168 endif
0169
0170 do i=1,3 !relative strenth of 2nd diffr. eigenst. [2-CD(1,icz)]
0171 cd(2,i)=2.d0-cd(1,i)
0172 enddo
0173
0174 !other parameters and constants:
0175
0176 spmax=1.d11 !max energy squared for tabulations
0177 delh=0.25d0 !effective exponent for weighting (technical)
0178 epsxmn=.01d0 !pt-resolution scale (technical)
0179 alm=.04d0 !lambda_qcd squared
0180 factk=1.5d0 !k-factor value
0181 fqscal=4.d0 !factor for fact. scale (Mf^2=p_t^2/fqscal)
0182 deta=.11111d0 !ratio of etas production to all pions (1/9)
0183 dc(3)=.000d0 !to switch off charmed particles set to 0.000
0184 dc(5)=.0d0 !to switch off charmed particles set to 0.000
0185
0186 cc(1,1)=.5d0 !pion
0187 cc(2,1)=.5d0
0188 cc(1,2)=.5d0 !proton
0189 cc(2,2)=.5d0
0190 cc(1,3)=.5d0 !kaon
0191 cc(2,3)=.5d0
0192
0193 b10=.43876194d0 !initial value of the pseudorandom sequence
0194 pi=3.1416d0 !pi-value
0195 amws=.523d0 !diffusive radius for saxon-wood density
0196
0197 arr(1)=0.5d0 !qq~-trajectory
0198 arr(2)=-0.5d0 !qqq~q~-trajectory
0199 arr(3)=0.d0 !us~-trajectory
0200
0201 dmmin(1)=.76d0 !rho
0202 dmmin(2)=1.23d0 !delta
0203 dmmin(3)=.89d0 !K*
0204
0205 dmres(1)=1.23d0 !pion
0206 dmres(2)=1.44d0 !proton
0207 dmres(3)=1.27d0 !kaon
0208 wdres(1)=.3d0 !pion
0209 wdres(2)=.3d0 !proton
0210 wdres(3)=.1d0 !kaon
0211
0212 amn=0.93827999
0213 amk=.496d0
0214 am0=.14d0
0215 amc=1.868d0
0216 amlam=1.116d0
0217 amlamc=2.27d0
0218 ameta=.548d0
0219 ammu=.1057d0
0220
0221 ty(1)='pion '
0222 ty(2)='nucleon'
0223 ty(3)='kaon '
0224
0225 tyq(1)='DD'
0226 tyq(2)='UU'
0227 tyq(3)='C '
0228 tyq(4)='S '
0229 tyq(5)='UD'
0230 tyq(6)='D '
0231 tyq(7)='U '
0232 tyq(8)='g '
0233 tyq(9)='u '
0234 tyq(10)='d '
0235 tyq(11)='ud'
0236 tyq(12)='s '
0237 tyq(13)='c '
0238 tyq(14)='uu'
0239 tyq(15)='dd'
0240 if(debug.ge.2)write (moniou,202)
0241
0242 210 format(2x,'qgset - common model parameters setting')
0243 202 format(2x,'qgset - end')
0244 return
0245 end
0246
0247
0248 subroutine qgaini( DATDIR )
0249
0250
0251
0252 implicit double precision (a-h,o-z)
0253 CHARACTER DATDIR*(132)
0254 real qggamfun
0255 integer debug
0256 character *7 ty
0257 logical lcalc
0258 parameter(iapmax=208)
0259 dimension mij(40,40,4),nij(40,40,4),cs1(40,40,160)
0260 *,evs(40,100,3,2),ixemax(40,3,2),gz0(5),gz1(3)
0261 *,qfan0(11,14),qfan2(11,11,3),fann(14)
0262 common /qgarr1/ ia(2),icz,icp
0263 common /qgarr2/ scm,wp0,wm0
0264 common /qgarr5/ rnuc(2),wsnuc(2),wbnuc(2),anorm
0265 *,cr1(2),cr2(2),cr3(2)
0266 common /qgarr6/ pi,bm,amws
0267 common /qgarr10/ am(7),ammu
0268 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
0269 common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
0270 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
0271 common /qgarr18/ alm,qt0,qtf,betp,dgqq
0272 common /qgarr19/ ahl(3)
0273 common /qgarr20/ spmax
0274 common /qgarr24/ qpomr(11,11,216,12,2)
0275 common /qgarr25/ ahv(3)
0276 common /qgarr26/ factk,fqscal
0277 common /qgarr27/ qlegi(51,11,2,3,7),qfanu(51,11,11,6,2)
0278 *,qfanc(51,11,11,39,18),qdfan(21,11,11,2,3),qrev(11,11,66,219,2)
0279 common /qgarr28/ arr(5)
0280 common /qgarr29/ cstot(40,40,160)
0281 common /qgarr30/ cs0(40,40,160)
0282 common /qgarr31/ csborn(40,160)
0283 common /qgarr33/ fsud(10,2)
0284 common /qgarr34/ qrt(10,101,2)
0285 common /qgarr35/ qlegc0(51,10,11,6,8),qlegc(51,10,11,11,30)
0286 common /qgarr38/ qpomc(11,100,11,11,48)
0287 common /qgarr39/ qpomi(51,11,15),qpomis(51,11,11,11,9)
0288 common /qgarr41/ ty(6)
0289 common /qgarr43/ moniou
0290 common /qgarr47/ gsect(10,5,6)
0291 common /qgarr48/ qgsasect(10,6,6)
0292 common /qgarr51/ epsxmn
0293 common /qgarr52/ evk(40,40,100,3,2)
0294
0295 common /arr1/ trnuc(56),twsnuc(56),twbnuc(56)
0296 common /arr3/ x1(7),a1(7)
0297 common /opt/ jopt
0298 common /qgdebug/debug
0299 character*500 fnIIdat,fnIIncs !used to link with nexus
0300 common /version/ version !used to link with nexus
0301 common/qgsIIfname/fnIIdat, fnIIncs, ifIIdat, ifIIncs !used to link with nexus
0302 common/qgsIInfname/ nfnIIdat, nfnIIncs !used to link with nexus
0303 common/producetab/ producetables !used to link with CRMC
0304 logical producetables
0305
0306 if(debug.ge.1)write (moniou,210)
0307 version = 204
0308
0309
0310 write(*,100)
0311 100 format(' ',
0312 * '====================================================',
0313 * /,' ','| |',
0314 * /,' ','| QUARK GLUON STRING JET -II MODEL |',
0315 * /,' ','| |',
0316 * /,' ','| HADRONIC INTERACTION MONTE CARLO |',
0317 * /,' ','| BY |',
0318 * /,' ','| S. OSTAPCHENKO |',
0319 * /,' ','| |',
0320 * /,' ','| e-mail: sergei@tf.phys.ntnu.no |',
0321 * /,' ','| |',
0322 * /,' ','| Version II-04 |',
0323 * /,' ','| |',
0324 * /,' ','| Publication to be cited when using this program: |',
0325 * /,' ','| S.Ostapchenko, PRD 83 (2011) 014018 |',
0326 * /,' ','| |',
0327 * /,' ','| last modification: 26.06.2012 |',
0328 * /,' ','| |',
0329 * /,' ','| Any modification has to be approved by the author|',
0330 * /,' ','====================================================',
0331 * /)
0332
0333
0334
0335
0336 rr=qggamfun(real(2.d0+betp-dels))/qggamfun(real(1.d0-dels))
0337 */qggamfun(real(1.d0+betp))/4.d0/pi
0338
0339 ahv(1)=.383d0+.624d0*dlog(dlog(qt0/.204d0**2)
0340 */dlog(.26d0/.204d0**2))
0341 ahv(3)=ahv(1)
0342 sq=dlog(dlog(qt0/.232d0**2)/dlog(.23d0/.232d0**2))
0343 ahv(2)=2.997d0+.753d0*sq-.076d0*sq*sq
0344
0345 qnorm1=0.d0
0346 do i=1,7
0347 do m=1,2
0348 tp=1.d0-(.5d0+x1(i)*(m-1.5d0))**(2.d0/3.d0)
0349 xp=1.d0-tp**(1.d0/(1.d0+ahv(1)))
0350 qnorm1=qnorm1+a1(i)*(qggrv(xp,qt0,1,1)+qggrv(xp,qt0,1,2))
0351 * /dsqrt(1.d0-tp)
0352 enddo
0353 enddo
0354 qnorm1=qnorm1/(1.d0+ahv(1))/3.d0
0355 qnorm2=0.d0
0356 do i=1,7
0357 do m=1,2
0358 tp=1.d0-(.5d0+x1(i)*(m-1.5d0))**(2.d0/3.d0)
0359 xp=1.d0-tp**(1.d0/(1.d0+ahv(2)))
0360 qnorm2=qnorm2+a1(i)*(qggrv(xp,qt0,2,1)+qggrv(xp,qt0,2,2))
0361 * /dsqrt(1.d0-tp)
0362 enddo
0363 enddo
0364 qnorm2=qnorm2/(1.d0+ahv(2))/3.d0
0365
0366 fp(2)=(1.d0-qnorm2)*(2.d0+ahl(2))*(1.d0+ahl(2))
0367
0368 gnorm=0.d0
0369 seanrm=0.d0
0370 do i=1,7
0371 do m=1,2
0372 xxg=(.5d0+x1(i)*(m-1.5d0))**(1.d0/(1.d0-dels))
0373 gnorm=gnorm+a1(i)*qgftld(xxg,2)
0374 seanrm=seanrm+a1(i)*qgftle(xxg,2)
0375 enddo
0376 enddo
0377 gnorm=gnorm/(1.d0-dels)*fp(2)*rr*2.d0*pi
0378 seanrm=seanrm/(1.d0-dels)*fp(2)*rr*2.d0*pi
0379 if(debug.ge.1)write (moniou,*)'rr,fp,norm,qnorm2,gnorm,seanrm'
0380 *,rr,fp(2),qnorm2+gnorm+seanrm,qnorm2,gnorm,seanrm
0381
0382 do icz=1,3,2
0383 fp(icz)=(1.d0-qnorm1)*(2.d0+ahl(icz))*(1.d0+ahl(icz))
0384 gnorm=0.d0
0385 seanrm=0.d0
0386 do i=1,7
0387 do m=1,2
0388 xxg=(.5d0+x1(i)*(m-1.5d0))**(1.d0/(1.d0-dels))
0389 gnorm=gnorm+a1(i)*qgftld(xxg,icz)
0390 seanrm=seanrm+a1(i)*qgftle(xxg,icz)
0391 enddo
0392 enddo
0393 gnorm=gnorm/(1.d0-dels)*fp(icz)*rr*2.d0*pi
0394 seanrm=seanrm/(1.d0-dels)*fp(icz)*rr*2.d0*pi
0395
0396 if(debug.ge.1)write (moniou,*)'fp,norm,qnorm1,gnorm,seanrm'
0397 * ,fp(icz),qnorm1+gnorm+seanrm,qnorm1,gnorm,seanrm
0398 enddo
0399
0400 do icz=1,3
0401 gsoft(icz)=fp(icz)*fp(2)*sigs*4.d0*.0389d0
0402 * *qggamfun(real(1.d0+dels))**2*qggamfun(real(1.d0+ahl(icz)))
0403 * *qggamfun(real(1.d0+ahl(2)))/qggamfun(real(2.d0+dels+ahl(icz)))
0404 * /qggamfun(real(2.d0+dels+ahl(2)))
0405 enddo
0406
0407
0408
0409 if(ifIIdat.ne.1)then
0410 inquire(file=DATDIR(1:INDEX(DATDIR,' ')-1)//'qgsdat-II-04'
0411 * ,exist=lcalc)
0412 else
0413 inquire(file=fnIIdat(1:nfnIIdat),exist=lcalc) !used to link with nexus
0414 endif
0415 lzmaUse=0
0416 if(lcalc)then
0417 if(ifIIdat.ne.1)then
0418 open(1,file=DATDIR(1:INDEX(DATDIR,' ')-1)//'qgsdat-II-04'
0419 * ,status='old')
0420 else !used to link with nexus
0421 if (LEN(fnIIdat).gt.6.and.
0422 * fnIIdat(nfnIIdat-4:nfnIIdat) .eq. ".lzma") then
0423 lzmaUse=1
0424 call LzmaOpenFile(fnIIdat(1:nfnIIdat))
0425 else
0426 open(ifIIdat,file=fnIIdat(1:nfnIIdat),status='old')
0427 endif
0428 endif
0429
0430 if (lzmaUse.ne.0) then
0431
0432 if(debug.ge.0)write (moniou,214) 'qgsdat-II-04.lzma'
0433
0434 call LzmaFillArray(csborn,size(csborn))
0435 call LzmaFillArray(cs0,size(cs0))
0436 call LzmaFillArray(cstot,size(cstot))
0437 call LzmaFillArray(evk,size(evk))
0438 call LzmaFillArray(qpomi,size(qpomi))
0439 call LzmaFillArray(qpomis,size(qpomis))
0440 call LzmaFillArray(qlegi,size(qlegi))
0441 call LzmaFillArray(qfanu,size(qfanu))
0442 call LzmaFillArray(qfanc,size(qfanc))
0443 call LzmaFillArray(qdfan,size(qdfan))
0444 call LzmaFillArray(qpomr,size(qpomr))
0445 call LzmaFillArray(gsect,size(gsect))
0446 call LzmaFillArray(qlegc0,size(qlegc0))
0447 call LzmaFillArray(qlegc,size(qlegc))
0448 call LzmaFillArray(qpomc,size(qpomc))
0449 call LzmaFillArray(fsud,size(fsud))
0450 call LzmaFillArray(qrt,size(qrt))
0451 call LzmaFillArray(qrev,size(qrev))
0452 call LzmaFillArray(fsud,size(fsud))
0453 call LzmaFillArray(qrt,size(qrt))
0454 call LzmaCloseFile()
0455 else
0456 if(debug.ge.0)write (moniou,214) 'qgsdat-II-04'
0457 read (1,*)csborn,cs0,cstot,evk,qpomi,qpomis,qlegi,qfanu,qfanc
0458 * ,qdfan,qpomr,gsect,qlegc0,qlegc,qpomc,fsud,qrt,qrev,fsud,
0459 * qrt
0460 close(1)
0461 endif
0462
0463 if(debug.ge.0)write (moniou,*)'done'
0464 goto 10
0465 elseif(.not.producetables)then
0466 write(moniou,*) "Missing QGSDAT-II-04 file !"
0467 write(moniou,*) "Please correct the defined path ",
0468 &"or force production ..."
0469 stop
0470 endif
0471
0472
0473
0474
0475 if(debug.ge.0)write (moniou,201)
0476 do i=1,40
0477 do m=1,3
0478 do k=1,2
0479 ixemax(i,m,k)=99
0480 do j=1,40
0481 do l=1,100
0482 evk(i,j,l,m,k)=0.d0
0483 enddo
0484 enddo
0485 enddo
0486 enddo
0487 enddo
0488
0489 n=1
0490 1 n=n+1
0491 do m=1,3
0492 do k=1,2
0493 if(m.ne.3.or.k.ne.1)then
0494 do i=1,39
0495 if(ixemax(i,m,k).gt.0)then
0496 qi=spmax**((i-1)/39.d0)
0497 qq=qi*(spmax/qi)**(1.d0/39.d0)
0498 do l=1,99
0499 if(l.le.37)then
0500 xx=.1d0/(.1d0*spmax)**((37.d0-l)/36.d0)
0501 elseif(l.le.69)then
0502 xx=.1d0+.8d0*(l-37.d0)/32.d0
0503 else
0504 xx=1.d0-.1d0*(10.d0*epsxmn)**((l-69.d0)/31.d0)
0505 endif
0506
0507 ev=qgev(qi,qq,qq,xx,m,k)/qgfap(xx,m,k)
0508 if(m.eq.1.and.k.eq.1.or.m.ne.1.and.k.ne.1)then
0509 evs(i,l,m,k)=dlog(1.d0+ev*4.5d0*qgsudx(qi,m)/qgsudx(qq,m)
0510 * /dlog(dlog(qq/alm)/dlog(qi/alm)))
0511 else
0512 evs(i,l,m,k)=dlog(1.d0+ev/.3d0*(dlog(epsxmn)+.75d0)
0513 * /(qgsudx(qq,1)/qgsudx(qi,1)-qgsudx(qq,2)/qgsudx(qi,2)))
0514 endif
0515 enddo
0516 endif
0517 enddo
0518 endif
0519 enddo
0520 enddo
0521
0522 jec=0
0523 do m=1,3
0524 do k=1,2
0525 if(m.ne.3.or.k.ne.1)then
0526 do i=1,39
0527 if(ixemax(i,m,k).gt.0)then
0528 qi=spmax**((i-1)/39.d0)
0529 qq=qi*(spmax/qi)**(1.d0/39.d0)
0530 imx=ixemax(i,m,k)
0531 do l=imx,1,-1
0532 if(l.le.37)then
0533 xx=.1d0/(.1d0*spmax)**((37.d0-l)/36.d0)
0534 elseif(l.le.69)then
0535 xx=.1d0+.8d0*(l-37.d0)/32.d0
0536 else
0537 xx=1.d0-.1d0*(10.d0*epsxmn)**((l-69.d0)/31.d0)
0538 endif
0539
0540 if(abs(evs(i,l,m,k)-evk(i,2,l,m,k)).gt.1.d-3)then
0541 evk(i,2,l,m,k)=evs(i,l,m,k)
0542 jec=1
0543 elseif(ixemax(i,m,k).eq.l)then
0544 ixemax(i,m,k)=l-1
0545 endif
0546 enddo
0547 endif
0548 enddo
0549 endif
0550 enddo
0551 enddo
0552
0553 do i=1,39
0554 qi=spmax**((i-1)/39.d0)
0555 qj=qi*(spmax/qi)**(1.d0/39.d0)
0556 qq=qi*(spmax/qi)**(2.d0/39.d0)
0557 do l=99,1,-1
0558 if(l.le.37)then
0559 xx=.1d0/(.1d0*spmax)**((37.d0-l)/36.d0)
0560 elseif(l.le.69)then
0561 xx=.1d0+.8d0*(l-37.d0)/32.d0
0562 else
0563 xx=1.d0-.1d0*(10.d0*epsxmn)**((l-69.d0)/31.d0)
0564 endif
0565 do m=1,3
0566 do k=1,2
0567 if(m.ne.3.or.k.ne.1)then
0568 ev=(qgev(qi,qj,qq,xx,m,k)
0569 * +qgevi(qi,qj,xx,m,k)*qgsudx(qq,k)/qgsudx(qj,k)
0570 * +qgevi(qj,qq,xx,m,k)*qgsudx(qj,m)/qgsudx(qi,m))/qgfap(xx,m,k)
0571 if(m.eq.1.and.k.eq.1.or.m.ne.1.and.k.ne.1)then
0572 evk(i,3,l,m,k)=dlog(ev*4.5d0*qgsudx(qi,m)/qgsudx(qq,m)
0573 * /dlog(dlog(qq/alm)/dlog(qi/alm)))
0574 else
0575 evk(i,3,l,m,k)=dlog(ev/.3d0*(dlog(epsxmn)+.75d0)
0576 * /(qgsudx(qq,1)/qgsudx(qi,1)-qgsudx(qq,2)/qgsudx(qi,2)))
0577 endif
0578 endif
0579 enddo
0580 enddo
0581 enddo
0582 enddo
0583 if(jec.ne.0)goto 1
0584
0585 do i=1,39
0586 qi=spmax**((i-1)/39.d0)
0587 do j=4,40
0588 qj=qi*(spmax/qi)**((j-2)/39.d0)
0589 qq=qi*(spmax/qi)**((j-1)/39.d0)
0590 do l=99,1,-1
0591 if(l.le.37)then
0592 xx=.1d0/(.1d0*spmax)**((37.d0-l)/36.d0)
0593 elseif(l.le.69)then
0594 xx=.1d0+.8d0*(l-37.d0)/32.d0
0595 else
0596 xx=1.d0-.1d0*(10.d0*epsxmn)**((l-69.d0)/31.d0)
0597 endif
0598 do m=1,3
0599 do k=1,2
0600 if(m.ne.3.or.k.ne.1)then
0601 ev=(qgev(qi,qj,qq,xx,m,k)
0602 * +qgevi(qi,qj,xx,m,k)*qgsudx(qq,k)/qgsudx(qj,k)
0603 * +qgevi(qj,qq,xx,m,k)*qgsudx(qj,m)/qgsudx(qi,m))/qgfap(xx,m,k)
0604 if(m.eq.1.and.k.eq.1.or.m.ne.1.and.k.ne.1)then
0605 evk(i,j,l,m,k)=dlog(ev*4.5d0*qgsudx(qi,m)/qgsudx(qq,m)
0606 * /dlog(dlog(qq/alm)/dlog(qi/alm)))
0607 else
0608 evk(i,j,l,m,k)=dlog(ev/.3d0*(dlog(epsxmn)+.75d0)
0609 * /(qgsudx(qq,1)/qgsudx(qi,1)-qgsudx(qq,2)/qgsudx(qi,2)))
0610 endif
0611 endif
0612 enddo
0613 enddo
0614 enddo
0615 enddo
0616 enddo
0617
0618
0619
0620 do i=1,40
0621 qi=(spmax/4.d0/fqscal)**((i-1)/39.d0) !q^2 cutoff for born process
0622 s2min=qi*4.d0*fqscal !energy threshold for 2->2 subprocess
0623 do m=1,2 !parton types (1-g, 2-q)
0624 do l=1,2 !parton types (1-g, 2-q)
0625 l1=2*l-1
0626 do k=1,40
0627 sk=s2min*(spmax/s2min)**((k-1)/39.d0) !c.m. energy squared
0628 k1=k+40*(m-1)+80*(l-1)
0629 csborn(i,k1)=dlog(qgborn(qi,qi,sk,m-1,l1-1)) !born cross-section (2->2)
0630 if(.not.(csborn(i,k1).ge.0.d0.or.csborn(i,k1).lt.0.d0))stop
0631 enddo
0632 enddo
0633 enddo
0634 enddo
0635
0636 do i=1,40
0637 qi=(spmax/4.d0/fqscal)**((i-1)/39.d0)
0638 do j=1,40
0639 qj=qi*(spmax/4.d0/fqscal/qi)**((j-1)/39.d0)
0640 s2min=qj*4.d0*fqscal
0641 smin=s2min/(1.d0-epsxmn)
0642 do m=1,2
0643 do l=1,2
0644 l1=2*l-1
0645 ml=m+2*l-2
0646 do k=1,40
0647 sk=s2min*(spmax/s2min)**((k-1)/39.d0)
0648 k1=k+40*(m-1)+80*(l-1)
0649
0650 tmin=qj*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qj*fqscal/sk)))
0651 sjtot=qgjett(qi,qj,sk,m-1,l-1)
0652 sjord1=qgjeto(qi,qj,sk,m-1,l-1)
0653 sjord2=qgjeto(qj,qi,sk,l-1,m-1)
0654 born=qgborn(qi,qj,sk,m-1,l1-1)
0655 if(k.eq.1.or.j.eq.40.or.i.eq.40.or.sk.le.smin)then
0656 cstot(i,j,k1)=dlog(born)
0657 cs0(i,j,k1)=cstot(i,j,k1)
0658 else
0659 cstot(i,j,k1)=dlog(born+(sjtot+sjord1+sjord2)
0660 * /(1.d0/tmin-2.d0/sk))
0661 cs0(i,j,k1)=dlog(born+sjord1/(1.d0/tmin-2.d0/sk))
0662 endif
0663 if(.not.(cstot(i,j,k1).ge.0.d0.or.cstot(i,j,k1).lt.0.d0))stop
0664 if(.not.(cs0(i,j,k1).ge.0.d0.or.cs0(i,j,k1).lt.0.d0))stop
0665 enddo
0666 enddo
0667 enddo
0668 enddo
0669 enddo
0670 goto 3
0671
0672
0673
0674 do i=1,40
0675 qi=(spmax/4.d0/fqscal)**((i-1)/39.d0)
0676 do j=1,40
0677 qj=qi*(spmax/4.d0/fqscal/qi)**((j-1)/39.d0)
0678 s2min=qj*4.d0*fqscal
0679 do m=1,2
0680 do l=1,2
0681 l1=2*l-1
0682 ml=m+2*l-2
0683 do k=1,40
0684 sk=s2min*(spmax/s2min)**((k-1)/39.d0)
0685 k1=k+40*(m-1)+80*(l-1)
0686 cstot(i,j,k1)=dlog(qgborn(qi,qj,sk,m-1,l1-1))
0687 cs0(i,j,k1)=cstot(i,j,k1)
0688 mij(i,j,ml)=2
0689 nij(i,j,ml)=2
0690 enddo
0691 enddo
0692 enddo
0693 enddo
0694 enddo
0695
0696 n=2 !number of ladder rungs considered
0697 2 if(debug.ge.1)write (moniou,202)n,mij(1,1,1),nij(1,1,1)
0698 do i=1,39
0699 qi=(spmax/4.d0/fqscal)**((i-1)/39.d0) !q^2 for upper parton
0700 do j=1,39
0701 qj=qi*(spmax/4.d0/fqscal/qi)**((j-1)/39.d0) !q^2 for downer parton
0702 s2min=qj*4.d0*fqscal !energy threshold for 2->2 subprocess
0703 smin=s2min/(1.d0-epsxmn) !energy threshold for 2->3 subprocess
0704 do m=1,2 !parton types (1-g, 2-q)
0705 do l=1,2 !parton types (1-g, 2-q)
0706 l1=2*l-1
0707 ml=m+2*l-2
0708 kmin=nij(i,j,ml) !lowest energy bin for another rung
0709 if(kmin.le.40)then
0710 do k=kmin,40
0711 sk=s2min*(spmax/s2min)**((k-1)/39.d0)
0712 if(sk.le.smin)then
0713 nij(i,j,ml)=nij(i,j,ml)+1
0714 else
0715 k1=k+40*(m-1)+80*(l-1)
0716 tmin=qj*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qj*fqscal/sk)))
0717 cs1(i,j,k1)=dlog(qgjet1(qi,qj,sk,s2min,m,l)
0718 * /(1.d0/tmin-2.d0/sk)+qgborn(qi,qj,sk,m-1,l1-1))
0719 endif
0720 enddo
0721 endif
0722 enddo
0723 enddo
0724 enddo
0725 enddo
0726
0727 do i=1,39
0728 qi=(spmax/4.d0/fqscal)**((i-1)/39.d0)
0729 do j=1,39
0730 qj=qi*(spmax/4.d0/fqscal/qi)**((j-1)/39.d0)
0731 s2min=qj*4.d0*fqscal
0732 do m=1,2
0733 do l=1,2
0734 ml=m+2*l-2
0735 kmin=nij(i,j,ml)
0736 if(kmin.le.40)then
0737 do k=40,kmin,-1
0738 sk=s2min*(spmax/s2min)**((k-1)/39.d0)
0739 tmin=qj*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qj*fqscal/sk)))
0740 k1=k+40*(m-1)+80*(l-1)
0741 if(abs(cs1(i,j,k1)-cs0(i,j,k1)).gt.1.d-2)then
0742 cs0(i,j,k1)=cs1(i,j,k1)
0743 elseif(k.eq.nij(i,j,ml))then
0744 nij(i,j,ml)=nij(i,j,ml)+1
0745 endif
0746 enddo
0747 endif
0748 enddo
0749 enddo
0750 enddo
0751 enddo
0752
0753 do i=1,39
0754 qi=(spmax/4.d0/fqscal)**((i-1)/39.d0)
0755 do j=1,39
0756 qj=qi*(spmax/4.d0/fqscal/qi)**((j-1)/39.d0)
0757 s2min=qj*4.d0*fqscal !min energy squared for 2->2 subprocess
0758 smin=s2min/(1.d0-epsxmn) !min energy squared for 2->3 subprocess
0759 do m=1,2
0760 do l=1,2
0761 ml=m+2*l-2
0762 kmin=mij(i,j,ml) !min energy bin for more ladder rungs
0763 if(kmin.le.40)then
0764 do k=kmin,40
0765 sk=s2min*(spmax/s2min)**((k-1)/39.d0)
0766 if(sk.le.smin)then
0767 mij(i,j,ml)=mij(i,j,ml)+1
0768 else
0769 k1=k+40*(m-1)+80*(l-1)
0770 tmin=qj*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qj*fqscal/sk)))
0771 cs1(i,j,k1)=dlog((qgjet(qi,qj,sk,s2min,m,l)
0772 * +qgjit1(qj,qi,sk,l,m))/(1.d0/tmin-2.d0/sk))
0773 endif
0774 enddo
0775 endif
0776 enddo
0777 enddo
0778 enddo
0779 enddo
0780
0781
0782
0783 do i=1,39
0784 qi=(spmax/4.d0/fqscal)**((i-1)/39.d0)
0785 do j=1,39
0786 qj=qi*(spmax/4.d0/fqscal/qi)**((j-1)/39.d0)
0787 s2min=qj*4.d0*fqscal
0788 do m=1,2
0789 do l=1,2
0790 ml=m+2*l-2
0791 kmin=mij(i,j,ml) !min energy bin for more ladder rungs
0792 if(kmin.le.40)then
0793 do k=40,kmin,-1
0794 sk=s2min*(spmax/s2min)**((k-1)/39.d0)
0795 tmin=qj*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qj*fqscal/sk)))
0796 k1=k+40*(m-1)+80*(l-1)
0797 if(abs(cs1(i,j,k1)-cstot(i,j,k1)).gt.1.d-2)then
0798 cstot(i,j,k1)=cs1(i,j,k1)
0799 elseif(k.eq.mij(i,j,ml))then
0800 mij(i,j,ml)=mij(i,j,ml)+1
0801 endif
0802 enddo
0803 endif
0804 enddo
0805 enddo
0806 enddo
0807 enddo
0808
0809 n=n+1 !one more rung
0810 do i=1,39
0811 do j=1,39
0812 do l=1,4
0813 if(mij(i,j,l).le.40.or.nij(i,j,l).le.40)goto 2
0814 enddo
0815 enddo
0816 enddo
0817
0818 3 if(debug.ge.2)write (moniou,205)
0819
0820
0821 if(debug.ge.1)write (moniou,210)
0822 s2min=4.d0*fqscal*qt0
0823 do iy=1,51
0824 sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
0825 rp=alfp*log(sy)*4.d0*.0389d0
0826 do iz=1,11
0827 if(iz.gt.6)then
0828 z=.2d0*(iz-6)
0829 b=sqrt(-log(z)*rp)
0830 else
0831 b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
0832 z=exp(-b*b/rp)
0833 endif
0834
0835 qpomi(iy,iz,1)=dlog(qgpint(sy,b*b)
0836 * /sy**dels/sigs/z*rp/4.d0/.0389d0+1.d0)
0837 enddo
0838 enddo
0839
0840
0841
0842 do iy=1,51
0843 sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
0844 rp=alfp*log(sy)*4.d0*.0389d0
0845 do iz=1,11
0846 if(iz.gt.6)then
0847 z=.2d0*(iz-6)
0848 b=sqrt(-log(z)*rp)
0849 else
0850 b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
0851 z=exp(-b*b/rp)
0852 endif
0853 do iqq=2,4
0854 qpomi(iy,iz,iqq)=qpomi(iy,iz,1)
0855 enddo
0856 enddo
0857 enddo
0858
0859 do iy=2,51
0860 sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
0861 rp=alfp*log(sy)*4.d0*.0389d0
0862 do iz=1,11
0863 do iqq=2,4
0864 qpomi(iy,iz,iqq)=qpomi(iy-1,iz,iqq)
0865 enddo
0866 enddo
0867 n=0
0868 4 n=n+1
0869 nrep=0
0870 do iz=1,11
0871 if(iz.gt.6)then
0872 z=.2d0*(iz-6)
0873 b=sqrt(-log(z)*rp)
0874 else
0875 b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
0876 z=exp(-b*b/rp)
0877 endif
0878 call qgloop(sy,b*b,fann,1)
0879 do iqq=1,3
0880 if(fann(iqq).gt.0.d0)then
0881 qfan0(iz,iqq)=dlog(fann(iqq)/z/sigs/sy**dels*rp/g3p**2
0882 * /4.d0/.0389d0)
0883 elseif(iy.gt.2)then
0884 qfan0(iz,iqq)=min(2.d0*qpomi(iy-1,iz,iqq+1)
0885 * -qpomi(iy-2,iz,iqq+1),qpomi(iy-1,iz,iqq+1))
0886 else
0887 stop'loop<0: iy=2'
0888 endif
0889 if(qfan0(iz,iqq).lt.-20.d0)then
0890 qfan0(iz,iqq)=-20.d0
0891 endif
0892 if(abs(qfan0(iz,iqq)-qpomi(iy,iz,iqq+1)).gt.1.d-3)nrep=1
0893 enddo
0894 enddo
0895 do iz=1,11
0896 if(iz.gt.6)then
0897 z=.2d0*(iz-6)
0898 b=sqrt(-log(z)*rp)
0899 else
0900 b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
0901 z=exp(-b*b/rp)
0902 endif
0903 do iqq=2,4
0904 qpomi(iy,iz,iqq)=qfan0(iz,iqq-1)
0905 if(.not.(qpomi(iy,iz,iqq).le.0.d0
0906 * .or.qpomi(iy,iz,iqq).gt.0.d0))stop'qpom-nan'
0907 enddo
0908 enddo
0909 if(nrep.eq.1.and.n.lt.100)goto 4
0910 enddo
0911
0912
0913
0914 do iy=1,51
0915 do iz=1,11
0916 do iqq=5,7
0917 qpomi(iy,iz,iqq)=qpomi(iy,iz,iqq-3)
0918 enddo
0919 qpomi(iy,iz,8)=qpomi(iy,iz,2)
0920 do iqq=9,10
0921 qpomi(iy,iz,iqq)=qpomi(iy,iz,iqq-7)
0922 qpomi(iy,iz,iqq+2)=qpomi(iy,iz,iqq-7)
0923 enddo
0924 do iqq=13,15
0925 qpomi(iy,iz,iqq)=qpomi(iy,iz,iqq-11)
0926 enddo
0927 enddo
0928 enddo
0929
0930 do iy=2,51
0931 sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
0932 rp=alfp*log(sy)*4.d0*.0389d0
0933 do iz=1,11
0934 do iqq=5,15
0935 qpomi(iy,iz,iqq)=qpomi(iy-1,iz,iqq)
0936 enddo
0937 enddo
0938 n=0
0939 5 n=n+1
0940 nrep=0
0941 do iz=1,11
0942 if(iz.gt.6)then
0943 z=.2d0*(iz-6)
0944 b=sqrt(-log(z)*rp)
0945 else
0946 b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
0947 z=exp(-b*b/rp)
0948 endif
0949 call qgloop(sy,b*b,fann,2)
0950 do iqq=4,14
0951 if(fann(iqq).gt.0.d0)then
0952 qfan0(iz,iqq)=dlog(fann(iqq)/z/sigs/sy**dels*rp/g3p**2
0953 * /4.d0/.0389d0)
0954 elseif(iy.gt.2)then
0955 qfan0(iz,iqq)=min(2.d0*qpomi(iy-1,iz,iqq+1)
0956 * -qpomi(iy-2,iz,iqq+1),qpomi(iy-1,iz,iqq+1))
0957 else
0958 stop'loop<0: iy=2'
0959 endif
0960 if(qfan0(iz,iqq).lt.-20.d0)then
0961 qfan0(iz,iqq)=-20.d0
0962 endif
0963 if(abs(qfan0(iz,iqq)-qpomi(iy,iz,iqq+1)).gt.1.d-3)nrep=1
0964 enddo
0965 enddo
0966 do iz=1,11
0967 if(iz.gt.6)then
0968 z=.2d0*(iz-6)
0969 b=sqrt(-log(z)*rp)
0970 else
0971 b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
0972 z=exp(-b*b/rp)
0973 endif
0974 do iqq=5,15
0975 qpomi(iy,iz,iqq)=qfan0(iz,iqq-1)
0976 if(.not.(qpomi(iy,iz,iqq).le.0.d0
0977 * .or.qpomi(iy,iz,iqq).gt.0.d0))stop'qpomi-nan'
0978 enddo
0979 enddo
0980 if(nrep.eq.1.and.n.lt.50)goto 5
0981 enddo
0982
0983
0984
0985 do iv=1,11
0986 vvx=dble(iv-1)/10.d0
0987 do iv1=1,11
0988 vvxt=dble(iv1-1)/10.d0
0989
0990 do iz=1,11
0991 do iqq=1,8
0992 qpomis(1,iz,iv,iv1,iqq)=0.d0
0993 enddo
0994 qpomis(1,iz,iv,iv1,1)=qpomi(1,iz,1)
0995 qpomis(1,iz,iv,iv1,4)=qpomi(1,iz,1)
0996 enddo
0997
0998 do iy=2,51
0999 sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
1000 rp=alfp*log(sy)*4.d0*.0389d0
1001 do iz=1,11
1002 do iqq=1,8
1003 qpomis(iy,iz,iv,iv1,iqq)=qpomis(iy-1,iz,iv,iv1,iqq)
1004 enddo
1005 enddo
1006
1007 n=0
1008 6 n=n+1
1009 nrep=0
1010 do iz=1,11
1011 if(iz.gt.6)then
1012 z=.2d0*(iz-6)
1013 b=sqrt(-log(z)*rp)
1014 else
1015 b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
1016 z=exp(-b*b/rp)
1017 endif
1018 call qgloos(sy,b*b,vvx,vvxt,fann)
1019 vi=qgpini(sy,b*b,0.d0,0.d0,2)
1020 vic=min(vi,qgpini(sy,b*b,0.d0,0.d0,8))
1021 vicng=min(vic,qgpini(sy,b*b,0.d0,0.d0,11))
1022 do iqq=1,8
1023 if(fann(iqq).gt.0.d0)then
1024 if(iqq.eq.1.or.iqq.eq.4)then
1025 qfan0(iz,iqq)=dlog(fann(iqq)/z/sigs/sy**dels*rp/g3p**2
1026 * /4.d0/.0389d0)
1027 elseif(iqq.eq.3)then
1028 qfan0(iz,iqq)=dlog(fann(iqq)/(.5d0*max(0.d0,1.d0
1029 * -exp(-2.d0*vic)*(1.d0+2.d0*vic))+vicng*exp(-2.d0*vic)))
1030 elseif(iqq.gt.6)then
1031 qfan0(iz,iqq)=dlog(fann(iqq)*2.d0/((1.d0-exp(-vi))**2
1032 * +(exp(2.d0*(vi-vic))-1.d0)*exp(-2.d0*vi)))
1033 else
1034 qfan0(iz,iqq)=dlog(fann(iqq)/(1.d0-exp(-vi)))
1035 endif
1036 elseif(iy.gt.2)then
1037 qfan0(iz,iqq)=min(2.d0*qpomis(iy-1,iz,iv,iv1,iqq)
1038 * -qpomis(iy-2,iz,iv,iv1,iqq),qpomis(iy-1,iz,iv,iv1,iqq))
1039 else
1040 qfan0(iz,iqq)=qpomis(iy-1,iz,iv,iv1,iqq)
1041 endif
1042 if(iqq.gt.5)qfan0(iz,iqq)=min(qfan0(iz,iqq),qfan0(iz,iqq-1))
1043 qfan0(iz,iqq)=max(qfan0(iz,iqq),-20.d0)
1044 if(abs(qfan0(iz,iqq)-qpomis(iy,iz,iv,iv1,iqq)).gt.1.d-3)
1045 * nrep=1
1046 enddo
1047 enddo
1048
1049 do iz=1,11
1050 if(iz.gt.6)then
1051 z=.2d0*(iz-6)
1052 b=sqrt(-log(z)*rp)
1053 else
1054 b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
1055 z=exp(-b*b/rp)
1056 endif
1057 do iqq=1,8
1058 qpomis(iy,iz,iv,iv1,iqq)=qfan0(iz,iqq)
1059 if(iqq.eq.1.or.iqq.eq.4)then
1060 dpx=exp(qpomis(iy,iz,iv,iv1,iqq))*g3p**2*sigs
1061 * *sy**dels*z/rp*4.d0*.0389d0
1062 else
1063 dpx=exp(qpomis(iy,iz,iv,iv1,iqq))
1064 endif
1065 enddo
1066 enddo
1067 if(nrep.eq.1.and.n.lt.50)goto 6
1068 enddo
1069 enddo
1070 enddo
1071
1072
1073
1074 if(debug.ge.1)write (moniou,212)
1075 do icz=1,3
1076 do icdp=1,2
1077 if(cd(icdp,icz).ne.0.d0)then
1078 do iy=1,51
1079 sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
1080 rp=(rq(icdp,icz)+alfp*log(sy))*4.d0*.0389d0
1081 do iz=1,11
1082 if(iz.gt.6)then
1083 z=.2d0*(iz-6)
1084 b=sqrt(-log(z)*rp)
1085 else
1086 b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
1087 z=exp(-b*b/rp)
1088 endif
1089
1090 qxl=qgleg(sy,b*b,icdp,icz)
1091 qlegi(iy,iz,icdp,icz,1)=log(qxl/z)
1092 enddo
1093 enddo
1094 endif
1095 enddo
1096 enddo
1097
1098
1099
1100 do icz=1,3
1101 do icdp=1,2
1102 if(cd(icdp,icz).ne.0.d0)then
1103 do iy=1,51
1104 sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
1105 rp=(rq(icdp,icz)+alfp*log(sy))*4.d0*.0389d0
1106 do iz=1,11
1107 if(iz.gt.6)then
1108 z=.2d0*(iz-6)
1109 b=sqrt(-log(z)*rp)
1110 else
1111 b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
1112 z=exp(-b*b/rp)
1113 endif
1114 if(iy.eq.1)then
1115 do iqq=2,7
1116 qlegi(iy,iz,icdp,icz,iqq)=qlegi(iy,iz,icdp,icz,1)
1117 enddo
1118 else
1119 call qglool(sy,b*b,icdp,icz,fann)
1120 do iqq=2,7
1121 if(fann(iqq-1).gt.0.d0)then
1122 qlegi(iy,iz,icdp,icz,iqq)=log(fann(iqq-1)/z)
1123 else
1124 qlegi(iy,iz,icdp,icz,iqq)=2.d0*qlegi(iy-1,iz,icdp,icz,iqq)
1125 * -qlegi(iy-2,iz,icdp,icz,iqq)
1126 endif
1127 qlegi(iy,iz,icdp,icz,iqq)=max(qlegi(iy,iz,icdp,icz,iqq)
1128 * ,-20.d0)
1129 if(.not.(qlegi(iy,iz,icdp,icz,iqq).le.0.d0
1130 * .or.qlegi(iy,iz,icdp,icz,iqq).gt.0.d0))stop'leg-nan'
1131 enddo
1132 endif
1133 enddo
1134 enddo
1135 endif
1136 enddo
1137 enddo
1138
1139
1140
1141 if(debug.ge.1)write (moniou,213)
1142 do icz=1,3
1143 do iv=1,11
1144 vvx=dble(iv-1)/10.d0
1145 do icdp=1,2
1146 if(cd(icdp,icz).ne.0.d0)then
1147 do iy=1,51
1148 do iz=1,11
1149 do iqq=1,2
1150 qfanu(iy,iz,iv,icdp+2*(icz-1),iqq)=qlegi(iy,iz,icdp,icz,iqq+1)
1151 enddo
1152 enddo
1153 enddo
1154
1155 do iy=2,51
1156 sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
1157 rp=(rq(icdp,icz)+alfp*dlog(sy))*4.d0*.0389d0
1158 do iz=1,11
1159 do iqq=1,2
1160 qfanu(iy,iz,iv,icdp+2*(icz-1),iqq)
1161 * =qfanu(iy-1,iz,iv,icdp+2*(icz-1),iqq)
1162 enddo
1163 enddo
1164
1165 n=1
1166 7 n=n+1
1167 nrep=0
1168 do iz=1,11
1169 if(iz.gt.6)then
1170 z=.2d0*dble(iz-6)
1171 b=dsqrt(-dlog(z)*rp)
1172 else
1173 b=dsqrt(-rp*(dlog(0.2d0)+2.d0*dble(iz-7)))
1174 z=dexp(-b*b/rp)
1175 endif
1176 call qgfan(sy,b*b,vvx,icdp,icz,fann)
1177 do iqq=1,2
1178 if(fann(iqq).gt.0.d0)then
1179 qfan0(iz,iqq)=dlog(fann(iqq)/z)
1180 else
1181 qfan0(iz,iqq)=min(qfanu(iy-1,iz,iv,icdp+2*(icz-1),iqq)
1182 * ,2.d0*qfanu(iy-1,iz,iv,icdp+2*(icz-1),iqq)
1183 * -qfanu(iy-2,iz,iv,icdp+2*(icz-1),iqq))
1184 endif
1185 qfan0(iz,iqq)=max(qfan0(iz,iqq),-20.d0)
1186 if(abs(qfan0(iz,iqq)-qfanu(iy,iz,iv,icdp+2*(icz-1),iqq))
1187 * .gt.1.d-3)nrep=1
1188 enddo
1189 enddo
1190
1191 do iz=1,11
1192 do iqq=1,2
1193 qfanu(iy,iz,iv,icdp+2*(icz-1),iqq)=qfan0(iz,iqq)
1194 enddo
1195 enddo
1196 if(nrep.eq.1)goto 7
1197
1198 do iz=1,11
1199 do iqq=1,2
1200 if(iz.gt.6)then
1201 z=.2d0*dble(iz-6)
1202 b=dsqrt(-dlog(z)*rp)
1203 else
1204 b=dsqrt(-rp*(dlog(0.2d0)+2.d0*dble(iz-7)))
1205 z=dexp(-b*b/rp)
1206 endif
1207 if(.not.(qfanu(iy,iz,iv,icdp+2*(icz-1),iqq).le.0.d0
1208 * .or.qfanu(iy,iz,iv,icdp+2*(icz-1),iqq).gt.0.d0))stop'fan-nn'
1209 enddo
1210 enddo
1211 enddo
1212 endif
1213 enddo
1214 enddo
1215 enddo
1216
1217
1218
1219 if(debug.ge.1)write (moniou,215)
1220 do icz=1,3 !hadron class
1221 do icdp=1,2 !diffractive eigenstate
1222 if(cd(icdp,icz).ne.0.d0)then
1223
1224 do iv=1,11
1225 vvx=dble(iv-1)/10.d0
1226 do iv1=1,1+5*(icz-1)*(3-icz)
1227 vvxp=dble(iv1-1)/5.d0
1228 do iv2=1,1+5*(icz-1)*(3-icz)
1229 vvxpl=vvx*dble(iv2-1)/5.d0
1230 do iy=1,51 !initialization
1231 do iz=1,11
1232 do iqq=1,9
1233 qfanc(iy,iz,iv,icz+(icz-1)*(3-icz)*(iv1+1+6*(iv2-1)),icdp
1234 * +2*(iqq-1))=qfanu(iy,iz,iv,icdp+2*(icz-1),1)
1235 enddo
1236 enddo
1237 enddo
1238
1239 do iy=2,51
1240 sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
1241 rp=(rq(icdp,icz)+alfp*dlog(sy))*4.d0*.0389d0
1242 do iz=1,11
1243 do iqq=1,9
1244 qfanc(iy,iz,iv,icz+(icz-1)*(3-icz)*(iv1+1+6*(iv2-1)),icdp
1245 * +2*(iqq-1))=qfanc(iy-1,iz,iv,icz+(icz-1)*(3-icz)*(iv1+1
1246 * +6*(iv2-1)),icdp+2*(iqq-1))
1247 enddo
1248 enddo
1249
1250 n=1
1251 8 n=n+1 !number of t-channel iterations
1252 nrep=0
1253 do iz=1,11
1254 if(iz.gt.6)then
1255 z=.2d0*dble(iz-6)
1256 b=dsqrt(-dlog(z)*rp)
1257 else
1258 b=dsqrt(-rp*(dlog(0.2d0)+2.d0*dble(iz-7)))
1259 z=dexp(-b*b/rp)
1260 endif
1261 call qgfanc(sy,b*b,vvx,vvxp,vvxpl,icdp,icz,fann)
1262 fann(7)=min(fann(7),fann(8))
1263 do iqq=1,9
1264 if(fann(iqq).gt.0.d0)then
1265 qfan0(iz,iqq)=dlog(fann(iqq)/z)
1266 else
1267 qfan0(iz,iqq)=min(2.d0*qfanc(iy-1,iz,iv,icz
1268 * +(icz-1)*(3-icz)*(iv1+1+6*(iv2-1)),icdp+2*(iqq-1))
1269 * -qfanc(iy-2,iz,iv,icz+(icz-1)*(3-icz)*(iv1+1+6*(iv2-1))
1270 * ,icdp+2*(iqq-1)),qfanc(iy-1,iz,iv,icz
1271 * +(icz-1)*(3-icz)*(iv1+1+6*(iv2-1)),icdp+2*(iqq-1)))
1272 endif
1273 qfan0(iz,iqq)=max(qfan0(iz,iqq),-20.d0)
1274 enddo
1275 enddo
1276
1277 do iz=1,11
1278 do iqq=1,9
1279 if(abs(qfan0(iz,iqq)-qfanc(iy,iz,iv,icz+(icz-1)*(3-icz)
1280 * *(iv1+1+6*(iv2-1)),icdp+2*(iqq-1))).gt.1.d-3)nrep=1
1281 qfanc(iy,iz,iv,icz+(icz-1)*(3-icz)*(iv1+1+6*(iv2-1))
1282 * ,icdp+2*(iqq-1))=qfan0(iz,iqq)
1283 enddo
1284 enddo
1285 if(nrep.eq.1.and.n.lt.50)goto 8
1286
1287 do iz=1,11
1288 if(iz.gt.6)then
1289 z=.2d0*dble(iz-6)
1290 b=dsqrt(-dlog(z)*rp)
1291 else
1292 b=dsqrt(-rp*(dlog(0.2d0)+2.d0*dble(iz-7)))
1293 z=dexp(-b*b/rp)
1294 endif
1295 do iqq=1,9
1296 if(.not.(qfanc(iy,iz,iv,icz+(icz-1)*(3-icz)*(iv1+1+6*(iv2-1))
1297 * ,icdp+2*(iqq-1)).le.0.d0.or.qfanc(iy,iz,iv,icz+(icz-1)
1298 * *(3-icz)*(iv1+1+6*(iv2-1)),icdp+2*(iqq-1)).gt.0.d0))
1299 * stop'fanc-nan'
1300 enddo
1301 enddo
1302 enddo
1303 enddo
1304 enddo
1305 enddo
1306 endif
1307 enddo
1308 enddo
1309
1310
1311
1312 do icz=1,3 !hadron class
1313 do icdp=1,2 !diffractive eigenstate
1314 if(cd(icdp,icz).ne.0.d0)then
1315 do iy=1,11
1316 sy=sgap**2*(spmax/sgap**2)**((iy-1)/10.d0)
1317 rp=(rq(icdp,icz)+alfp*dlog(sy))*4.d0*.0389d0
1318 do iz=1,11
1319 if(iz.gt.6)then
1320 z=.2d0*dble(iz-6)
1321 bb=-dlog(z)*rp
1322 else
1323 bb=-rp*(dlog(0.2d0)+2.d0*dble(iz-7))
1324 z=dexp(-bb/rp)
1325 endif
1326 do iv=1,11
1327 vvxt0=dble(iv-1)/10.d0
1328 do iv1=1,6
1329 vvxt=vvxt0+(1.d0-vvxt0)*dble(iv1-1)/5.d0
1330 do iv2=1,1+5*(icz-1)*(3-icz)
1331 vvxpt=dble(iv2-1)/5.d0
1332 do iv3=1,1+5*(icz-1)*(3-icz)
1333 vvxp0=vvxpt*dble(iv3-1)/5.d0
1334 do iv4=1,1+5*(icz-1)*(3-icz)
1335 vvxpl=dble(iv4-1)/5.d0
1336
1337 dfan=qgrev(sy,bb,vvxt0,vvxt,vvxpt,vvxp0,vvxpl,icdp,icz)
1338 if(dfan.gt.0.d0)then
1339 qrev(iy,iz,iv+11*(iv1-1),icz+(icz-1)*(3-icz)
1340 * *(iv2+1+6*(iv3-1)+36*(iv4-1)),icdp)=dlog(dfan/z)
1341 else
1342 qrev(iy,iz,iv+11*(iv1-1),icz+(icz-1)*(3-icz)*(iv2+1
1343 * +6*(iv3-1)+36*(iv4-1)),icdp)=2.d0*qrev(iy-1,iz,iv+11*(iv1-1)
1344 * ,icz+(icz-1)*(3-icz)*(iv2+1+6*(iv3-1)+36*(iv4-1)),icdp)
1345 * -qrev(iy-2,iz,iv+11*(iv1-1),icz+(icz-1)*(3-icz)*(iv2+1
1346 * +6*(iv3-1)+36*(iv4-1)),icdp)
1347 endif
1348 qrev(iy,iz,iv+11*(iv1-1),icz+(icz-1)*(3-icz)*(iv2+1+6*(iv3-1)
1349 * +36*(iv4-1)),icdp)=max(qrev(iy,iz,iv+11*(iv1-1),icz
1350 * +(icz-1)*(3-icz)*(iv2+1+6*(iv3-1)+36*(iv4-1)),icdp),-20.d0)
1351
1352 if(.not.(qrev(iy,iz,iv+11*(iv1-1),icz+(icz-1)*(3-icz)
1353 * *(iv2+1+6*(iv3-1)+36*(iv4-1)),icdp).le.0.d0.or.qrev(iy,iz
1354 * ,iv+11*(iv1-1),icz+(icz-1)*(3-icz)*(iv2+1+6*(iv3-1)
1355 * +36*(iv4-1)),icdp).gt.0.d0))stop'fanc-nan'
1356 enddo
1357 enddo
1358 enddo
1359 enddo
1360 enddo
1361 enddo
1362 enddo
1363 endif
1364 enddo
1365 enddo
1366
1367
1368
1369 icz=2
1370 do icdp=1,2
1371 if(cd(icdp,icz).ne.0.d0)then
1372 do iy=1,21
1373 xpomr=(1.d5/sgap**2)**(-dble(iy-1)/20.d0)/sgap**2
1374 rp=(rq(icdp,icz)-alfp*dlog(xpomr))*2.d0*.0389d0
1375 if(iy.gt.1)then
1376 do iy1=1,11
1377 do iz=1,11
1378 do iqq=1,3
1379 qdfan(iy,iy1,iz,icdp,iqq)=qdfan(iy-1,iy1,iz,icdp,iqq)
1380 enddo
1381 enddo
1382 enddo
1383 endif
1384
1385 n=0
1386 9 n=n+1
1387 nrep=0
1388 do iy1=1,11
1389 xpomr1=(xpomr*sgap**2)**(dble(11-iy1)/10.d0)/sgap
1390 do iz=1,11
1391 if(iz.gt.6)then
1392 z=.2d0*dble(iz-6)
1393 b=dsqrt(-dlog(z)*rp)
1394 else
1395 b=dsqrt(-rp*(dlog(0.2d0)+2.d0*dble(iz-7)))
1396 z=dexp(-b*b/rp)
1397 endif
1398 call qgdfan(xpomr,xpomr1,b*b,icdp,fann,n)
1399 do iqq=1,3
1400 if(fann(iqq).gt.0.d0)then
1401 qfan2(iy1,iz,iqq)=dlog(fann(iqq)/z)
1402 else
1403 qfan2(iy1,iz,iqq)=qfan2(iy1-1,iz,iqq)
1404 endif
1405 if(n.gt.1.and.abs(qfan2(iy1,iz,iqq)
1406 * -qdfan(iy,iy1,iz,icdp,iqq)).gt.1.d-3)nrep=1
1407 enddo
1408 enddo
1409 enddo
1410
1411 do iy1=1,11
1412 do iz=1,11
1413 do iqq=1,3
1414 qdfan(iy,iy1,iz,icdp,iqq)=qfan2(iy1,iz,iqq)
1415 enddo
1416 enddo
1417 enddo
1418 if((n.eq.1.or.nrep.eq.1).and.iy.gt.1)goto 9
1419
1420 do iy1=1,11
1421 xpomr1=(xpomr*sgap**2)**(dble(11-iy1)/10.d0)/sgap
1422 do iz=1,11
1423 if(iz.gt.6)then
1424 z=.2d0*dble(iz-6)
1425 b=dsqrt(-dlog(z)*rp)
1426 else
1427 b=dsqrt(-rp*(dlog(0.2d0)+2.d0*dble(iz-7)))
1428 z=dexp(-b*b/rp)
1429 endif
1430 do iqq=1,3
1431 if(iqq.ne.3)then
1432 dpx=dexp(qdfan(iy,iy1,iz,icdp,iqq))*z
1433 else
1434 dpx=dexp(qdfan(iy,iy1,iz,icdp,iqq))*z
1435 * *dlog(xpomr1/xpomr/sgap)
1436 endif
1437 if(.not.(qdfan(iy,iy1,iz,icdp,iqq).le.0.d0
1438 * .or.qdfan(iy,iy1,iz,icdp,iqq).gt.0.d0))stop'qdfan-nan'
1439 enddo
1440 enddo
1441 enddo
1442 enddo
1443 endif
1444 enddo
1445
1446
1447
1448 do icz=1,3
1449 do icdp=1,2
1450 do icdt=1,2
1451 if(cd(icdp,icz).ne.0.d0.and.cd(icdt,2).ne.0.d0)then
1452 do iy=1,11
1453 e0n=10.d0**iy
1454 sy=2.d0*e0n*am(2)+am(2)**2+am(icz)**2
1455 rp=(rq(icdp,icz)+rq(icdt,2)+alfp*log(sy))*4.d0*.0389d0
1456 do iz=1,11
1457 if(iz.gt.6)then
1458 z=.2d0*(iz-6)
1459 b=sqrt(-log(z)*rp)
1460 else
1461 b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
1462 z=exp(-b*b/rp)
1463 endif
1464
1465 vsoft=gsoft(icz)*sy**dels/rp*cd(icdp,icz)*cd(icdt,2)
1466 vgg=qgfsh(sy,b*b,icdp,icdt,icz,0)
1467 vqg=qgfsh(sy,b*b,icdp,icdt,icz,1)
1468 vgq=qgfsh(sy,b*b,icdp,icdt,icz,2)
1469 vqq=qghard(sy,b*b,icdp,icdt,icz)
1470
1471 qxp=vsoft*z+vgg+vqg+vgq+vqq
1472 do iv=1,6
1473 vvx=(iv-1)/5.d0
1474 do iv1=1,1+5*(icz-1)*(3-icz)
1475 vvxp=(iv1-1)/5.d0
1476 do iv2=1,6
1477 vvxt=(iv2-1)/5.d0
1478
1479 v3p=qg3pom(sy,b,vvx,vvxp,vvxt,icdp,icdt,icz)
1480 v1p=qgpcut(sy,b,vvx,vvxp,vvxt,icdp,icdt,icz)
1481 qxp1=qxp+v3p
1482 qxpc=qxp+v1p
1483 if(qxp1.gt.0.d0)then
1484 qpomr(iy,iz,iv+6*(iv1-1)+36*(iv2-1)
1485 * ,icdp+2*(icdt-1)+4*(icz-1),1)=log(qxp1/z)
1486 else
1487 qpomr(iy,iz,iv+6*(iv1-1)+36*(iv2-1),icdp+2*(icdt-1)
1488 * +4*(icz-1),1)=min(2.d0*qpomr(iy-1,iz,iv+6*(iv1-1)
1489 * +36*(iv2-1),icdp+2*(icdt-1)+4*(icz-1),1)-qpomr(iy-2,iz
1490 * ,iv+6*(iv1-1)+36*(iv2-1),icdp+2*(icdt-1)+4*(icz-1),1)
1491 * ,qpomr(iy-1,iz,iv+6*(iv1-1)+36*(iv2-1)
1492 * ,icdp+2*(icdt-1)+4*(icz-1),1))
1493 endif
1494 if(qxpc.gt.0.d0)then
1495 qpomr(iy,iz,iv+6*(iv1-1)+36*(iv2-1)
1496 * ,icdp+2*(icdt-1)+4*(icz-1),2)=log(qxpc/z)
1497 else
1498 qpomr(iy,iz,iv+6*(iv1-1)+36*(iv2-1),icdp+2*(icdt-1)
1499 * +4*(icz-1),2)=min(2.d0*qpomr(iy-1,iz,iv+6*(iv1-1)
1500 * +36*(iv2-1),icdp+2*(icdt-1)+4*(icz-1),2)-qpomr(iy-2,iz
1501 * ,iv+6*(iv1-1)+36*(iv2-1),icdp+2*(icdt-1)+4*(icz-1),2)
1502 * ,qpomr(iy-1,iz,iv+6*(iv1-1)+36*(iv2-1)
1503 * ,icdp+2*(icdt-1)+4*(icz-1),2))
1504 endif
1505
1506 do iqq=1,2
1507 qpomr(iy,iz,iv+6*(iv1-1)+36*(iv2-1),icdp+2*(icdt-1)
1508 * +4*(icz-1),iqq)=max(qpomr(iy,iz,iv+6*(iv1-1)+36*(iv2-1)
1509 * ,icdp+2*(icdt-1)+4*(icz-1),iqq),-20.d0)
1510
1511 if(.not.(qpomr(iy,iz,iv+6*(iv1-1)+36*(iv2-1),icdp+2*(icdt-1)
1512 * +4*(icz-1),iqq).le.0.d0.or.qpomr(iy,iz,iv+6*(iv1-1)
1513 * +36*(iv2-1),icdp+2*(icdt-1)+4*(icz-1),iqq).gt.0.d0))
1514 * stop'qpomr-nan'
1515 enddo
1516 enddo
1517 enddo
1518 enddo
1519 enddo
1520 enddo
1521 endif
1522 enddo
1523 enddo
1524 enddo
1525
1526
1527
1528 ia(1)=1
1529 do iy=1,10
1530 e0n=10.d0**iy !interaction energy
1531 scm=2.d0*e0n*am(2)+am(2)**2+am(icz)**2
1532
1533 do iiz=1,3
1534 icz=iiz !hadron class
1535 rp=(rq(1,icz)+rq(1,2)+alfp*log(scm))*4.d0*.0389d0 !slope (in fm^2)
1536 g0=pi*rp*10.d0 !factor for cross-sections (in mb)
1537
1538 do iia=1,6
1539 if(iia.le.4)then
1540 ia(2)=4**(iia-1) !target mass number
1541 elseif(iia.eq.5)then
1542 ia(2)=14
1543 else
1544 ia(2)=40
1545 endif
1546 if(debug.ge.1)write (moniou,206)e0n,ty(icz),ia(2)
1547
1548
1549 if(ia(2).lt.10)then !light nuclei - gaussian
1550 rnuc(2)=.9d0*float(ia(2))**.3333 !nuclear radius
1551 wsnuc(2)=amws !not used
1552 wbnuc(2)=0.d0 !not used
1553 elseif(ia(2).le.56)then !3-parameter Fermi
1554 rnuc(2)=trnuc(ia(2)) !nuclear radius
1555 wsnuc(2)=twsnuc(ia(2)) !diffuseness
1556 wbnuc(2)=twbnuc(ia(2)) !'wine-bottle' parameter
1557 else !2-parameter Fermi
1558
1559 rnuc(2)=1.19d0*dble(ia(2))**(1.d0/3.d0)
1560 * -1.38d0*dble(ia(2))**(-1.d0/3.d0) !nuclear radius
1561 wsnuc(2)=amws !diffuseness
1562 wbnuc(2)=0.d0 !not used
1563 endif
1564
1565 if(ia(2).eq.1)then !hadron-proton interaction
1566 call qgfz(0.d0,gz0,0,0)
1567 gtot=gz0(1) !total cross-section
1568 gin=(gz0(2)+gz0(3)+gz0(4))*.5d0 !inelastic cross section
1569 bel=gz0(5) !elastic scattering slope
1570 gel=gtot-gin !elastic cross section
1571 gdp=gz0(3)*.5d0 !projectile low mass diffr. (+double LMD)
1572 gdt=gz0(4)*.5d0 !target low mass diffraction
1573 if(iy.le.10)gsect(iy,icz,iia)=log(gin)
1574
1575 if(debug.ge.1)write (moniou,225)gtot,gin,gel,gdp,gdt,bel
1576 else !hadron-nucleus interaction
1577 bm=rnuc(2)+dlog(29.d0)*wsnuc(2) !for numerical integration
1578 anorm=qganrm(rnuc(2),wsnuc(2),wbnuc(2))*rp !density normalization
1579 call qggau(gz1) !integration over b<bm
1580 call qggau1(gz1) !integration over b>bm
1581 gin=gz1(1)+gz1(2)+gz1(3) !inelastic cross section
1582 if(iy.le.10)gsect(iy,icz,iia)=log(gin*10.d0)
1583
1584 if(debug.ge.1)write (moniou,224)
1585 * gin*10.d0,gz1(3)*10.d0,gz1(2)*10.d0
1586 endif
1587 if(.not.(gsect(iy,icz,iia).le.0.d0
1588 * .or.gsect(iy,icz,iia).gt.0.d0))stop'qpomr-nan'
1589 enddo
1590 enddo
1591 enddo
1592
1593
1594
1595 if(debug.ge.1)write (moniou,223)
1596 do icz=1,3 !hadron class
1597 do icdp=1,2
1598 if(cd(icdp,icz).ne.0.d0)then
1599 do iy=1,51
1600 sy=sgap**2*(spmax/sgap**2)**((iy-1)/50.d0)
1601 rp=(rq(icdp,icz)+alfp*log(sy))*4.d0*.0389d0
1602 do iz=1,11
1603 if(iz.gt.6)then
1604 z=.2d0*(iz-6)
1605 bb=-log(z)*rp !impact parameter^2
1606 else
1607 bb=-rp*(log(0.2d0)+2.d0*(iz-7))
1608 z=exp(-bb/rp)
1609 endif
1610 do ix=1,10
1611 if(ix.le.5)then
1612 xp=.2d0*(5.d0*sgap/sy)**((6-ix)/5.d0) !Pomeron LC+ momentum
1613 else
1614 xp=.2d0*(ix-5)
1615 endif
1616 sys=xp*sy
1617
1618 vs=qgls(sys,xp,bb,icdp,icz)
1619 vg=qglsh(sys,xp,bb,icdp,icz,0)
1620 if(xp.lt..99d0)then
1621 vq=qglsh(sys,xp,bb,icdp,icz,1)
1622 * /dsqrt(xp)*(1.d0-xp)**(ahv(icz)-ahl(icz))
1623 else
1624 vq=0.d0
1625 endif
1626 qlegc0(iy,ix,iz,icdp+2*(icz-1),1)=dlog((vs+vg+vq)/vs)
1627 qlegc0(iy,ix,iz,icdp+2*(icz-1),2)=dlog((vs+vg)/vs)
1628 enddo
1629 enddo
1630 enddo
1631 endif
1632 enddo
1633 enddo
1634
1635 do icz=1,3 !hadron class
1636 do icdp=1,2
1637 if(cd(icdp,icz).ne.0.d0)then
1638 do iy=1,51
1639 sy=sgap**2*(spmax/sgap**2)**((iy-1)/50.d0)
1640 rp=(rq(icdp,icz)+alfp*log(sy))*4.d0*.0389d0
1641 do iz=1,11
1642 if(iz.gt.6)then
1643 z=.2d0*(iz-6)
1644 bb=-log(z)*rp !impact parameter^2
1645 else
1646 bb=-rp*(log(0.2d0)+2.d0*(iz-7))
1647 z=exp(-bb/rp)
1648 endif
1649 do ix=1,10
1650 if(ix.le.5)then
1651 xp=.2d0*(5.d0*sgap/sy)**((6-ix)/5.d0) !Pomeron LC+ momentum
1652 else
1653 xp=.2d0*(ix-5)
1654 endif
1655 sys=xp*sy
1656
1657 do iqq=1,3
1658 call qgloolc(sys,xp,bb,icdp,icz,iqq,fann(2*iqq-1)
1659 * ,fann(2*iqq))
1660 enddo
1661 do iqq=1,6
1662 if(fann(iqq).gt.0.d0)then
1663 qlegc0(iy,ix,iz,icdp+2*(icz-1),iqq+2)
1664 * =dlog(fann(iqq)/qgls(sys,xp,bb,icdp,icz))
1665 else
1666 qlegc0(iy,ix,iz,icdp+2*(icz-1),iqq+2)
1667 * =min(2.d0*qlegc0(iy-1,ix,iz,icdp+2*(icz-1),iqq+2)
1668 * -qlegc0(iy-2,ix,iz,icdp+2*(icz-1),iqq+2)
1669 * ,qlegc0(iy-1,ix,iz,icdp+2*(icz-1),iqq+2))
1670 endif
1671 qlegc0(iy,ix,iz,icdp+2*(icz-1),iqq+2)
1672 * =max(qlegc0(iy,ix,iz,icdp+2*(icz-1),iqq+2),-20.d0)
1673 enddo
1674 enddo
1675 enddo
1676 enddo
1677 endif
1678 enddo
1679 enddo
1680
1681 do icz=1,3 !hadron class
1682 do icdp=1,2 !diffr. eigenstate
1683 if(cd(icdp,icz).ne.0.d0)then
1684 do iv=1,11
1685 vvx=dble(iv-1)/10.d0
1686 do iy=1,51 !initialization
1687 do ix=1,10
1688 do iz=1,11
1689 do iqq=1,3
1690 qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
1691 * =qlegc0(iy,ix,iz,icdp+2*(icz-1),2*iqq+1)
1692 enddo
1693 enddo
1694 enddo
1695 enddo
1696
1697 do iy=2,51
1698 sy=sgap**2*(spmax/sgap**2)**((iy-1)/50.d0)
1699 rp=(rq(icdp,icz)+alfp*log(sy))*4.d0*.0389d0
1700
1701 do ix=1,10
1702 do iz=1,11
1703 do iqq=1,3
1704 qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
1705 * =qlegc(iy-1,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
1706 enddo
1707 enddo
1708 enddo
1709
1710 n=1
1711 43 n=n+1 !number of t-channel iterations
1712 nrep=0
1713 do iz=1,11
1714 if(iz.gt.6)then
1715 z=.2d0*(iz-6)
1716 bb=-log(z)*rp !impact parameter^2
1717 else
1718 bb=-rp*(log(0.2d0)+2.d0*(iz-7))
1719 z=exp(-bb/rp)
1720 endif
1721 do ix=1,10
1722 if(ix.le.5)then
1723 xp=.2d0*(5.d0*sgap/sy)**((6-ix)/5.d0) !Pomeron LC+ momentum
1724 else
1725 xp=.2d0*(ix-5)
1726 endif
1727 sys=xp*sy
1728
1729 do iqq=1,3
1730 fann(iqq)=qglscr(sys,xp,bb,vvx,icdp,icz,iqq)
1731 if(fann(iqq).gt.0.d0)then
1732 qfan2(ix,iz,iqq)=dlog(fann(iqq)/qgls(sys,xp,bb,icdp,icz))
1733 elseif(iy.gt.2)then
1734 qfan2(ix,iz,iqq)
1735 * =min(2.d0*qlegc(iy-1,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
1736 * -qlegc(iy-2,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
1737 * ,qlegc(iy-1,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1)))
1738 else
1739 qfan2(ix,iz,iqq)
1740 * =qlegc(iy-1,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
1741 endif
1742 qfan2(ix,iz,iqq)=max(qfan2(ix,iz,iqq),-20.d0)
1743 if(abs(qfan2(ix,iz,iqq)-qlegc(iy,ix,iv,iz
1744 * ,icdp+2*(icz-1)+6*(iqq-1))).gt.1.d-3)nrep=1
1745 enddo
1746 enddo
1747 enddo
1748
1749 do iz=1,11
1750 if(iz.gt.6)then
1751 z=.2d0*(iz-6)
1752 bb=-log(z)*rp !impact parameter
1753 else
1754 bb=-rp*(log(0.2d0)+2.d0*(iz-7))
1755 z=exp(-bb/rp)
1756 endif
1757 do ix=1,10
1758 if(ix.le.5)then
1759 xp=.2d0*(5.d0*sgap/sy)**((6-ix)/5.d0) !Pomeron LC+ momentum
1760 else
1761 xp=.2d0*(ix-5)
1762 endif
1763 sys=xp*sy
1764
1765 do iqq=1,3
1766 qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))=qfan2(ix,iz,iqq)
1767
1768 if(.not.(qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1)).le.0.d0
1769 * .or.qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1)).gt.0.d0))
1770 * stop'qlegc-nan'
1771 enddo
1772 enddo
1773 enddo
1774 if(nrep.eq.1.and.n.lt.50)goto 43
1775 enddo
1776 enddo
1777 endif
1778 enddo
1779 enddo
1780
1781
1782 do icz=1,3 !hadron class
1783 do icdp=1,2 !diffr. eigenstate
1784 if(cd(icdp,icz).ne.0.d0)then
1785 do iv=1,11
1786 vvx=dble(iv-1)/10.d0
1787 do iy=1,51
1788 sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
1789 rp=(rq(icdp,icz)+alfp*log(sy))*4.d0*.0389d0
1790 do iz=1,11
1791 if(iz.gt.6)then
1792 z=.2d0*(iz-6)
1793 bb=-log(z)*rp !impact parameter
1794 else
1795 bb=-rp*(log(0.2d0)+2.d0*(iz-7))
1796 z=exp(-bb/rp)
1797 endif
1798 do ix=1,10
1799 if(ix.le.5)then
1800 xp=.2d0*(sgap/sy)**((6-ix)/5.d0) !Pomeron LC+ momentum
1801 else
1802 xp=.2d0*(ix-5)
1803 endif
1804 sys=xp*sy
1805
1806 if(iy.eq.1)then
1807 qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+18)=0.d0
1808 qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+24)=0.d0
1809 else
1810 do iqq=4,5
1811 fann(iqq)=qglh(sys,xp,bb,vvx,icdp,icz,iqq-4)
1812 if(fann(iqq).gt.0.d0)then
1813 qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
1814 * =dlog(fann(iqq))
1815 elseif(iy.gt.2)then
1816 qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
1817 * =min(2.d0*qlegc(iy-1,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
1818 * -qlegc(iy-2,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
1819 * ,qlegc(iy-1,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1)))
1820 else
1821 qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
1822 * =qlegc(iy-1,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
1823 endif
1824 qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
1825 * =max(qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1)),-20.d0)
1826
1827 if(.not.(qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1)).le.0.d0
1828 * .or.qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1)).gt.0.d0))
1829 * stop'qlegc-nan'
1830 enddo
1831 endif
1832 enddo
1833 enddo
1834 enddo
1835 enddo
1836 endif
1837 enddo
1838 enddo
1839
1840
1841
1842 if(debug.ge.1)write (moniou,226)
1843 do icz=1,3 !proj. class
1844 do icdp=1,2
1845 do icdt=1,2
1846 if(cd(icdp,icz).ne.0.d0.and.cd(icdt,2).ne.0.d0)then
1847 do iy=1,11
1848 sy=sgap**2*(spmax/sgap**2)**((iy-1)/10.d0)
1849 rp=(rq(icdp,icz)+rq(icdt,2)+alfp*log(sy))*4.d0*.0389d0
1850 do iz=1,11
1851 if(iz.gt.6)then
1852 z=.2d0*(iz-6)
1853 bb=-log(z)*rp !impact parameter^2
1854 else
1855 bb=-rp*(log(0.2d0)+2.d0*(iz-7))
1856 z=exp(-bb/rp)
1857 endif
1858 do iv=1,11
1859 vvx=(iv-1)/10.d0 !relative scr. strenth
1860
1861 do ix1=1,10
1862 if(ix1.le.5)then
1863 xp=.2d0*(5.d0*sgap/sy)**((6-ix1)/5.d0) !Pomeron LC+ momentum
1864 else
1865 xp=.2d0*(ix1-5)
1866 endif
1867 do ix2=1,10
1868 if(ix2.le.5)then
1869 xm=.2d0*(sgap/sy/xp)**((6-ix2)/5.d0) !Pomeron LC- momentum
1870 else
1871 xm=.2d0*(ix2-5)
1872 endif
1873 sys=xp*xm*sy
1874
1875 do iqq=1,4
1876 vv=qgcutp(sys,xp,xm,bb,vvx,icdp,icdt,icz,iqq)
1877 if(vv.gt.0.d0)then
1878 qpomc(iy,ix1+10*(ix2-1),iz,iv,icdp+2*(icdt-1)+4*(icz-1)
1879 * +12*(iqq-1))=dlog(vv/z)
1880 elseif(iy.gt.2)then
1881 qpomc(iy,ix1+10*(ix2-1),iz,iv,icdp+2*(icdt-1)+4*(icz-1)
1882 * +12*(iqq-1))=min(2.d0*qpomc(iy-1,ix1+10*(ix2-1),iz,iv
1883 * ,icdp+2*(icdt-1)+4*(icz-1)+12*(iqq-1))-qpomc(iy-2
1884 * ,ix1+10*(ix2-1),iz,iv,icdp+2*(icdt-1)+4*(icz-1)+12*(iqq-1))
1885 * ,qpomc(iy-1,ix1+10*(ix2-1),iz,iv,icdp+2*(icdt-1)+4*(icz-1)
1886 * +12*(iqq-1)))
1887 else
1888 qpomc(iy,ix1+10*(ix2-1),iz,iv,icdp+2*(icdt-1)+4*(icz-1)
1889 * +12*(iqq-1))=qpomc(iy-1,ix1+10*(ix2-1),iz,iv,icdp+2*(icdt-1)
1890 * +4*(icz-1)+12*(iqq-1))
1891 endif
1892 qpomc(iy,ix1+10*(ix2-1),iz,iv,icdp+2*(icdt-1)+4*(icz-1)
1893 * +12*(iqq-1))=max(qpomc(iy,ix1+10*(ix2-1),iz,iv,icdp
1894 * +2*(icdt-1)+4*(icz-1)+12*(iqq-1)),-20.d0)
1895
1896 if(.not.(qpomc(iy,ix1+10*(ix2-1),iz,iv,icdp+2*(icdt-1)+4*(icz
1897 * -1)+12*(iqq-1)).le.0.d0.or.qpomc(iy,ix1+10*(ix2-1),iz,iv,icdp
1898 * +2*(icdt-1)+4*(icz-1)+12*(iqq-1)).gt.0.d0))stop'qpomc-nan'
1899 enddo
1900 enddo
1901 enddo
1902 enddo
1903 enddo
1904 enddo
1905 endif
1906 enddo
1907 enddo
1908 enddo
1909
1910
1911
1912 if(debug.ge.1)write (moniou,221)
1913 do m=1,2 !parton type (1-g, 2-q)
1914 fsud(1,m)=0.d0
1915 do k=2,10
1916 qmax=qtf*4.d0**(1.d0+k) !effective virtuality (qt**2/z**2/(1-z)**2)
1917 fsud(k,m)=qgsudt(qmax,m)
1918 enddo
1919 enddo
1920
1921
1922 if(debug.ge.1)write (moniou,222)
1923 do m=1,2 !parton type (1-g, 2-q)
1924 do k=1,10
1925 qlmax=1.38629d0*(k-1)
1926 qrt(k,1,m)=0.d0
1927 qrt(k,101,m)=qlmax
1928 do i=1,99 !bins in Sudakov formfactor
1929 if(k.eq.1)then
1930 qrt(k,i+1,m)=0.d0
1931 else
1932 qrt(k,i+1,m)=qgroot(qlmax,.01d0*i,m)
1933 endif
1934 enddo
1935 enddo
1936 enddo
1937
1938
1939
1940 if(debug.ge.1)write (moniou,220)
1941 if(ifIIdat.ne.1)then
1942 open(1,file=DATDIR(1:INDEX(DATDIR,' ')-1)//'qgsdat-II-04'
1943 * ,status='unknown')
1944 else !used to link with nexus
1945 open(ifIIdat,file=fnIIdat(1:nfnIIdat),status='unknown')
1946 endif
1947 write (1,*)csborn,cs0,cstot,evk,qpomi,qpomis,qlegi,qfanu,qfanc
1948 *,qdfan,qpomr,gsect,qlegc0,qlegc,qpomc,fsud,qrt,qrev,fsud,qrt
1949 close(1)
1950
1951 10 continue
1952
1953
1954 if(ifIIncs.ne.2)then
1955 inquire(file=DATDIR(1:INDEX(DATDIR,' ')-1)//'sectnu-II-04'
1956 * ,exist=lcalc)
1957 else !ctp
1958 inquire(file=fnIIncs(1:nfnIIncs),exist=lcalc)
1959 endif
1960
1961 if(lcalc)then
1962 if(debug.ge.0)write (moniou,207)
1963 if(ifIIncs.ne.2)then
1964 open(2,file=DATDIR(1:INDEX(DATDIR,' ')-1)//'sectnu-II-04'
1965 * ,status='old')
1966 else !ctp
1967 open(ifIIncs,file=fnIIncs(1:nfnIIncs),status='old')
1968 endif
1969 read (2,*)qgsasect
1970 close(2)
1971
1972 elseif(.not.producetables)then
1973 write(moniou,*) "Missing sectnu-II-04 file !"
1974 write(moniou,*) "Please correct the defined path ",
1975 &"or force production ..."
1976 stop
1977
1978 else
1979 niter=5000 !number of iterations
1980 do ie=1,10
1981 e0n=10.d0**ie !interaction energy (per nucleon)
1982 do iia1=1,6
1983 iap=2**iia1 !proj. mass number
1984 do iia2=1,6
1985 if(iia2.le.4)then
1986 iat=4**(iia2-1) !targ. mass number
1987 elseif(iia2.eq.5)then
1988 iat=14
1989 else
1990 iat=40
1991 endif
1992 if(debug.ge.1)write (moniou,208)e0n,iap,iat
1993
1994 call qgini(e0n,2,iap,iat)
1995 call qgcrossc(niter,gtot,gprod,gabs,gdd,gqel,gcoh)
1996 if(debug.ge.1)write (moniou,209)gtot,gprod,gabs,gdd,gqel,gcoh
1997 qgsasect(ie,iia1,iia2)=log(gprod)
1998 enddo
1999 enddo
2000 enddo
2001 if(ifIIncs.ne.2)then
2002 open(2,file=DATDIR(1:INDEX(DATDIR,' ')-1)//'sectnu-II-04'
2003 * ,status='unknown')
2004 else !ctp
2005 open(ifIIncs,file=fnIIncs(1:nfnIIncs),status='unknown')
2006 endif
2007 write (2,*)qgsasect
2008 close(2)
2009 endif
2010
2011 if(debug.ge.3)write (moniou,218)
2012 201 format(2x,'qgaini: hard cross sections calculation')
2013 202 format(2x,'qgaini: number of rungs considered:',i2
2014 */4x,'starting energy bin for ordered and general ladders:',3i4)
2015 205 format(2x,'qgaini: pretabulation of the interaction eikonals')
2016 206 format(2x,'qgaini: initial particle energy:',e10.3,2x
2017 *,'its type:',a7,2x,'target mass number:',i2)
2018 207 format(2x,'qgaini: nuclear cross sections readout from the file'
2019 *,' sectnu-II-04')
2020 208 format(2x,'qgaini: initial nucleus energy:',e10.3,2x
2021 *,'projectile mass:',i2,2x,'target mass:',i2)
2022 209 format(2x,'gtot',d10.3,' gprod',d10.3,' gabs',d10.3
2023 */2x,'gdd',d10.3,' gqel',d10.3,' gcoh',d10.3)
2024 210 format(2x,'qgaini - main initialization procedure')
2025 212 format(2x,'qgaini: integrated Pomeron leg eikonals')
2026 213 format(2x,'qgaini: integrated fan contributions')
2027 214 format(2x,'qgaini: cross sections readout from the file: ', A,2x)
2028
2029 215 format(2x,'qgaini: integrated cut fan contributions')
2030
2031 218 format(2x,'qgaini - end')
2032 220 format(2x,'qgaini: cross sections are written to the file'
2033 *,' qgsdat-II-04')
2034 221 format(2x,'qgaini: timelike Sudakov formfactor')
2035 222 format(2x,'qgaini: effective virtuality for inversion')
2036 223 format(2x,'qgaini: cut Pomeron leg eikonals')
2037 224 format(2x,'qgaini: hadron-nucleus cross sections:'
2038 */4x,'gin=',e10.3,2x,'gdifr_targ=',e10.3,2x
2039 *,'gdifr_proj=',e10.3)
2040 225 format(2x,'qgaini: hadron-proton cross sections:'
2041 */4x,'gtot=',e10.3,2x,'gin=',e10.3,2x,'gel=',e10.3/4x
2042 *,'gdifrp=',e10.3,2x,'gdifrt=',e10.3,2x,'b_el=',e10.3,2x)
2043 226 format(2x,'qgaini: cut Pomeron eikonals (semi-hard)')
2044 return
2045 end
2046
2047
2048 subroutine qgini(e0n,icp0,iap,iat)
2049
2050
2051
2052
2053
2054
2055
2056
2057 implicit double precision (a-h,o-z)
2058 integer debug
2059 parameter(iapmax=208)
2060 common /qgarr1/ ia(2),icz,icp
2061 common /qgarr2/ scm,wp0,wm0
2062 common /qgarr4/ ey0(3)
2063 common /qgarr5/ rnuc(2),wsnuc(2),wbnuc(2),anorm
2064 *,cr1(2),cr2(2),cr3(2)
2065 common /qgarr6/ pi,bm,amws
2066 common /qgarr7/ xa(iapmax,3),xb(iapmax,3),b
2067 common /qgarr10/ am(7),ammu
2068 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
2069 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
2070 common /qgarr43/ moniou
2071 common /arr1/ trnuc(56),twsnuc(56),twbnuc(56)
2072 common /qgdebug/ debug
2073 common /qgsIInex1/xan(iapmax,3),xbn(iapmax,3) !used to link with nexus
2074 *,bqgs,bmaxqgs,bmaxnex,bminnex
2075
2076 if(debug.ge.1)write (moniou,201)icp0,iap,iat,e0n
2077 icp=icp0
2078 ia(1)=iap
2079 ia(2)=iat
2080
2081 icz=iabs(icp)/2+1 !!!!!particle class (1 - pion, 2 - nucleon, 3 - kaon)
2082
2083 scm=2.d0*e0n*am(2)+am(2)**2+am(icz)**2 !c.m. energy squared
2084 ey0(1)=dsqrt(scm)/(e0n+am(2)+dsqrt(e0n-am(icz))
2085 **dsqrt(e0n+am(icz))) !Lorentz boost to lab. frame
2086 ey0(2)=1.d0
2087 ey0(3)=1.d0
2088 wp0=dsqrt(scm) !initial LC+ mometum
2089 wm0=wp0 !initial LC- mometum
2090
2091
2092
2093 do i=1,2
2094 if(ia(i).lt.10.and.ia(i).ne.1)then !gaussian density
2095 rnuc(i)=.9d0*float(ia(i))**.3333 !nuclear radius
2096 if(ia(i).eq.2)rnuc(i)=3.16d0
2097
2098 rnuc(i)=rnuc(i)*dsqrt(2.d0*ia(i)/(ia(i)-1.d0))
2099 !rnuc -> rnuc*a/(a-1) - to use Van-Hove method
2100 elseif(ia(i).ne.1)then
2101 if(ia(i).le.56)then !3-parameter Fermi
2102 rnuc(i)=trnuc(ia(i)) !nuclear radius
2103 wsnuc(i)=twsnuc(ia(i)) !diffuseness
2104 wbnuc(i)=twbnuc(ia(i)) !'wine-bottle' parameter
2105 else
2106 rnuc(i)=1.19*float(ia(i))**(1./3.)-1.38*float(ia(i))**(-1./3.)
2107 wsnuc(i)=amws !diffuseness
2108 wbnuc(i)=0.d0
2109 endif
2110 cr1(i)=1.d0+3.d0/rnuc(i)*wsnuc(i)+6.d0/(rnuc(i)/wsnuc(i))**2
2111 * +6.d0/(rnuc(i)/wsnuc(i))**3
2112 cr2(i)=3.d0/rnuc(i)*wsnuc(i)
2113 cr3(i)=3.d0/rnuc(i)*wsnuc(i)+6.d0/(rnuc(i)/wsnuc(i))**2
2114 endif
2115 enddo
2116
2117 if(ia(1).ne.1)then !primary nucleus
2118 bm=rnuc(1)+rnuc(2)+5.d0*max(wsnuc(1),wsnuc(2)) !b-cutoff
2119 elseif(ia(2).ne.1)then !hadron-nucleus
2120 bm=rnuc(2)+5.d0*wsnuc(2) !b-cutoff
2121 else !hadron-proton
2122 bm=3.d0*dsqrt((rq(1,icz)+rq(1,2)+alfp*log(scm))*4.d0*.0398d0)
2123 endif
2124
2125 bmaxqgs=bm !used to link with nexus
2126
2127 if(debug.ge.3)write (moniou,202)
2128 201 format(2x,'qgini - miniinitialization: particle type icp0=',
2129 *i2,2x,'projectile mass number iap=',i2/4x,
2130 *'target mass number iat=',i2,' interaction energy e0n=',e10.3)
2131 202 format(2x,'qgini - end')
2132 return
2133 end
2134
2135
2136 double precision function qgpint(sy,bb)
2137
2138
2139
2140
2141
2142 implicit double precision (a-h,o-z)
2143 integer debug
2144 common /qgarr6/ pi,bm,amws
2145 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
2146 common /qgarr18/ alm,qt0,qtf,betp,dgqq
2147 common /qgarr26/ factk,fqscal
2148 common /qgarr43/ moniou
2149 common /qgdebug/ debug
2150 common /arr3/ x1(7),a1(7)
2151
2152 if(debug.ge.2)write (moniou,201)sy,bb
2153
2154 qgpint=0.d0
2155 s2min=4.d0*fqscal*qt0
2156 xmin=s2min/sy
2157 if(xmin.ge.1.d0)return
2158
2159 xmin=xmin**(delh-dels)
2160
2161 do i=1,7
2162 do m=1,2
2163 z1=(.5d0*(1.d0+xmin-(2*m-3)*x1(i)*(1.d0-xmin)))
2164 * **(1.d0/(delh-dels))
2165 ww=z1*sy
2166 sjqq=qgjit(qt0,qt0,ww,2,2) !inclusive qq cross-section
2167 sjqg=qgjit(qt0,qt0,ww,1,2) !inclusive qg cross-section
2168 sjgg=qgjit(qt0,qt0,ww,1,1) !inclusive gg cross-section
2169
2170 st2=0.d0
2171 do j=1,7
2172 do k=1,2
2173 xx=.5d0*(1.d0+x1(j)*(2*k-3))
2174 xp=z1**xx
2175 xm=z1/xp
2176 glu1=qgppdi(xp,0)
2177 sea1=qgppdi(xp,1)
2178 glu2=qgppdi(xm,0)
2179 sea2=qgppdi(xm,1)
2180 st2=st2+a1(j)*(glu1*glu2*sjgg+(glu1*sea2+glu2*sea1)*sjqg
2181 * +sea1*sea2*sjqq)
2182 enddo
2183 enddo
2184 rh=-alfp*dlog(z1)
2185 qgpint=qgpint-a1(i)*dlog(z1)/z1**delh*st2
2186 * *exp(-bb/(4.d0*.0389d0*rh))/rh
2187 enddo
2188 enddo
2189 qgpint=qgpint*(1.d0-xmin)/(delh-dels)*factk*rr**2/2.d0*pi
2190
2191 if(debug.ge.3)write (moniou,202)qgpint
2192 201 format(2x,'qgpint - interm. Pomeron eikonal:'
2193 */4x,'sy=',e10.3,2x,'bb=',e10.3)
2194 202 format(2x,'qgpint=',e10.3)
2195 return
2196 end
2197
2198
2199 double precision function qgpini(sy,bb,vvx,vvxt,iqq)
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245 implicit double precision (a-h,o-z)
2246 integer debug
2247 dimension wk(3),wz(3),wi(3),wj(3)
2248 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
2249 common /qgarr18/ alm,qt0,qtf,betp,dgqq
2250 common /qgarr20/ spmax
2251 common /qgarr26/ factk,fqscal
2252 common /qgarr39/ qpomi(51,11,15),qpomis(51,11,11,11,9)
2253 common /qgarr43/ moniou
2254 common /qgdebug/ debug
2255
2256 qgpini=0.d0
2257 pinm=0.d0
2258 s2min=4.d0*fqscal*qt0
2259 rp=alfp*dlog(sy)*4.d0*.0389d0
2260 z=exp(-bb/rp)
2261 if(iqq.le.1.and.(sy.le.s2min.or.iqq.eq.0))goto 1
2262
2263 yl=log(sy/sgap)/log(spmax/sgap)*50.d0+1.d0
2264 k=max(1,int(1.00001d0*yl-1.d0))
2265 k=min(k,49)
2266 wk(2)=yl-k
2267 if(yl.le.2.d0)then
2268 iymax=2
2269 wk(1)=1.d0-wk(2)
2270 else
2271 wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
2272 wk(1)=1.d0-wk(2)+wk(3)
2273 wk(2)=wk(2)-2.d0*wk(3)
2274 iymax=3
2275 endif
2276
2277 if(z.gt..2d0)then
2278 zz=5.d0*z+6.d0
2279 else
2280 zz=(-bb/rp-dlog(0.2d0))/2.d0+7.d0
2281 endif
2282 jz=min(9,int(zz))
2283 jz=max(1,jz)
2284 if(zz.lt.1.d0)then
2285 wz(2)=zz-jz
2286 wz(1)=1.d0-wz(2)
2287 izmax=2
2288 else
2289 if(jz.eq.6)jz=5
2290 wz(2)=zz-jz
2291 wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
2292 wz(1)=1.d0-wz(2)+wz(3)
2293 wz(2)=wz(2)-2.d0*wz(3)
2294 izmax=3
2295 endif
2296
2297 if(iqq.le.15)then
2298 iqr=iqq
2299 if(sy.le.sgap**2.and.iqq.le.12)iqr=1
2300 do l1=1,izmax
2301 l2=jz+l1-1
2302 do k1=1,iymax
2303 k2=k+k1-1
2304 qgpini=qgpini+qpomi(k2,l2,iqr)*wk(k1)*wz(l1)
2305 enddo
2306 enddo
2307 if(zz.lt.1.d0)then
2308 do k1=1,iymax
2309 k2=k+k1-1
2310 pinm=pinm+qpomi(k2,1,iqr)*wk(k1)
2311 enddo
2312 qgpini=min(qgpini,pinm)
2313 endif
2314
2315 else
2316 vi=vvx*10.d0+1.d0
2317 i=max(1,int(vi))
2318 i=min(i,9)
2319 wi(2)=vi-i
2320 wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
2321 wi(1)=1.d0-wi(2)+wi(3)
2322 wi(2)=wi(2)-2.d0*wi(3)
2323
2324 if(iqq.le.19)then
2325 do i1=1,3
2326 i2=i+i1-1
2327 do l1=1,izmax
2328 l2=jz+l1-1
2329 do k1=1,iymax
2330 k2=k+k1-1
2331 qgpini=qgpini+qpomis(k2,l2,i2,1,iqq-15)*wk(k1)*wz(l1)*wi(i1)
2332 enddo
2333 enddo
2334 enddo
2335 if(zz.lt.1.d0)then
2336 do i1=1,3
2337 i2=i+i1-1
2338 do k1=1,iymax
2339 k2=k+k1-1
2340 pinm=pinm+qpomis(k2,1,i2,1,iqq-15)*wk(k1)*wi(i1)
2341 enddo
2342 enddo
2343 qgpini=min(qgpini,pinm)
2344 endif
2345
2346 else
2347 vj=vvxt*10.d0+1.d0
2348 j=max(1,int(vj))
2349 j=min(j,9)
2350 wj(2)=vj-j
2351 wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
2352 wj(1)=1.d0-wj(2)+wj(3)
2353 wj(2)=wj(2)-2.d0*wj(3)
2354 jmax=3
2355
2356 do j1=1,jmax
2357 j2=j+j1-1
2358 do i1=1,3
2359 i2=i+i1-1
2360 do l1=1,izmax
2361 l2=jz+l1-1
2362 do k1=1,iymax
2363 k2=k+k1-1
2364 qgpini=qgpini+qpomis(k2,l2,i2,j2,iqq-15)
2365 * *wk(k1)*wz(l1)*wi(i1)*wj(j1)
2366 enddo
2367 enddo
2368 enddo
2369 enddo
2370 if(zz.lt.1.d0)then
2371 do j1=1,jmax
2372 j2=j+j1-1
2373 do i1=1,3
2374 i2=i+i1-1
2375 do k1=1,iymax
2376 k2=k+k1-1
2377 pinm=pinm+qpomis(k2,1,i2,j2,iqq-15)*wk(k1)*wi(i1)*wj(j1)
2378 enddo
2379 enddo
2380 enddo
2381 qgpini=min(qgpini,pinm)
2382 endif
2383 endif
2384 endif
2385 1 qgpini=exp(qgpini)
2386 if(iqq.le.16.or.iqq.eq.19)qgpini=qgpini
2387 **sy**dels*sigs*g3p**2*z/rp*4.d0*.0389d0
2388 return
2389 end
2390
2391
2392 double precision function qgleg(sy,bb,icdp,icz)
2393
2394
2395
2396
2397
2398
2399 implicit double precision (a-h,o-z)
2400 integer debug
2401 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
2402 common /qgarr19/ ahl(3)
2403 common /qgarr25/ ahv(3)
2404 common /qgarr43/ moniou
2405 common /qgdebug/ debug
2406 common /arr3/ x1(7),a1(7)
2407
2408 if(debug.ge.2)write (moniou,201)sy,bb,icz
2409
2410 qgleg=0.d0
2411 if(sy.lt.1.001d0)then
2412 tmin=1.d0
2413 else
2414 tmin=(1.d0-(1.d0-1.d0/sy)**(1.+ahl(icz)))**(1.+dels)
2415 endif
2416 if(debug.ge.3)write (moniou,203)tmin
2417 do i1=1,7
2418 do m1=1,2
2419 tp=1.d0-(.5d0*(1.d0+tmin)+x1(i1)*(m1-1.5d0)*(1.d0-tmin))
2420 * **(1./(1.+dels))
2421 if(tp.gt.1.d-9)then
2422 xp=1.d0-tp**(1.d0/(1.d0+ahl(icz)))
2423 else
2424 xp=1.d0
2425 endif
2426
2427 ws=qgls(xp*sy,xp,bb,icdp,icz)
2428 wg=qglsh(xp*sy,xp,bb,icdp,icz,0)
2429 wq=qglsh(xp*sy,xp,bb,icdp,icz,1)/dsqrt(xp)
2430 * *(1.d0-xp)**(ahv(icz)-ahl(icz))
2431
2432 qgleg=qgleg+a1(i1)*(ws+wg+wq)/(1.d0-tp)**dels
2433 enddo
2434 enddo
2435 qgleg=qgleg/2.d0/(1.+ahl(icz))/(1.d0+dels)
2436
2437 if(debug.ge.3)write (moniou,202)qgleg
2438 201 format(2x,'qgleg - Pomeron leg eikonal:'
2439 */4x,'s=',e10.3,2x,'b^2=',e10.3,2x,'icz=',i1)
2440 202 format(2x,'qgleg=',e10.3)
2441 203 format(2x,'qgleg:',2x,'tmin=',e10.3)
2442 return
2443 end
2444
2445
2446 double precision function qglegi(sy,bb,icdp,icz,iqq)
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461 implicit double precision (a-h,o-z)
2462 integer debug
2463 dimension wk(3),wz(3)
2464 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
2465 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
2466 common /qgarr19/ ahl(3)
2467 common /qgarr20/ spmax
2468 common /qgarr27/ qlegi(51,11,2,3,7),qfanu(51,11,11,6,2)
2469 *,qfanc(51,11,11,39,18),qdfan(21,11,11,2,3),qrev(11,11,66,219,2)
2470 common /qgarr43/ moniou
2471 common /qgdebug/ debug
2472
2473 qglegi=0.d0
2474 xlegm=0.d0
2475 rp=(rq(icdp,icz)+alfp*log(sy))*4.d0*.0389d0
2476 z=exp(-bb/rp)
2477 if(z.gt..2d0)then
2478 zz=5.d0*z+6.d0
2479 else
2480 zz=(-bb/rp-dlog(0.2d0))/2.d0+7.d0
2481 endif
2482 jz=min(9,int(zz))
2483 jz=max(1,jz)
2484 if(zz.lt.1.d0)then
2485 wz(2)=zz-jz
2486 wz(1)=1.d0-wz(2)
2487 izmax=2
2488 else
2489 if(jz.eq.6)jz=5
2490 wz(2)=zz-jz
2491 wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
2492 wz(1)=1.d0-wz(2)+wz(3)
2493 wz(2)=wz(2)-2.d0*wz(3)
2494 izmax=3
2495 endif
2496
2497 yl=log(sy/sgap)/log(spmax/sgap)*50.d0+1.d0
2498 k=max(1,int(yl))
2499 k=min(k,49)
2500 wk(2)=yl-k
2501 wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
2502 wk(1)=1.d0-wk(2)+wk(3)
2503 wk(2)=wk(2)-2.d0*wk(3)
2504 iymax=3
2505
2506 iqr=iqq
2507 if(sy.le.sgap**2)iqr=1
2508 do l1=1,izmax
2509 l2=jz+l1-1
2510 do k1=1,iymax
2511 k2=k+k1-1
2512 qglegi=qglegi+qlegi(k2,l2,icdp,icz,iqr)*wk(k1)*wz(l1)
2513 enddo
2514 enddo
2515 if(zz.lt.1.d0)then
2516 do k1=1,iymax
2517 k2=k+k1-1
2518 xlegm=xlegm+qlegi(k2,1,icdp,icz,iqr)*wk(k1)
2519 enddo
2520 qglegi=min(qglegi,xlegm)
2521 endif
2522 qglegi=exp(qglegi)*z
2523 **(1.d0-(1.d0-(1.d0-1.d0/sy)**(1.+ahl(icz)))**(1.+dels))
2524 return
2525 end
2526
2527
2528 double precision function qgls(sy,xp,bb,icdp,icz)
2529
2530
2531
2532
2533
2534
2535
2536
2537 implicit double precision (a-h,o-z)
2538 integer debug
2539 common /qgarr6/ pi,bm,amws
2540 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
2541 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
2542 common /qgarr43/ moniou
2543 common /qgdebug/ debug
2544
2545 if(debug.ge.2)write (moniou,201)sy,bb,icz
2546
2547 rp=rq(icdp,icz)+alfp*log(sy/xp)
2548 qgls=sy**dels*fp(icz)*g3p*sigs/rp*exp(-bb/(4.d0*.0389d0*rp))
2549 **cd(icdp,icz)
2550
2551 if(debug.ge.3)write (moniou,202)qgls
2552 201 format(2x,'qgls - soft pomeron leg eikonal:'
2553 */4x,'sy=',e10.3,2x,'b^2=',e10.3,2x,'icz=',i1)
2554 202 format(2x,'qgls=',e10.3)
2555 return
2556 end
2557
2558
2559 double precision function qglsh(sy,xp,bb,icdp,icz,iqq)
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569 implicit double precision (a-h,o-z)
2570 integer debug
2571 common /qgarr6/ pi,bm,amws
2572 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
2573 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
2574 common /qgarr18/ alm,qt0,qtf,betp,dgqq
2575 common /qgarr19/ ahl(3)
2576 common /qgarr25/ ahv(3)
2577 common /qgarr26/ factk,fqscal
2578 common /qgarr43/ moniou
2579 common /qgdebug/ debug
2580 common /arr3/ x1(7),a1(7)
2581
2582 if(debug.ge.2)write (moniou,201)sy,bb,icz
2583
2584 qglsh=0.d0
2585 s2min=4.d0*fqscal*qt0
2586 if(sy.lt.1.001d0*s2min)return
2587
2588 xmin=(s2min/sy)**(delh-dels)
2589
2590 do i1=1,7
2591 do m1=1,2
2592 zh=(.5d0*(1.d0+xmin-(2*m1-3)*x1(i1)*(1.d0-xmin)))
2593 * **(1.d0/(delh-dels))
2594 ww=zh*sy !c.m. energy squared for hard interaction
2595 sjqq=qgjit(qt0,qt0,ww,2,2)
2596 sjqg=qgjit(qt0,qt0,ww,1,2)
2597 sjgg=qgjit(qt0,qt0,ww,1,1)
2598 if(debug.ge.3)write (moniou,203)ww,sjqq+sjqg+sjgg
2599
2600 if(iqq.eq.0)then
2601 stg=0.d0
2602 do i2=1,7
2603 do m2=1,2
2604 xx=.5d0*(1.d0+x1(i2)*(2*m2-3))
2605 xph=zh**xx
2606 xmh=zh/xph
2607 glu1=qgppdi(xph,0)
2608 sea1=qgppdi(xph,1)
2609 glu2=qgppdi(xmh,0)
2610 sea2=qgppdi(xmh,1)
2611 rh=rq(icdp,icz)-alfp*dlog(zh*xp)
2612
2613 stsum=(glu1*glu2*sjgg+(glu1*sea2+glu2*sea1)*sjqg
2614 * +sea1*sea2*sjqq)*exp(-bb/(4.d0*.0389d0*rh))/rh
2615 stg=stg+a1(i2)*stsum
2616 enddo
2617 enddo
2618 qglsh=qglsh-a1(i1)*dlog(zh)/zh**delh*stg
2619
2620 elseif(iqq.eq.1)then
2621 xmh=zh
2622 glu2=qgppdi(xmh,0)
2623 sea2=qgppdi(xmh,1)
2624 rh=rq(icdp,icz)-alfp*dlog(zh)
2625
2626 stq=(glu2*sjqg+sea2*sjqq)*exp(-bb/(4.d0*.0389d0*rh))/rh
2627 qglsh=qglsh+a1(i1)/zh**delh*stq
2628 * *(qggrv(xp,qt0,icz,1)+qggrv(xp,qt0,icz,2))/dsqrt(xp)
2629 endif
2630 enddo
2631 enddo
2632 if(iqq.eq.0)then
2633 qglsh=qglsh*rr**2*(1.d0-xmin)/(delh-dels)*fp(icz)*g3p*factk
2634 * /2.d0*pi*cd(icdp,icz)
2635 elseif(iqq.eq.1)then
2636 qglsh=qglsh*rr*(1.d0-xmin)/(delh-dels)*g3p*factk/4.d0
2637 * *cd(icdp,icz)
2638 endif
2639
2640 if(debug.ge.3)write (moniou,202)qglsh
2641 201 format(2x,'qglsh - unintegrated Pomeron leg eikonal:'
2642 */4x,'s=',e10.3,2x,'b^2=',e10.3,2x,'icz=',i1)
2643 202 format(2x,'qglsh=',e10.3)
2644 203 format(2x,'qglsh:',2x,'s_hard=',e10.3,2x,'sigma_hard=',e10.3)
2645 return
2646 end
2647
2648
2649 subroutine qgloop(sy,bb,fann,jj)
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671 implicit double precision (a-h,o-z)
2672 integer debug
2673 dimension fann(14)
2674 common /qgarr6/ pi,bm,amws
2675 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
2676 common /qgarr43/ moniou
2677 common /qgdebug/ debug
2678 common /arr3/ x1(7),a1(7)
2679
2680 do iqq=1,14
2681 fann(iqq)=0.d0
2682 enddo
2683 if(sy.le.sgap**2)goto 1
2684 do ix1=1,7
2685 do mx1=1,2
2686 xpomr=(sy/sgap**2)**(-.5d0-x1(ix1)*(mx1-1.5d0))/sgap
2687 rp=-alfp*log(xpomr)*4.d0*.0389d0
2688 rp1=alfp*log(xpomr*sy)*4.d0*.0389d0
2689 rp2=rp*rp1/(rp+rp1)
2690 do ix2=1,7
2691 do mx2=1,2
2692 z=.5d0+x1(ix2)*(mx2-1.5d0)
2693 bb0=-rp2*log(z)
2694 do ix3=1,7
2695 do mx3=1,2
2696 phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
2697 bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
2698 * +bb0*sin(phi)**2
2699 bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
2700 * +bb0*sin(phi)**2
2701
2702 vi=qgpini(xpomr*sy,bb1,0.d0,0.d0,1)
2703 vit=min(vi,qgpini(xpomr*sy,bb1,0.d0,0.d0,2))
2704 v1i0=qgpini(1.d0/xpomr,bb2,0.d0,0.d0,4)
2705 v1i1=min(v1i0,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,3))
2706 v1i=min(v1i1,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,2))
2707 if(jj.eq.1)then
2708 do iqq=1,3
2709 if(iqq.eq.1)then
2710 dpx=vi*(min(0.d0,1.d0-exp(-v1i)-v1i)+v1i-v1i1)
2711 * +min(0.d0,1.d0-exp(-vit)-vit)*(1.d0-exp(-v1i))
2712 elseif(iqq.eq.2)then
2713 dpx=vi*(min(0.d0,1.d0-exp(-v1i)-v1i)+v1i-v1i1)
2714 elseif(iqq.eq.3)then
2715 dpx=vi*(v1i1-v1i0)
2716 else
2717 dpx=0.d0
2718 endif
2719 fann(iqq)=fann(iqq)+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
2720 enddo
2721
2722 else
2723 v1ic0=min(v1i0,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,7))
2724 v1ic1=min(v1ic0,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,6))
2725 v1ic=min(v1ic1,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,5))
2726 v1icn=min(v1i,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,8))
2727 vict=min(vit,qgpini(xpomr*sy,bb1,0.d0,0.d0,5))
2728 victn=min(vit,qgpini(xpomr*sy,bb1,0.d0,0.d0,8))
2729 victg=min(victn,qgpini(xpomr*sy,bb1,0.d0,0.d0,11))
2730 vict1=min(victg,qgpini(xpomr*sy,bb1,0.d0,0.d0,9))
2731
2732 vis=min(vi,qgpini(xpomr*sy,bb1,0.d0,0.d0,0))
2733 v1ic0s=min(v1ic0,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,15))
2734 v1ic1s=min(v1ic0s,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,14))
2735 v1ics=min(v1ic1s,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,13))
2736 victs=min(vict,qgpini(xpomr*sy,bb1,0.d0,0.d0,13))
2737 do iqq=4,14
2738 if(iqq.eq.4)then
2739 dpx=vi*(v1ic*exp(-2.d0*v1icn)-v1ic1)
2740 * +vict*(exp(-2.d0*victn)-1.d0)*v1ic*exp(-2.d0*v1icn)
2741 elseif(iqq.eq.5)then
2742 dpx=vi*(v1ic*exp(-2.d0*v1icn)-v1ic1)
2743 elseif(iqq.eq.6)then
2744 dpx=vi*(v1ic1-v1ic0)
2745 elseif(iqq.eq.7)then
2746 dpx=vi*(min(0.d0,1.d0-exp(-v1i)-v1i)+v1i-v1i1)
2747 * +.5d0*min(0.d0,1.d0-exp(-vit)-vit)*(1.d0-exp(-2.d0*v1icn))
2748 * +.5d0*min(0.d0,1.d0-exp(-2.d0*victn)-2.d0*victn)
2749 * *max(0.d0,1.d0-exp(-v1i)-.5d0*(1.d0-exp(-2.d0*v1icn)))
2750 elseif(iqq.eq.8)then
2751 dpx=vi*(min(0.d0,1.d0-exp(-v1i)-v1i)+v1i-v1i1)
2752 * +vict1*(exp(-2.d0*victn)-1.d0)*(1.d0-exp(-v1i))
2753 elseif(iqq.eq.9)then
2754 dpx=vi*(v1i1-v1i0)
2755 * +vict1*(exp(-2.d0*victn)-1.d0)*v1i1
2756 elseif(iqq.eq.10)then
2757 dpx=vi*(min(0.d0,1.d0-exp(-v1i)-v1i)+v1i-v1i1)
2758 * +(.5d0*max(0.d0,1.d0-exp(-2.d0*victn)-2.d0*victn
2759 * *exp(-2.d0*victn))+victg*(exp(-2.d0*victn)-1.d0))
2760 * *(1.d0-exp(-v1i))
2761 elseif(iqq.eq.11)then
2762 dpx=vi*(v1i1-v1i0)
2763 * +(.5d0*max(0.d0,1.d0-exp(-2.d0*victn)-2.d0*victn
2764 * *exp(-2.d0*victn))+victg*(exp(-2.d0*victn)-1.d0))*v1i1
2765 elseif(iqq.eq.12)then
2766 dpx=vis*(v1ics*exp(-2.d0*v1icn)-v1ic1s)
2767 * +victs*(exp(-2.d0*victn)-1.d0)*v1ics*exp(-2.d0*v1icn)
2768 elseif(iqq.eq.13)then
2769 dpx=vis*(v1ics*exp(-2.d0*v1icn)-v1ic1s)
2770 elseif(iqq.eq.14)then
2771 dpx=vis*(v1ic1s-v1ic0s)
2772 else
2773 dpx=0.d0
2774 endif
2775 fann(iqq)=fann(iqq)+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
2776 enddo
2777 endif
2778 enddo
2779 enddo
2780 enddo
2781 enddo
2782 enddo
2783 enddo
2784 1 dpin=qgpini(sy,bb,0.d0,0.d0,1)
2785 do iqq=1,11
2786 fann(iqq)=fann(iqq)*log(sy/sgap**2)/8.d0*pi*r3p/.0389d0/g3p**3
2787 * +dpin
2788 enddo
2789 dpins=min(dpin,qgpini(sy,bb,0.d0,0.d0,0))
2790 do iqq=12,14
2791 fann(iqq)=fann(iqq)*log(sy/sgap**2)/8.d0*pi*r3p/.0389d0/g3p**3
2792 * +dpins
2793 enddo
2794 return
2795 end
2796
2797
2798 subroutine qgloos(sy,bb,vvx,vvxt,fann)
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822 implicit double precision (a-h,o-z)
2823 integer debug
2824 dimension fann(14)
2825 common /qgarr6/ pi,bm,amws
2826 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
2827 common /qgarr43/ moniou
2828 common /qgdebug/ debug
2829 common /arr3/ x1(7),a1(7)
2830
2831 do iqq=1,8
2832 fann(iqq)=0.d0
2833 enddo
2834 if(sy.le.sgap**2)goto 1
2835
2836 do ix1=1,7
2837 do mx1=1,2
2838 xpomr=(sy/sgap**2)**(-.5d0-x1(ix1)*(mx1-1.5d0))/sgap
2839 rp=-alfp*log(xpomr)*4.d0*.0389d0
2840 rp1=alfp*log(xpomr*sy)*4.d0*.0389d0
2841 rp2=rp*rp1/(rp+rp1)
2842 do ix2=1,7
2843 do mx2=1,2
2844 z=.5d0+x1(ix2)*(mx2-1.5d0)
2845 bb0=-rp2*log(z)
2846 do ix3=1,7
2847 do mx3=1,2
2848 phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
2849 bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
2850 * +bb0*sin(phi)**2
2851 bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
2852 * +bb0*sin(phi)**2
2853
2854 vit=qgpini(xpomr*sy,bb1,0.d0,0.d0,2)
2855 vicn=min(vit,qgpini(xpomr*sy,bb1,0.d0,0.d0,8))
2856 vicng=min(vicn,qgpini(xpomr*sy,bb1,0.d0,0.d0,11))
2857 vicpe=min(vicng,qgpini(xpomr*sy,bb1,0.d0,0.d0,9))
2858 vic1=min(vicpe,qgpini(xpomr*sy,bb1,0.d0,0.d0,5))
2859
2860 viu=qgpini(1.d0/xpomr,bb2,0.d0,0.d0,2)
2861 v1icn=min(viu,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,8))
2862 v1i=qgpini(1.d0/xpomr,bb2,vvx,0.d0,16)*exp(-2.d0*v1icn)
2863 vi=qgpini(1.d0/xpomr,bb2,vvx,0.d0,17)*(1.d0-exp(-viu))
2864 vduu=qgpini(1.d0/xpomr,bb2,vvx,vvxt,20)*(1.d0-exp(-viu))
2865 vduc=max(0.d0,vduu-qgpini(1.d0/xpomr,bb2,vvx,vvxt,21)
2866 * *(1.d0-exp(-viu)))
2867 vdcc=qgpini(1.d0/xpomr,bb2,vvx,vvxt,22)*((1.d0-exp(-viu))**2
2868 * +(exp(2.d0*(viu-v1icn))-1.d0)*exp(-2.d0*viu))/2.d0
2869 vdcu=max(0.d0,qgpini(1.d0/xpomr,bb2,vvx,vvxt,23)
2870 * *((1.d0-exp(-viu))**2+(exp(2.d0*(viu-v1icn))-1.d0)
2871 * *exp(-2.d0*viu))/2.d0-vdcc)
2872
2873 do iqq=1,8
2874 if(iqq.eq.1)then !single cut Pomeron
2875 dpx=-vvx*v1i*vic1*exp(-2.d0*vicn)
2876 elseif(iqq.eq.2)then !uncut / cut end / loop sequence
2877 dpx=-(1.d0-exp(-vit))*vi*vvx
2878 elseif(iqq.eq.3)then !no rap-gap at the end
2879 dpx=-(.5d0*max(0.d0,1.d0-exp(-2.d0*vicn)*(1.d0+2.d0*vicn))
2880 * +vicng*exp(-2.d0*vicn))*vi*vvx
2881 elseif(iqq.eq.4)then !single cut Pomeron end
2882 dpx=-vicpe*exp(-2.d0*vicn)*vi*vvx
2883 elseif(iqq.eq.5)then !Puu
2884 dpx=(1.d0-exp(-vit))
2885 * *(vduu*((1.d0-vvx)*(1.d0-vvxt)*(1.d0-vvx*vvxt)-1.d0)
2886 * -vdcu*(1.d0-vvx)**2*(1.d0-vvxt)*vvxt)
2887 elseif(iqq.eq.6)then !Puu-Puc
2888 dpx=(1.d0-exp(-vit))
2889 * *((vduu-vduc)*((1.d0-vvx)*(1.d0-vvxt)*(1.d0-vvx*vvxt)-1.d0)
2890 * -(vdcc+vdcu)*(1.d0-vvx)**2*(1.d0-vvxt)*vvxt)
2891 elseif(iqq.eq.7)then !Pcc
2892 dpx=.5d0*((1.d0-exp(-vit))**2
2893 * +(exp(2.d0*(vit-vicn))-1.d0)*exp(-2.d0*vit))
2894 * *(vdcc*((1.d0-vvx)**2*(1.d0-vvxt)**2-1.d0)
2895 * -vduc*(1.d0-vvx)*(1.d0-vvxt)**2*vvx)
2896 elseif(iqq.eq.8)then !Pcc+Pcu
2897 dpx=.5d0*((1.d0-exp(-vit))**2
2898 * +(exp(2.d0*(vit-vicn))-1.d0)*exp(-2.d0*vit))
2899 * *((vdcc+vdcu)*((1.d0-vvx)**2*(1.d0-vvxt)**2-1.d0)
2900 * +(vduu-vduc)*(1.d0-vvx)*(1.d0-vvxt)**2*vvx)
2901 else
2902 dpx=0.d0
2903 endif
2904 fann(iqq)=fann(iqq)+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
2905 enddo
2906 enddo
2907 enddo
2908 enddo
2909 enddo
2910 enddo
2911 enddo
2912 1 vit=qgpini(sy,bb,0.d0,0.d0,2)
2913 vicn=min(vit,qgpini(sy,bb,0.d0,0.d0,8))
2914 vicng=min(vicn,qgpini(sy,bb,0.d0,0.d0,11))
2915 vicpe=min(vicng,qgpini(sy,bb,0.d0,0.d0,9))
2916 vic1=min(vicpe,qgpini(sy,bb,0.d0,0.d0,5))
2917 do iqq=1,8
2918 fann(iqq)=fann(iqq)*log(sy/sgap**2)/8.d0*pi*r3p/.0389d0/g3p**3
2919 if(iqq.eq.1)then
2920 fann(iqq)=fann(iqq)*exp(2.d0*vicn)+vic1
2921 elseif(iqq.eq.3)then
2922 fann(iqq)=fann(iqq)+vicng*exp(-2.d0*vicn)
2923 * +.5d0*max(0.d0,1.d0-exp(-2.d0*vicn)*(1.d0+2.d0*vicn))
2924 elseif(iqq.eq.4)then
2925 fann(iqq)=fann(iqq)*exp(2.d0*vicn)+vicpe
2926 elseif(iqq.lt.7)then
2927 fann(iqq)=fann(iqq)+(1.d0-exp(-vit))
2928 else
2929 fann(iqq)=fann(iqq)+.5d0*((1.d0-exp(-vit))**2
2930 * +(exp(2.d0*(vit-vicn))-1.d0)*exp(-2.d0*vit))
2931 endif
2932 enddo
2933 return
2934 end
2935
2936
2937 subroutine qglool(sy,bb,icdp,icz,fann)
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950 implicit double precision (a-h,o-z)
2951 integer debug
2952 dimension fann(14)
2953 common /qgarr6/ pi,bm,amws
2954 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
2955 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
2956 common /qgarr19/ ahl(3)
2957 common /qgarr43/ moniou
2958 common /qgdebug/ debug
2959 common /arr3/ x1(7),a1(7)
2960
2961 do iqq=1,6
2962 fann(iqq)=0.d0
2963 enddo
2964 if(sy.le.sgap**2)goto 1
2965
2966 do ix1=1,7
2967 do mx1=1,2
2968 xpomr=(sy/sgap**2)**(-.5d0-x1(ix1)*(mx1-1.5d0))/sgap
2969 rp=(rq(icdp,icz)-alfp*log(xpomr))*4.d0*.0389d0
2970 rp1=alfp*log(xpomr*sy)*4.d0*.0389d0
2971 rp2=rp*rp1/(rp+rp1)
2972 do ix2=1,7
2973 do mx2=1,2
2974 z=.5d0+x1(ix2)*(mx2-1.5d0)
2975 bb0=-rp2*log(z)
2976 do ix3=1,7
2977 do mx3=1,2
2978 phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
2979 bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
2980 * +bb0*sin(phi)**2
2981 bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
2982 * +bb0*sin(phi)**2
2983
2984 vpl=qglegi(1.d0/xpomr,bb2,icdp,icz,1)
2985 v1i0=qgpini(xpomr*sy,bb1,0.d0,0.d0,4)
2986 v1i1=min(v1i0,qgpini(xpomr*sy,bb1,0.d0,0.d0,3))
2987 v1i=min(v1i1,qgpini(xpomr*sy,bb1,0.d0,0.d0,2))
2988 v1ic0=min(v1i0,qgpini(xpomr*sy,bb1,0.d0,0.d0,7))
2989 v1ic1=min(v1ic0,qgpini(xpomr*sy,bb1,0.d0,0.d0,6))
2990 v1ic=min(v1ic1,qgpini(xpomr*sy,bb1,0.d0,0.d0,5))
2991 v1icn=min(v1i,qgpini(xpomr*sy,bb1,0.d0,0.d0,8))
2992 vicn0=min(v1i1,qgpini(xpomr*sy,bb1,0.d0,0.d0,12))
2993 vicn=min(vicn0,qgpini(xpomr*sy,bb1,0.d0,0.d0,11))
2994 vic0=min(vicn0,qgpini(xpomr*sy,bb1,0.d0,0.d0,10))
2995 vic1=min(vic0,qgpini(xpomr*sy,bb1,0.d0,0.d0,9))
2996 vicn=min(vicn,v1icn)
2997 vic1=min(vicn,vic1)
2998 do iqq=1,6
2999 if(iqq.eq.1)then
3000 dpx=vpl*(min(0.d0,1.d0-exp(-v1i)-v1i)+v1i-v1i1)
3001 elseif(iqq.eq.2)then
3002 dpx=vpl*(v1i1-v1i0)
3003 elseif(iqq.eq.3)then
3004 dpx=vpl*(v1ic*exp(-2.d0*v1icn)-v1ic1)
3005 elseif(iqq.eq.4)then
3006 dpx=vpl*(v1ic1-v1ic0)
3007 elseif(iqq.eq.5)then
3008 dpx=vpl*(vic1*exp(-2.d0*v1icn)-vic0)
3009 elseif(iqq.eq.6)then
3010 dpx=vpl*(.5d0*max(0.d0,1.d0-exp(-2.d0*v1icn)-2.d0*v1icn
3011 * *exp(-2.d0*v1icn))+vicn*exp(-2.d0*v1icn)-vicn0)
3012 else
3013 dpx=0.d0
3014 endif
3015 fann(iqq)=fann(iqq)+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
3016 enddo
3017 enddo
3018 enddo
3019 enddo
3020 enddo
3021 enddo
3022 enddo
3023 1 dlool=qglegi(sy,bb,icdp,icz,1)
3024 do iqq=1,6
3025 fann(iqq)=(fann(iqq)*log(sy/sgap**2)/8.d0*pi*r3p/.0389d0/g3p**3
3026 * +dlool)/(1.d0-(1.d0-(1.d0-1.d0/sy)**(1.+ahl(icz)))**(1.+dels))
3027 enddo
3028 return
3029 end
3030
3031
3032 double precision function qgrev(sy,bb,vvxt0,vvxt,vvxpt,vvxp0
3033 *,vvxpl,icdp,icz)
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046 implicit double precision (a-h,o-z)
3047 integer debug
3048 common /qgarr6/ pi,bm,amws
3049 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
3050 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
3051 common /qgarr19/ ahl(3)
3052 common /qgarr43/ moniou
3053 common /qgdebug/ debug
3054 common /arr3/ x1(7),a1(7)
3055
3056 qgrev=0.d0
3057 if(sy.lt..999d0*sgap**2)return
3058
3059 do ix1=1,7
3060 do mx1=1,2
3061 xpomr=(sy/sgap**2)**(-.5d0-x1(ix1)*(mx1-1.5d0))/sgap
3062 rp=(rq(icdp,icz)-alfp*log(xpomr))*4.d0*.0389d0
3063 rp1=alfp*log(xpomr*sy)*4.d0*.0389d0
3064 rp2=rp*rp1/(rp+rp1)
3065 do ix2=1,7
3066 do mx2=1,2
3067 z=.5d0+x1(ix2)*(mx2-1.5d0)
3068 bb0=-rp2*log(z)
3069 do ix3=1,7
3070 do mx3=1,2
3071 phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
3072 bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
3073 * +bb0*sin(phi)**2
3074 bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
3075 * +bb0*sin(phi)**2
3076
3077 vvx=1.d0-(1.d0-vvxt)*(1.d0-vvxpl)
3078 vpf=qgfani(1.d0/xpomr,bb2,vvx,0.d0,0.d0,icdp,icz,1)
3079
3080 viu=qgpini(xpomr*sy,bb1,0.d0,0.d0,2)
3081 viloop=(1.d0-exp(-viu))
3082 vim=2.d0*min(viu,qgpini(xpomr*sy,bb1,0.d0,0.d0,8))
3083
3084 if(vvxt.eq.0.d0)then
3085 vvxpin=1.d0-(1.d0-vvxp0)*(1.d0-vvxpl)*exp(-vpf)
3086 vvxtin=0.d0
3087 vi=max(0.d0,qgpini(xpomr*sy,bb1,vvxpin,vvxtin,21)*viloop
3088 * -qgpini(xpomr*sy,bb1,vvxpin,vvxtin,23)
3089 * *(viloop**2+(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))/2.d0)
3090
3091 dpx=vi*(1.d0-exp(-vpf))
3092 else
3093 vpf0=min(vpf,qgfani(1.d0/xpomr,bb2,vvx,vvxp0,vvxpl,icdp,icz,3))
3094 vpft=max(vpf,qgfani(1.d0/xpomr,bb2,vvx,vvxpt,vvxpl,icdp,icz,6))
3095 vvxpin=1.d0-(1.d0-vvxp0)*(1.d0-vvxpl)*exp(-vpf0)
3096 vvxtin=vvxt0
3097 vi=max(0.d0,qgpini(xpomr*sy,bb1,vvxpin,vvxtin,21)*viloop
3098 * -qgpini(xpomr*sy,bb1,vvxpin,vvxtin,23)
3099 * *(viloop**2+(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))/2.d0)
3100 if(vvxpt.eq.1.d0)then
3101 dpx=vi*(1.d0-exp(-vpft))
3102 else
3103 dpx=vi*(1.d0-exp(-vpft)+((1.d0-vvxt)**2*(max(0.d0
3104 * ,1.d0-exp(-vpft)*(1.d0+vpft))-max(0.d0,1.d0-exp(-vpf0)
3105 * *(1.d0+vpf0))*(1.d0-vvxp0)/(1.d0-vvxpt))
3106 * +vpft*((1.d0-vvxt)**2*exp(-vpft)-exp(-vpf0)*(1.d0-vvxpl)
3107 * *(1.d0-vvxp0)/(1.d0-vvxpt)*(1.d0-vvxt0)**2)
3108 * -vpf0*exp(-vpf0)*(1.d0-vvxp0)/(1.d0-vvxpt)*((1.d0-vvxt)**2
3109 * -(1.d0-vvxpl)*(1.d0-vvxt0)**2))/(1.d0-(1.d0-vvxt)**2))
3110 if(dpx.le.0.d0)dpx=vi*(1.d0-exp(-vpft))
3111 endif
3112 endif
3113
3114 qgrev=qgrev+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
3115 enddo
3116 enddo
3117 enddo
3118 enddo
3119 enddo
3120 enddo
3121 qgrev=qgrev/8.d0*pi*r3p/.0389d0/g3p**3
3122 if(.not.(qgrev.gt.0.d0.and.qgrev.lt.1.d10))stop'qgrev=NAN'
3123 return
3124 end
3125
3126
3127 double precision function qgrevi(sy,bb,vvxt0,vvxt,vvxpt,vvxp0
3128 *,vvxpl,icdp,icz)
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141 implicit double precision (a-h,o-z)
3142 integer debug
3143 dimension wk(3),wz(3),wj(3),wi(3),wm2(3),wm3(3),wm4(3)
3144 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
3145 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
3146 common /qgarr19/ ahl(3)
3147 common /qgarr20/ spmax
3148 common /qgarr27/ qlegi(51,11,2,3,7),qfanu(51,11,11,6,2)
3149 *,qfanc(51,11,11,39,18),qdfan(21,11,11,2,3),qrev(11,11,66,219,2)
3150 common /qgarr43/ moniou
3151 common /qgdebug/ debug
3152
3153 qgrevi=0.d0
3154 revm=0.d0
3155 if(sy.le.sgap**2)return
3156
3157 rp=(rq(icdp,icz)+alfp*dlog(sy))*4.d0*.0389d0
3158 z=dexp(-bb/rp)
3159 if(z.gt..2d0)then
3160 zz=5.d0*z+6.d0
3161 else
3162 zz=(-bb/rp-dlog(0.2d0))/2.d0+7.d0
3163 endif
3164 jz=min(9,int(zz))
3165 jz=max(1,jz)
3166 if(zz.lt.1.d0)then
3167 wz(2)=zz-jz
3168 wz(1)=1.d0-wz(2)
3169 izmax=2
3170 else
3171 if(jz.eq.6)jz=5
3172 wz(2)=zz-jz
3173 wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
3174 wz(1)=1.d0-wz(2)+wz(3)
3175 wz(2)=wz(2)-2.d0*wz(3)
3176 izmax=3
3177 endif
3178
3179 yl=dlog(sy/sgap**2)/dlog(spmax/sgap**2)*10.d0+1.d0
3180 k=max(1,int(1.00001d0*yl-1.d0))
3181 k=min(k,9)
3182 wk(2)=yl-k
3183 if(yl.le.2.d0)then
3184 iymax=2
3185 wk(1)=1.d0-wk(2)
3186 else
3187 wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
3188 wk(1)=1.d0-wk(2)+wk(3)
3189 wk(2)=wk(2)-2.d0*wk(3)
3190 iymax=3
3191 endif
3192
3193 if(vvxt0.gt..99d0)then
3194 j=11
3195 wj(1)=1.d0
3196 ivmax=1
3197 i=1
3198 wi(1)=1.d0
3199 iv1max=1
3200 else
3201 vl=max(1.d0,vvxt0*10.d0+1.d0)
3202 j=min(int(vl),9)
3203 wj(2)=vl-dble(j)
3204 wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
3205 wj(1)=1.d0-wj(2)+wj(3)
3206 wj(2)=wj(2)-2.d0*wj(3)
3207 ivmax=3
3208
3209 vl1=max(1.d0,(vvxt-vvxt0)/(1.d0-vvxt0)*5.d0+1.d0)
3210 i=min(int(vl1),4)
3211 wi(2)=vl1-dble(i)
3212 wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
3213 wi(1)=1.d0-wi(2)+wi(3)
3214 wi(2)=wi(2)-2.d0*wi(3)
3215 iv1max=3
3216 endif
3217
3218 if(icz.ne.2.or.vvxpt+vvxp0+vvxpl.eq.0.d0)then !hadron (no proj. nucl. corr.)
3219 ll=icz+(icz-1)*(3-icz)*2
3220 do i1=1,iv1max
3221 i2=i+i1-2
3222 do j1=1,ivmax
3223 j2=j+j1-1
3224 do l1=1,izmax
3225 l2=jz+l1-1
3226 do k1=1,iymax
3227 k2=k+k1-1
3228 qgrevi=qgrevi+qrev(k2,l2,j2+11*i2,ll,icdp)
3229 * *wk(k1)*wz(l1)*wj(j1)*wi(i1)
3230 enddo
3231 enddo
3232 enddo
3233 enddo
3234 if(zz.lt.1.d0)then
3235 do i1=1,iv1max
3236 i2=i+i1-2
3237 do j1=1,ivmax
3238 j2=j+j1-1
3239 do k1=1,iymax
3240 k2=k+k1-1
3241 revm=revm+qrev(k2,1,j2+11*i2,ll,icdp)*wk(k1)*wj(j1)*wi(i1)
3242 enddo
3243 enddo
3244 enddo
3245 qgrevi=min(qgrevi,revm)
3246 endif
3247
3248 else
3249 vm2=max(1.d0,vvxpt*5.d0+1.d0)
3250 m2=min(int(vm2),5)
3251 wm2(2)=vm2-dble(m2)
3252 wm2(1)=1.d0-wm2(2)
3253 im2max=2
3254
3255 if(vvxpt.lt.1.d-2)then
3256 m3=1
3257 wm3(1)=1.d0
3258 im3max=1
3259 else
3260 vm3=max(1.d0,vvxp0/vvxpt*5.d0+1.d0)
3261 m3=min(int(vm3),5)
3262 wm3(2)=vm3-dble(m3)
3263 wm3(1)=1.d0-wm3(2)
3264 im3max=2
3265 endif
3266
3267 vm4=max(1.d0,vvxpl*5.d0+1.d0)
3268 m4=min(int(vm4),5)
3269 wm4(2)=vm4-dble(m4)
3270 wm4(1)=1.d0-wm4(2)
3271 im4max=2
3272
3273 do mn4=1,im4max
3274 do mn3=1,im3max
3275 do mn2=1,im2max
3276 mn=icz+m2+mn2+6*(m3+mn3-2)+36*(m4+mn4-2)
3277 do i1=1,iv1max
3278 i2=i+i1-2
3279 do j1=1,ivmax
3280 j2=j+j1-1
3281 do l1=1,izmax
3282 l2=jz+l1-1
3283 do k1=1,iymax
3284 k2=k+k1-1
3285 qgrevi=qgrevi+qrev(k2,l2,j2+11*i2,mn,icdp)
3286 * *wk(k1)*wz(l1)*wj(j1)*wi(i1)*wm2(mn2)*wm3(mn3)*wm4(mn4)
3287 enddo
3288 enddo
3289 enddo
3290 enddo
3291 enddo
3292 enddo
3293 enddo
3294 if(zz.lt.1.d0)then
3295 do mn4=1,im4max
3296 do mn3=1,im3max
3297 do mn2=1,im2max
3298 mn=icz+m2+mn2+6*(m3+mn3-2)+36*(m4+mn4-2)
3299 do i1=1,iv1max
3300 i2=i+i1-2
3301 do j1=1,ivmax
3302 j2=j+j1-1
3303 do k1=1,iymax
3304 k2=k+k1-1
3305 revm=revm+qrev(k2,1,j2+11*i2,mn,icdp)
3306 * *wk(k1)*wj(j1)*wi(i1)*wm2(mn2)*wm3(mn3)*wm4(mn4)
3307 enddo
3308 enddo
3309 enddo
3310 enddo
3311 enddo
3312 enddo
3313 qgrevi=min(qgrevi,revm)
3314 endif
3315 endif
3316 qgrevi=dexp(qgrevi)*z*dlog(sy/sgap**2)
3317 **(1.d0-(1.d0-vvxt)**2)*(1.d0-vvxpt)
3318 return
3319 end
3320
3321
3322 subroutine qgfan(sy,bb,vvx,icdp,icz,fann)
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333 implicit double precision (a-h,o-z)
3334 integer debug
3335 dimension fann(14)
3336 common /qgarr6/ pi,bm,amws
3337 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
3338 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
3339 common /qgarr19/ ahl(3)
3340 common /qgarr43/ moniou
3341 common /qgdebug/ debug
3342 common /arr3/ x1(7),a1(7)
3343
3344 do iqq=1,2
3345 fann(iqq)=0.d0
3346 enddo
3347 if(sy.le.sgap**2)goto 1
3348
3349 do ix1=1,7
3350 do mx1=1,2
3351 xpomr1=(sy/sgap**2)**(-.5d0-x1(ix1)*(mx1-1.5d0))/sgap
3352 rp=(rq(icdp,icz)-alfp*log(xpomr1))*4.d0*.0389d0
3353 rp1=alfp*log(xpomr1*sy)*4.d0*.0389d0
3354 rp2=rp*rp1/(rp+rp1)
3355 do ix2=1,7
3356 do mx2=1,2
3357 z=.5d0+x1(ix2)*(mx2-1.5d0)
3358 bb0=-rp2*log(z)
3359 do ix3=1,7
3360 do mx3=1,2
3361 phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
3362 bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
3363 * +bb0*sin(phi)**2
3364 bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
3365 * +bb0*sin(phi)**2
3366
3367 vpf1=qgfani(1.d0/xpomr1,bb2,vvx,0.d0,0.d0,icdp,icz,2)
3368 vpf=min(vpf1,qgfani(1.d0/xpomr1,bb2,vvx,0.d0,0.d0,icdp,icz,1))
3369 v1i1=qgpini(xpomr1*sy,bb1,0.d0,0.d0,3)
3370 v1i=min(v1i1,qgpini(xpomr1*sy,bb1,0.d0,0.d0,2))
3371 do iqq=1,2
3372 if(iqq.eq.1)then
3373 dpx=(1.d0-exp(-v1i))*(min(0.d0,1.d0-exp(-vpf)-vpf)
3374 * *(1.d0-vvx)-vpf*vvx)
3375 else
3376 dpx=v1i1*(min(0.d0,1.d0-exp(-vpf)-vpf)*(1.d0-vvx)-vpf*vvx)
3377 endif
3378 fann(iqq)=fann(iqq)+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
3379 enddo
3380 enddo
3381 enddo
3382 enddo
3383 enddo
3384 enddo
3385 enddo
3386 1 continue
3387 do iqq=1,2
3388 fann(iqq)=(fann(iqq)*dlog(sy/sgap**2)/8.d0*pi*r3p/.0389d0/g3p**3
3389 * +qglegi(sy,bb,icdp,icz,iqq+1))
3390 * /(1.d0-(1.d0-(1.d0-1.d0/sy)**(1.+ahl(icz)))**(1.+dels))
3391 enddo
3392 return
3393 end
3394
3395
3396 subroutine qgfanc(sy,bb,vvx,vvxp,vvxpl,icdp,icz,fann)
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418 implicit double precision (a-h,o-z)
3419 integer debug
3420 dimension fann(14)
3421 common /qgarr6/ pi,bm,amws
3422 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
3423 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
3424 common /qgarr19/ ahl(3)
3425 common /qgarr43/ moniou
3426 common /qgdebug/ debug
3427 common /arr3/ x1(7),a1(7)
3428
3429 do iqq=1,9
3430 fann(iqq)=0.d0
3431 enddo
3432 if(sy.le.sgap**2)goto 1
3433
3434 if(vvx.gt..999d0)then
3435 vvxs=0.d0
3436 else
3437 vvxs=(1.d0-vvx)**2/(1.d0-vvxpl)
3438 endif
3439
3440 do ix1=1,7
3441 do mx1=1,2
3442 xpomr1=(sy/sgap**2)**(-.5d0-x1(ix1)*(mx1-1.5d0))/sgap
3443 rp=(rq(icdp,icz)-alfp*log(xpomr1))*4.d0*.0389d0
3444 rp1=alfp*log(xpomr1*sy)*4.d0*.0389d0
3445 rp2=rp*rp1/(rp+rp1)
3446 do ix2=1,7
3447 do mx2=1,2
3448 z=.5d0+x1(ix2)*(mx2-1.5d0)
3449 bb0=-rp2*log(z)
3450 do ix3=1,7
3451 do mx3=1,2
3452 phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
3453 bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
3454 * +bb0*sin(phi)**2
3455 bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
3456 * +bb0*sin(phi)**2
3457
3458 vi=qgpini(xpomr1*sy,bb1,0.d0,0.d0,2)
3459 vicn=min(vi,qgpini(xpomr1*sy,bb1,0.d0,0.d0,8))
3460 vicgap=min(vicn,qgpini(xpomr1*sy,bb1,0.d0,0.d0,11))
3461 vic1p=min(vicgap,qgpini(xpomr1*sy,bb1,0.d0,0.d0,9))
3462 vic1=min(vic1p,qgpini(xpomr1*sy,bb1,0.d0,0.d0,5))
3463
3464 vpf=qgfani(1.d0/xpomr1,bb2,vvx,0.d0,0.d0,icdp,icz,1)
3465 vpfc0=min(vpf
3466 * ,qgfani(1.d0/xpomr1,bb2,vvx,vvxp,vvxpl,icdp,icz,3))
3467 vpfct=max(vpf
3468 * ,qgfani(1.d0/xpomr1,bb2,vvx,vvxp,vvxpl,icdp,icz,6))
3469 vpf1p=min(vpf
3470 * ,qgfani(1.d0/xpomr1,bb2,vvx,vvxp,vvxpl,icdp,icz,7))
3471 vpf1p0=min(vpf1p
3472 * ,qgfani(1.d0/xpomr1,bb2,vvx,vvxp,vvxpl,icdp,icz,8))
3473 vpfc1=min(vpf1p0
3474 * ,qgfani(1.d0/xpomr1,bb2,vvx,vvxp,vvxpl,icdp,icz,9))
3475 do iqq=1,9
3476 if(iqq.eq.1)then !cut handle
3477 dpx=(1.d0-exp(-vi))
3478 * *(vvxs*(min(0.d0,1.d0-exp(-vpfc0)-vpfc0)
3479 * +vvxp*(exp(-vpfc0)-exp(-vpf)))+vpfc0*(vvxs-1.d0))
3480 elseif(iqq.eq.2)then !no rap-gap at the end
3481 dpx=(.5d0*max(0.d0,1.d0-exp(-2.d0*vicn)*(1.d0+2.d0*vicn))
3482 * +vicgap*exp(-2.d0*vicn))
3483 * *(vvxs*(min(0.d0,1.d0-exp(-vpfc0)-vpfc0)
3484 * +vvxp*(exp(-vpfc0)-exp(-vpf)))+vpfc0*(vvxs-1.d0))
3485 elseif(iqq.eq.3)then !single cut Pomeron end
3486 dpx=vic1p*exp(-2.d0*vicn)
3487 * *(vvxs*(min(0.d0,1.d0-exp(-vpfc0)-vpfc0)
3488 * +vvxp*(exp(-vpfc0)-exp(-vpf)))+vpfc0*(vvxs-1.d0))
3489 elseif(iqq.eq.4)then !total fan-like contribution
3490 dpx=(1.d0-exp(-vi))
3491 * *((1.d0-vvxpl)*(min(0.d0,1.d0-exp(-vpfct)-vpfct)
3492 * +vvxp*(exp(-vpfct)-exp(-vpf)))-vpfct*vvxpl)
3493 elseif(iqq.eq.5)then !leg-like cut
3494 dpx=(1.d0-exp(-vi))*vpf1p
3495 * *((1.d0-vvx)*(1.d0-vvxpl)*(1.d0-vvxp)**2*exp(-2.d0*vpf)-1.d0)
3496 elseif(iqq.eq.6)then !leg-like cut with cut handle
3497 dpx=(1.d0-exp(-vi))
3498 * *(vpf1p0*((1.d0-vvx)**2*(1.d0-vvxp)**2*exp(-2.d0*vpf)-1.d0)
3499 * -(vpf1p-vpf1p0)*vvxs*(1.d0-vvxp)*exp(-vpf)
3500 * *(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpf)))
3501 elseif(iqq.eq.7)then !single Pomeron cut
3502 dpx=vic1*exp(-2.d0*vicn)
3503 * *vpfc1*((1.d0-vvx)**2*(1.d0-vvxp)**2*exp(-2.d0*vpf)-1.d0)
3504 elseif(iqq.eq.8)then !leg-like cut with single cut Pomeron end
3505 dpx=vic1p*exp(-2.d0*vicn)
3506 * *(vpf1p0*((1.d0-vvx)**2*(1.d0-vvxp)**2*exp(-2.d0*vpf)-1.d0)
3507 * -(vpf1p-vpf1p0)*vvxs*(1.d0-vvxp)*exp(-vpf)
3508 * *(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpf)))
3509 elseif(iqq.eq.9)then !leg-like cut without a rap-gap at the end
3510 dpx=(.5d0*max(0.d0,1.d0-exp(-2.d0*vicn)*(1.d0+2.d0*vicn))
3511 * +vicgap*exp(-2.d0*vicn))
3512 * *(vpf1p0*((1.d0-vvx)**2*(1.d0-vvxp)**2*exp(-2.d0*vpf)-1.d0)
3513 * -(vpf1p-vpf1p0)*vvxs*(1.d0-vvxp)*exp(-vpf)
3514 * *(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpf)))
3515 else
3516 dpx=0.d0
3517 endif
3518 fann(iqq)=fann(iqq)+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
3519 enddo
3520 enddo
3521 enddo
3522 enddo
3523 enddo
3524 enddo
3525 enddo
3526 1 continue
3527 dfan=qglegi(sy,bb,icdp,icz,2)
3528 dfangap=min(dfan,qglegi(sy,bb,icdp,icz,7))
3529 dfan1p=min(dfangap,qglegi(sy,bb,icdp,icz,6))
3530 dfanc1=min(dfan1p,qglegi(sy,bb,icdp,icz,4))
3531 do iqq=1,9
3532 fann(iqq)=fann(iqq)*dlog(sy/sgap**2)/8.d0*pi*r3p/.0389d0/g3p**3
3533 if(iqq.eq.2.or.iqq.eq.9)then
3534 fann(iqq)=fann(iqq)+dfangap
3535 elseif(iqq.eq.3.or.iqq.eq.8)then
3536 fann(iqq)=fann(iqq)+dfan1p
3537 elseif(iqq.eq.7)then
3538 fann(iqq)=fann(iqq)+dfanc1
3539 else
3540 fann(iqq)=fann(iqq)+dfan
3541 endif
3542 fann(iqq)=fann(iqq)
3543 * /(1.d0-(1.d0-(1.d0-1.d0/sy)**(1.+ahl(icz)))**(1.+dels))
3544 enddo
3545 return
3546 end
3547
3548
3549 double precision function qgfani(sy,bb,vvx,vvxp,vvxpl
3550 *,icdp,icz,iqq)
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577 implicit double precision (a-h,o-z)
3578 integer debug
3579 dimension wk(3),wz(3),wj(3),wi(3),wn(3)
3580 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
3581 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
3582 common /qgarr19/ ahl(3)
3583 common /qgarr20/ spmax
3584 common /qgarr27/ qlegi(51,11,2,3,7),qfanu(51,11,11,6,2)
3585 *,qfanc(51,11,11,39,18),qdfan(21,11,11,2,3),qrev(11,11,66,219,2)
3586 common /qgarr43/ moniou
3587 common /qgdebug/ debug
3588
3589 qgfani=0.d0
3590 fanm=0.d0
3591
3592 if(sy.le.sgap**2)then
3593 qgfani=qglegi(sy,bb,icdp,icz,1)
3594 return
3595 endif
3596
3597 rp=(rq(icdp,icz)+alfp*dlog(sy))*4.d0*.0389d0
3598 z=dexp(-bb/rp)
3599 if(z.gt..2d0)then
3600 zz=5.d0*z+6.d0
3601 else
3602 zz=(-bb/rp-dlog(0.2d0))/2.d0+7.d0
3603 endif
3604 jz=min(9,int(zz))
3605 jz=max(1,jz)
3606 if(zz.lt.1.d0)then
3607 wz(2)=zz-jz
3608 wz(1)=1.d0-wz(2)
3609 izmax=2
3610 else
3611 if(jz.eq.6)jz=5
3612 wz(2)=zz-jz
3613 wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
3614 wz(1)=1.d0-wz(2)+wz(3)
3615 wz(2)=wz(2)-2.d0*wz(3)
3616 izmax=3
3617 endif
3618
3619 yl=dlog(sy/sgap)/dlog(spmax/sgap)*50.d0+1.d0
3620 k=max(1,int(1.00001d0*yl-1.d0))
3621 k=min(k,49)
3622 wk(2)=yl-k
3623 if(yl.le.2.d0)then
3624 iymax=2
3625 wk(1)=1.d0-wk(2)
3626 else
3627 wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
3628 wk(1)=1.d0-wk(2)+wk(3)
3629 wk(2)=wk(2)-2.d0*wk(3)
3630 iymax=3
3631 endif
3632
3633 vl=max(1.d0,vvx*10.d0+1.d0)
3634 if(vvx.eq.0.d0)then
3635 ivmax=1
3636 j=1
3637 wj(1)=1.d0
3638 else
3639 j=min(int(vl),9)
3640 wj(2)=vl-dble(j)
3641 wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
3642 wj(1)=1.d0-wj(2)+wj(3)
3643 wj(2)=wj(2)-2.d0*wj(3)
3644 ivmax=3
3645 endif
3646
3647 if(iqq.le.2)then
3648 ii=icdp+2*(icz-1)
3649 do j1=1,ivmax
3650 j2=j+j1-1
3651 do l1=1,izmax
3652 l2=jz+l1-1
3653 do k1=1,iymax
3654 k2=k+k1-1
3655 qgfani=qgfani+qfanu(k2,l2,j2,ii,iqq)
3656 * *wk(k1)*wz(l1)*wj(j1)
3657 enddo
3658 enddo
3659 enddo
3660 if(zz.lt.1.d0)then
3661 do j1=1,ivmax
3662 j2=j+j1-1
3663 do k1=1,iymax
3664 k2=k+k1-1
3665 fanm=fanm+qfanu(k2,1,j2,ii,iqq)*wk(k1)*wj(j1)
3666 enddo
3667 enddo
3668 qgfani=min(qgfani,fanm)
3669 endif
3670
3671 elseif(icz.ne.2.or.vvxp+vvxpl.eq.0.d0)then !hadron (no proj. nucl. corr.)
3672 ii=icdp+2*(iqq-3)
3673 ll=icz+(icz-1)*(3-icz)*2
3674 do j1=1,ivmax
3675 j2=j+j1-1
3676 do l1=1,izmax
3677 l2=jz+l1-1
3678 do k1=1,iymax
3679 k2=k+k1-1
3680 qgfani=qgfani+qfanc(k2,l2,j2,ll,ii)*wk(k1)*wz(l1)*wj(j1)
3681 enddo
3682 enddo
3683 enddo
3684 if(zz.lt.1.d0)then
3685 do j1=1,ivmax
3686 j2=j+j1-1
3687 do k1=1,iymax
3688 k2=k+k1-1
3689 fanm=fanm+qfanc(k2,1,j2,ll,ii)*wk(k1)*wj(j1)
3690 enddo
3691 enddo
3692 qgfani=min(qgfani,fanm)
3693 endif
3694
3695 else
3696 iv1max=2
3697 vl1=max(1.d0,vvxp*5.d0+1.d0)
3698 i=min(int(vl1),5)
3699 wi(2)=vl1-i
3700 wi(1)=1.d0-wi(2)
3701
3702 if(vvx.lt..01d0)then !weak (no) screening
3703 iv2max=1
3704 n=1
3705 wn(1)=1.d0
3706 else !nuclear effects
3707 iv2max=2
3708 vl2=max(1.d0,vvxpl/vvx*5.d0+1.d0)
3709 n=min(int(vl2),5)
3710 wn(2)=vl2-n
3711 wn(1)=1.d0-wn(2)
3712 endif
3713
3714 ii=icdp+2*(iqq-3)
3715 do n1=1,iv2max
3716 n2=n+n1-2
3717 do i1=1,iv1max
3718 i2=i+i1+2
3719 do j1=1,ivmax
3720 j2=j+j1-1
3721 do l1=1,izmax
3722 l2=jz+l1-1
3723 do k1=1,iymax
3724 k2=k+k1-1
3725 qgfani=qgfani+qfanc(k2,l2,j2,i2+6*n2,ii)
3726 * *wk(k1)*wz(l1)*wj(j1)*wi(i1)*wn(n1)
3727 enddo
3728 enddo
3729 enddo
3730 enddo
3731 enddo
3732 if(zz.lt.1.d0)then
3733 do n1=1,iv2max
3734 n2=n+n1-2
3735 do i1=1,iv1max
3736 i2=i+i1+2
3737 do j1=1,ivmax
3738 j2=j+j1-1
3739 do k1=1,iymax
3740 k2=k+k1-1
3741 fanm=fanm+qfanc(k2,1,j2,i2+6*n2,ii)
3742 * *wk(k1)*wj(j1)*wi(i1)*wn(n1)
3743 enddo
3744 enddo
3745 enddo
3746 enddo
3747 qgfani=min(qgfani,fanm)
3748 endif
3749 endif
3750 qgfani=dexp(qgfani)*z
3751 **(1.d0-(1.d0-(1.d0-1.d0/sy)**(1.+ahl(icz)))**(1.+dels))
3752 return
3753 end
3754
3755
3756 subroutine qgdfan(xpomr,xpomr1,bb,icdp,fann,nn)
3757
3758
3759
3760
3761
3762
3763
3764 implicit double precision (a-h,o-z)
3765 integer debug
3766 dimension fann(14),dps(3)
3767 common /qgarr6/ pi,bm,amws
3768 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
3769 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
3770 common /qgarr19/ ahl(3)
3771 common /qgarr43/ moniou
3772 common /qgdebug/ debug
3773 common /arr3/ x1(7),a1(7)
3774
3775 icz=2
3776 do iqq=1,3
3777 fann(iqq)=0.d0
3778 enddo
3779
3780 rp=(rq(icdp,icz)-alfp*log(xpomr1))*2.d0*.0389d0
3781 rp1=alfp*log(xpomr1/xpomr)*4.d0*.0389d0
3782 rp2=rp*rp1/(rp+rp1)
3783 do ix2=1,7
3784 do mx2=1,2
3785 z=.5d0+x1(ix2)*(mx2-1.5d0)
3786 bb0=-rp2*log(z)
3787 do ix3=1,7
3788 do mx3=1,2
3789 phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
3790 bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
3791 * +bb0*sin(phi)**2
3792 bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
3793 * +bb0*sin(phi)**2
3794
3795 vpf=qgfani(1.d0/xpomr1,bb2,0.d0,0.d0,0.d0,icdp,icz,1)
3796 v1i1=qgpini(xpomr1/xpomr,bb1,0.d0,0.d0,3)
3797 v1i=min(v1i1,qgpini(xpomr1/xpomr,bb1,0.d0,0.d0,2))
3798
3799 do iqq=1,2
3800 if(iqq.eq.1)then
3801 dpx=(1.d0-exp(-v1i))*(1.d0-exp(-vpf))**2
3802 else
3803 dpx=v1i1*(1.d0-exp(-vpf))**2
3804 endif
3805 fann(iqq)=fann(iqq)+a1(ix2)*a1(ix3)*dpx/z*rp2
3806 enddo
3807 enddo
3808 enddo
3809 enddo
3810 enddo
3811
3812 do ix1=1,7
3813 do mx1=1,2
3814 xpomr2=xpomr1*(xpomr/xpomr1*sgap)**(.5d0+x1(ix1)*(mx1-1.5d0))
3815 rp=(rq(icdp,icz)-alfp*log(xpomr2))*2.d0*.0389d0
3816 rp1=alfp*log(xpomr2/xpomr)*4.d0*.0389d0
3817 rp2=rp*rp1/(rp+rp1)
3818 do ix2=1,7
3819 do mx2=1,2
3820 z=.5d0+x1(ix2)*(mx2-1.5d0)
3821 bb0=-rp2*log(z)
3822 do ix3=1,7
3823 do mx3=1,2
3824 phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
3825 bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
3826 * +bb0*sin(phi)**2
3827 bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
3828 * +bb0*sin(phi)**2
3829
3830 vpf=qgfani(1.d0/xpomr2,bb2,0.d0,0.d0,0.d0,icdp,icz,1)
3831 v1i=qgpini(xpomr2/xpomr,bb1,0.d0,0.d0,2)
3832 dpx=(1.d0-exp(-v1i))*(1.d0-exp(-vpf))**2/2.d0
3833 fann(3)=fann(3)+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
3834 enddo
3835 enddo
3836 enddo
3837 enddo
3838 enddo
3839 enddo
3840 do iqq=1,3
3841 fann(iqq)=fann(iqq)*(r3p*pi/.0389d0)/g3p**3/8.d0
3842 enddo
3843
3844 if(nn.gt.1.and.xpomr1/xpomr.gt.sgap**2)then
3845 do iqq=1,3
3846 dps(iqq)=0.d0
3847 enddo
3848 do ix1=1,7
3849 do mx1=1,2
3850 xpomr2=xpomr1/sgap*(xpomr/xpomr1*sgap**2)
3851 * **(.5d0+x1(ix1)*(mx1-1.5d0))
3852 rp=(rq(icdp,icz)-alfp*log(xpomr2))*2.d0*.0389d0
3853 rp1=alfp*log(xpomr2/xpomr)*4.d0*.0389d0
3854 rp2=rp*rp1/(rp+rp1)
3855 do ix2=1,7
3856 do mx2=1,2
3857 z=.5d0+x1(ix2)*(mx2-1.5d0)
3858 bb0=-rp2*log(z)
3859 do ix3=1,7
3860 do mx3=1,2
3861 phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
3862 bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
3863 * +bb0*sin(phi)**2
3864 bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
3865 * +bb0*sin(phi)**2
3866
3867 vpf=qgfani(1.d0/xpomr2,bb2,0.d0,0.d0,0.d0,icdp,icz,1)
3868 v1i1=qgpini(xpomr2/xpomr,bb1,0.d0,0.d0,3)
3869 v1i=min(v1i1,qgpini(xpomr2/xpomr,bb1,0.d0,0.d0,2))
3870 vpdf=qgdfani(xpomr2,xpomr1,bb2,icdp,1)
3871 vpdfi=qgdfani(xpomr2,xpomr1,bb2,icdp,3)
3872 do iqq=1,3
3873 if(iqq.eq.1)then
3874 dpx=(1.d0-exp(-v1i))*vpdf*(exp(2.d0*(vpdfi-vpf))-1.d0)
3875 elseif(iqq.eq.2)then
3876 dpx=v1i1*vpdf*(exp(2.d0*(vpdfi-vpf))-1.d0)
3877 elseif(iqq.eq.3)then
3878 dpx=(1.d0-exp(-v1i))*((exp(2.d0*vpdfi)-1.d0)*exp(-2.d0*vpf)
3879 * -2.d0*vpdfi)/2.d0/dlog(xpomr1/xpomr/sgap)
3880 endif
3881 dps(iqq)=dps(iqq)+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
3882 enddo
3883 enddo
3884 enddo
3885 enddo
3886 enddo
3887 enddo
3888 enddo
3889 do iqq=1,3
3890 fann(iqq)=fann(iqq)+dps(iqq)*dlog(xpomr1/xpomr/sgap**2)
3891 * *(r3p*pi/.0389d0)/g3p**3/8.d0
3892 enddo
3893 endif
3894 return
3895 end
3896
3897
3898 double precision function qgdfani(xpomr,xpomr1,bb,icdp,iqq)
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910 implicit double precision (a-h,o-z)
3911 integer debug
3912 dimension wk(3),wz(3),wj(3)
3913 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
3914 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
3915 common /qgarr19/ ahl(3)
3916 common /qgarr20/ spmax
3917 common /qgarr27/ qlegi(51,11,2,3,7),qfanu(51,11,11,6,2)
3918 *,qfanc(51,11,11,39,18),qdfan(21,11,11,2,3),qrev(11,11,66,219,2)
3919 common /qgarr43/ moniou
3920 common /qgdebug/ debug
3921
3922 qgdfani=0.d0
3923 dfanm=0.d0
3924 if(xpomr*sgap**2.gt.1.d0)return
3925
3926 icz=2
3927 rp=(rq(icdp,icz)-alfp*dlog(xpomr))*2.d0*.0389d0
3928 z=dexp(-bb/rp)
3929 if(z.gt..2d0)then
3930 zz=5.d0*z+6.d0
3931 else
3932 zz=(-bb/rp-dlog(0.2d0))/2.d0+7.d0
3933 endif
3934 jz=min(9,int(zz))
3935 jz=max(1,jz)
3936 if(zz.lt.1.d0)then
3937 wz(2)=zz-jz
3938 wz(1)=1.d0-wz(2)
3939 izmax=2
3940 else
3941 if(jz.eq.6)jz=5
3942 wz(2)=zz-jz
3943 wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
3944 wz(1)=1.d0-wz(2)+wz(3)
3945 wz(2)=wz(2)-2.d0*wz(3)
3946 izmax=3
3947 endif
3948
3949 if(xpomr*sgap**2.gt..9999d0)then
3950 k=1
3951 j=1
3952 wk(1)=1.d0
3953 wj(1)=1.d0
3954 iymax=1
3955 iy1max=1
3956 else
3957 yl=-dlog(xpomr*sgap**2)/dlog(1.d5/sgap**2)*20.d0+1.d0
3958 k=max(1,int(1.00001d0*yl-1.d0))
3959 k=min(k,19)
3960 wk(2)=yl-k
3961 if(yl.le.2.d0)then
3962 iymax=2
3963 wk(1)=1.d0-wk(2)
3964 else
3965 wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
3966 wk(1)=1.d0-wk(2)+wk(3)
3967 wk(2)=wk(2)-2.d0*wk(3)
3968 iymax=3
3969 endif
3970
3971 yl1=11.d0-dlog(xpomr1*sgap)/dlog(xpomr*sgap**2)*10.d0
3972 j=max(1,int(yl1))
3973 j=min(j,9)
3974 wj(2)=yl1-dble(j)
3975 wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
3976 wj(1)=1.d0-wj(2)+wj(3)
3977 wj(2)=wj(2)-2.d0*wj(3)
3978 iy1max=3
3979 endif
3980
3981 do l1=1,izmax
3982 l2=jz+l1-1
3983 do j1=1,iy1max
3984 j2=j+j1-1
3985 do k1=1,iymax
3986 k2=k+k1-1
3987 qgdfani=qgdfani+qdfan(k2,j2,l2,icdp,iqq)
3988 * *wk(k1)*wz(l1)*wj(j1)
3989 enddo
3990 enddo
3991 enddo
3992 if(zz.lt.1.d0)then
3993 do j1=1,iy1max
3994 j2=j+j1-1
3995 do k1=1,iymax
3996 k2=k+k1-1
3997 dfanm=dfanm+qdfan(k2,j2,1,icdp,iqq)*wk(k1)*wj(j1)
3998 enddo
3999 enddo
4000 qgdfani=min(qgdfani,dfanm)
4001 endif
4002 qgdfani=dexp(qgdfani)*z
4003 if(iqq.eq.3)qgdfani=qgdfani*max(0.d0,dlog(xpomr1/xpomr/sgap))
4004 return
4005 end
4006
4007
4008 double precision function qg3pom(sy,b,vvx,vvxp,vvxt
4009 *,icdp,icdt,icz)
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021 implicit double precision (a-h,o-z)
4022 integer debug
4023 common /qgarr6/ pi,bm,amws
4024 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
4025 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
4026 common /qgdebug/ debug
4027 common /qgarr43/ moniou
4028 common /arr3/ x1(7),a1(7)
4029
4030 qg3pom=0.d0
4031 if(sy.le.sgap**2)return
4032
4033 do ix1=1,7
4034 do mx1=1,2
4035 xpomr1=(sy/sgap**2)**(-(.5+x1(ix1)*(mx1-1.5)))/sgap
4036 rp1=(rq(icdp,icz)-alfp*log(xpomr1))*4.d0*.0389d0
4037 rp2=(rq(icdt,2)+alfp*log(xpomr1*sy))*4.d0*.0389d0
4038 rp=rp1*rp2/(rp1+rp2)
4039 do ib1=1,7
4040 do mb1=1,2
4041 z=.5d0+x1(ib1)*(mb1-1.5d0)
4042 bb0=-rp*dlog(z)
4043 do ib2=1,7
4044 do mb2=1,2
4045 phi=pi*(.5d0+x1(ib2)*(mb2-1.5d0))
4046 bb1=(b*rp1/(rp1+rp2)+dsqrt(bb0)*cos(phi))**2+bb0*sin(phi)**2
4047 bb2=(b*rp2/(rp1+rp2)-dsqrt(bb0)*cos(phi))**2+bb0*sin(phi)**2
4048
4049 v1p0=qglegi(1.d0/xpomr1,bb1,icdp,icz,1)
4050 v1t0=qglegi(xpomr1*sy,bb2,icdt,2,1)
4051 v1p1=min(v1p0,qglegi(1.d0/xpomr1,bb1,icdp,icz,3))
4052 v1t1=min(v1t0,qglegi(xpomr1*sy,bb2,icdt,2,3))
4053 v1p=min(v1p1,qglegi(1.d0/xpomr1,bb1,icdp,icz,2))
4054 v1t=min(v1t1,qglegi(xpomr1*sy,bb2,icdt,2,2))
4055
4056 vpf0=min(v1p,qgfani(1.d0/xpomr1,bb1
4057 * ,1.d0-(1.d0-vvx)*(1.d0-vvxt),0.d0,0.d0,icdp,icz,1))
4058 vtf0=min(v1t,qgfani(xpomr1*sy,bb2
4059 * ,1.d0-(1.d0-vvx)*(1.d0-vvxp),0.d0,0.d0,icdt,2,1))
4060
4061 n=1
4062 1 n=n+1
4063 vpf=qgfani(1.d0/xpomr1,bb1
4064 * ,1.d0-(1.d0-vvx)*(1.d0-vvxt)*exp(-vtf0),0.d0,0.d0,icdp,icz,1)
4065 vtf=qgfani(xpomr1*sy,bb2
4066 * ,1.d0-(1.d0-vvx)*(1.d0-vvxp)*exp(-vpf0),0.d0,0.d0,icdt,2,1)
4067 if(abs(1.d0-vpf/vpf0)+abs(1.d0-vtf/vtf0).gt.1.d-2.and.n.lt.100)
4068 * then
4069 vpf0=vpf
4070 vtf0=vtf
4071 goto 1
4072 endif
4073
4074 dpx=(1.d0-vvx)*(min(0.d0,1.d0-exp(-vpf)-vpf)
4075 * *min(0.d0,1.d0-exp(-vtf)-vtf)
4076 * +vpf*min(0.d0,1.d0-exp(-vtf)-vtf)
4077 * +vtf*min(0.d0,1.d0-exp(-vpf)-vpf))-vvx*vpf*vtf
4078 * -.5d0*(vtf-v1t)*(min(0.d0,1.d0-exp(-vpf)-vpf)
4079 * *(1.d0-vvx)*(1.d0-vvxt)*exp(-vtf)
4080 * -vpf*(1.d0-(1.d0-vvx)*(1.d0-vvxt)*exp(-vtf)))
4081 * -.5d0*(vpf-v1p)*(min(0.d0,1.d0-exp(-vtf)-vtf)
4082 * *(1.d0-vvx)*(1.d0-vvxp)*exp(-vpf)
4083 * -vtf*(1.d0-(1.d0-vvx)*(1.d0-vvxp)*exp(-vpf)))
4084 * +.5d0*(v1t-v1t1)*v1p0+.5d0*(v1p-v1p1)*v1t0
4085 dpx=min(1.d0,dpx)
4086
4087 qg3pom=qg3pom+a1(ib1)*a1(ib2)*a1(ix1)/z*rp*dpx
4088 enddo
4089 enddo
4090 enddo
4091 enddo
4092 enddo
4093 enddo
4094 qg3pom=qg3pom/8.d0*log(sy/sgap**2)*(r3p*pi/.0389d0)/g3p**3
4095 return
4096 end
4097
4098
4099 double precision function qgpcut(sy,b,vvx,vvxp,vvxt
4100 *,icdp,icdt,icz)
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110 implicit double precision (a-h,o-z)
4111 integer debug
4112 common /qgarr6/ pi,bm,amws
4113 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
4114 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
4115 common /qgarr19/ ahl(3)
4116 common /qgarr43/ moniou
4117 common /qgdebug/ debug
4118 common /arr3/ x1(7),a1(7)
4119
4120 qgpcut=0.d0
4121 if(sy.le.sgap**2)return
4122
4123 do ix1=1,7
4124 do mx1=1,2
4125 xpomr1=(sy/sgap**2)**(-(.5+x1(ix1)*(mx1-1.5)))/sgap
4126 rp1=(rq(icdp,icz)-alfp*log(xpomr1))*4.d0*.0389d0
4127 rp2=(rq(icdt,2)+alfp*log(xpomr1*sy))*4.d0*.0389d0
4128 rp=rp1*rp2/(rp1+rp2)
4129 do ib1=1,7
4130 do mb1=1,2
4131 z=.5d0+x1(ib1)*(mb1-1.5d0)
4132 bb0=-rp*dlog(z)
4133 do ib2=1,7
4134 do mb2=1,2
4135 phi=pi*(.5d0+x1(ib2)*(mb2-1.5d0))
4136 bb1=(b*rp1/(rp1+rp2)+dsqrt(bb0)*cos(phi))**2+bb0*sin(phi)**2
4137 bb2=(b*rp2/(rp1+rp2)-dsqrt(bb0)*cos(phi))**2+bb0*sin(phi)**2
4138
4139 vpl=qglegi(1.d0/xpomr1,bb1,icdp,icz,1)
4140 vtl=qglegi(xpomr1*sy,bb2,icdt,2,1)
4141 vpf0=qgfani(1.d0/xpomr1,bb1,1.d0-(1.d0-vvx)*(1.d0-vvxt)
4142 * ,0.d0,0.d0,icdp,icz,1)
4143 vtf0=qgfani(xpomr1*sy,bb2,1.d0-(1.d0-vvx)*(1.d0-vvxp)
4144 * ,0.d0,0.d0,icdt,2,1)
4145
4146 n=1
4147 1 n=n+1
4148 vpf=qgfani(1.d0/xpomr1,bb1,1.d0-(1.d0-vvx)*(1.d0-vvxt)
4149 * *exp(-vtf0),0.d0,0.d0,icdp,icz,1)
4150 vtf=qgfani(xpomr1*sy,bb2,1.d0-(1.d0-vvx)*(1.d0-vvxp)*exp(-vpf0)
4151 * ,0.d0,0.d0,icdt,2,1)
4152 if(abs(1.d0-vpf/vpf0)+abs(1.d0-vtf/vtf0).gt.1.d-2.and.n.lt.100)
4153 * then
4154 vpf0=vpf
4155 vtf0=vtf
4156 goto 1
4157 endif
4158
4159 vpls=qgfani(1.d0/xpomr1,bb1,1.d0-(1.d0-vvx)*(1.d0-vvxt)
4160 * *exp(-vtf),vvxp,0.d0,icdp,icz,9)
4161 vtls=qgfani(xpomr1*sy,bb2,1.d0-(1.d0-vvx)*(1.d0-vvxp)*exp(-vpf)
4162 * ,vvxt,0.d0,icdt,2,9)
4163 vploop0=qglegi(1.d0/xpomr1,bb1,icdp,icz,5)
4164 vploop=min(vploop0,qglegi(1.d0/xpomr1,bb1,icdp,icz,4))
4165 vtloop0=qglegi(xpomr1*sy,bb2,icdt,2,5)
4166 vtloop=min(vtloop0,qglegi(xpomr1*sy,bb2,icdt,2,4))
4167
4168 dpx=(vpls*vtloop+vtls*vploop)*(((1.d0-vvx)*(1.d0-vvxp)
4169 * *(1.d0-vvxt))**2*exp(-2.d0*vpf-2.d0*vtf)-1.d0)
4170 * +vpl*(vtloop-vtloop0)+vtl*(vploop-vploop0)
4171
4172 qgpcut=qgpcut+a1(ib1)*a1(ib2)*a1(ix1)/z*rp*dpx
4173 enddo
4174 enddo
4175 enddo
4176 enddo
4177 enddo
4178 enddo
4179 qgpcut=qgpcut/16.d0*log(sy/sgap**2)*(r3p*pi/.0389d0)/g3p**3
4180 return
4181 end
4182
4183
4184 double precision function qgpomi(sy,bb,vvx,vvxp,vvxt
4185 *,icdp,icdt,icz,iqq)
4186
4187
4188
4189
4190
4191
4192
4193
4194 implicit double precision (a-h,o-z)
4195 integer debug
4196 dimension wk(3),wz(3),wi(3),wj(3),wm(3)
4197 common /qgarr10/ am(7),ammu
4198 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
4199 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
4200 common /qgarr24/ qpomr(11,11,216,12,2)
4201 common /qgdebug/ debug
4202 common /qgarr43/ moniou
4203
4204 qgpomi=0.d0
4205 pomm=0.d0
4206 if(cd(icdp,icz).eq.0.d0.or.cd(icdt,2).eq.0.d0)return
4207
4208 rp=(rq(icdp,icz)+rq(icdt,2)+alfp*log(sy))*4.d0*.0389d0
4209 z=exp(-bb/rp)
4210 if(z.gt..2d0)then
4211 zz=5.d0*z+6.d0
4212 else
4213 zz=(-bb/rp-log(0.2d0))/2.d0+7.d0
4214 endif
4215 jz=min(9,int(zz))
4216 jz=max(1,jz)
4217 if(zz.lt.1.d0)then
4218 wz(2)=zz-jz
4219 wz(1)=1.d0-wz(2)
4220 izmax=2
4221 else
4222 if(jz.eq.6)jz=5
4223 wz(2)=zz-jz
4224 wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
4225 wz(1)=1.d0-wz(2)+wz(3)
4226 wz(2)=wz(2)-2.d0*wz(3)
4227 izmax=3
4228 endif
4229
4230 yl=dlog10((sy-am(2)**2-am(icz)**2)/2.d0/am(2))
4231 k=max(1,int(yl))
4232 k=min(k,9)
4233 wk(2)=yl-k
4234 wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
4235 wk(1)=1.d0-wk(2)+wk(3)
4236 wk(2)=wk(2)-2.d0*wk(3)
4237
4238 ml=icdp+2*(icdt-1)+4*(icz-1)
4239 if(vvx+vvxp+vvxt.eq.0.d0)then !hadron-proton (no nucl. screening)
4240 do l1=1,izmax
4241 l2=jz+l1-1
4242 do k1=1,3
4243 k2=k+k1-1
4244 qgpomi=qgpomi+qpomr(k2,l2,1,ml,iqq)*wk(k1)*wz(l1)
4245 enddo
4246 enddo
4247 if(zz.lt.1.d0)then
4248 do k1=1,3
4249 k2=k+k1-1
4250 pomm=pomm+qpomr(k2,1,1,ml,iqq)*wk(k1)
4251 enddo
4252 qgpomi=min(qgpomi,pomm)
4253 endif
4254 else
4255 vl=max(1.d0,vvx*5.d0+1.d0)
4256 j=min(int(vl),4)
4257 wj(2)=vl-j
4258 wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
4259 wj(1)=1.d0-wj(2)+wj(3)
4260 wj(2)=wj(2)-2.d0*wj(3)
4261
4262 if(icz.ne.2.or.vvxp.eq.0.d0)then !hadron-nucleus (no proj. nucl. scr.)
4263 i1max=1
4264 i=1
4265 wi(1)=1.d0
4266 else
4267 i1max=3
4268 vl1=max(1.d0,vvxp*5.d0+1.d0)
4269 i=min(int(vl1),4)
4270 wi(2)=vl1-i
4271 wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
4272 wi(1)=1.d0-wi(2)+wi(3)
4273 wi(2)=wi(2)-2.d0*wi(3)
4274 endif
4275
4276 vl2=max(1.d0,vvxt*5.d0+1.d0)
4277 m=min(int(vl2),4)
4278 wm(2)=vl2-m
4279 wm(3)=wm(2)*(wm(2)-1.d0)*.5d0
4280 wm(1)=1.d0-wm(2)+wm(3)
4281 wm(2)=wm(2)-2.d0*wm(3)
4282
4283 do m1=1,3
4284 m2=m+m1-2
4285 do i1=1,i1max
4286 i2=i+i1-2
4287 do j1=1,3
4288 j2=j+j1-1
4289 mij=j2+6*i2+36*m2
4290 do l1=1,izmax
4291 l2=jz+l1-1
4292 do k1=1,3
4293 k2=k+k1-1
4294 qgpomi=qgpomi+qpomr(k2,l2,mij,ml,iqq)
4295 * *wk(k1)*wz(l1)*wj(j1)*wi(i1)*wm(m1)
4296 enddo
4297 enddo
4298 enddo
4299 enddo
4300 enddo
4301 if(zz.lt.1.d0)then
4302 do m1=1,3
4303 m2=m+m1-2
4304 do i1=1,i1max
4305 i2=i+i1-2
4306 do j1=1,3
4307 j2=j+j1-1
4308 mij=j2+6*i2+36*m2
4309 do k1=1,3
4310 k2=k+k1-1
4311 pomm=pomm+qpomr(k2,1,mij,ml,iqq)*wk(k1)*wj(j1)*wi(i1)*wm(m1)
4312 enddo
4313 enddo
4314 enddo
4315 enddo
4316 qgpomi=min(qgpomi,pomm)
4317 endif
4318 endif
4319 qgpomi=exp(qgpomi)*z
4320 return
4321 end
4322
4323
4324 double precision function qgppdi(xp,iqq)
4325
4326
4327
4328
4329
4330
4331 implicit double precision (a-h,o-z)
4332 integer debug
4333 common /qgarr18/ alm,qt0,qtf,betp,dgqq
4334 common /qgarr20/ spmax
4335 common /qgarr43/ moniou
4336 common /qgdebug/ debug
4337
4338
4339 qgppdi=0.d0
4340 if(debug.ge.3)write (moniou,201)xp,iqq
4341 if(xp.ge..9999999d0)then
4342 qgppdi=0.d0
4343 else
4344 if(iqq.eq.0)then !gluon
4345 qgppdi=(1.d0-xp)**betp*(1.d0-dgqq)
4346 elseif(iqq.eq.1)then !quark
4347 qgppdi=qgftlf(xp)*dgqq
4348 endif
4349 endif
4350 if(debug.ge.4)write (moniou,202)qgppdi
4351
4352 201 format(2x,'qgppdi - parton distr. in the Pomeron (interpol.):'
4353 */4x,'xp=',e10.3,2x,'iqq=',i1)
4354 202 format(2x,'qgppdi=',e10.3)
4355 return
4356 end
4357
4358
4359 double precision function qgvpdf(x,icz)
4360
4361
4362
4363
4364
4365 implicit double precision (a-h,o-z)
4366 integer debug
4367 common /qgarr6/ pi,bm,amws
4368 common /qgarr18/ alm,qt0,qtf,betp,dgqq
4369 common /qgarr25/ ahv(3)
4370 common /qgarr43/ moniou
4371 common /qgdebug/ debug
4372
4373 qgvpdf=(qggrv(x,qt0,icz,1)+qggrv(x,qt0,icz,2))*(1.d0-x)**ahv(icz)
4374 return
4375 end
4376
4377
4378 double precision function qgspdf(x,icz)
4379
4380
4381
4382
4383
4384 implicit double precision (a-h,o-z)
4385 integer debug
4386 parameter(iapmax=208)
4387 common /qgarr6/ pi,bm,amws
4388 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
4389 common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
4390 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
4391 common /qgarr18/ alm,qt0,qtf,betp,dgqq
4392 common /qgarr43/ moniou
4393 common /qgdebug/ debug
4394 common /arr3/ x1(7),a1(7)
4395
4396 qgspdf=0.d0
4397 if(x*sgap.ge.1.d0)goto 1
4398
4399 do icdp=1,2
4400 rp=(rq(icdp,icz)-alfp*log(x))*2.d0*.0389d0
4401 if(cd(icdp,icz).ne.0.d0)then
4402 dps=0.d0
4403 do ix=1,7
4404 do mx=1,2
4405 xpomr=(x*sgap)**(.5d0+x1(ix)*(mx-1.5d0))/sgap
4406 do ib=1,7
4407 do mb=1,2
4408 z=.5d0+x1(ib)*(mb-1.5d0)
4409 bb=-rp*log(z)
4410
4411 v1p1=qgfani(1.d0/xpomr,bb,0.d0,0.d0,0.d0,icdp,icz,2)
4412 v1p=min(v1p1,qgfani(1.d0/xpomr,bb,0.d0,0.d0,0.d0,icdp,icz,1))
4413 dps=dps+a1(ix)*a1(ib)*(min(0.d0,1.d0-exp(-v1p)-v1p)+v1p-v1p1)
4414 * *qgftlf(x/xpomr)*(xpomr/x)**dels/z
4415 enddo
4416 enddo
4417 enddo
4418 enddo
4419 qgspdf=qgspdf-dps*dlog(x*sgap)*rp/g3p**2*pi*rr*(r3p*pi/.0389d0)
4420 * *dgqq*cc(icdp,icz)
4421 endif
4422 enddo
4423
4424 1 qgspdf=qgspdf+4.*pi*rr*fp(icz)*qgftle(x,icz)/x**dels
4425 return
4426 end
4427
4428
4429 double precision function qggpdf(x,icz)
4430
4431
4432
4433
4434
4435 implicit double precision (a-h,o-z)
4436 integer debug
4437 parameter(iapmax=208)
4438 common /qgarr6/ pi,bm,amws
4439 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
4440 common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
4441 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
4442 common /qgarr18/ alm,qt0,qtf,betp,dgqq
4443 common /qgarr43/ moniou
4444 common /qgdebug/ debug
4445 common /arr3/ x1(7),a1(7)
4446
4447 qggpdf=0.d0
4448 if(x*sgap.ge.1.d0)goto 1
4449
4450 do icdp=1,2
4451 rp=(rq(icdp,icz)-alfp*log(x))*2.d0*.0389d0
4452 if(cd(icdp,icz).ne.0.d0)then
4453 dps=0.d0
4454 do ix=1,7
4455 do mx=1,2
4456 xpomr=(x*sgap)**(.5d0+x1(ix)*(mx-1.5d0))/sgap
4457 do ib=1,7
4458 do mb=1,2
4459 z=.5d0+x1(ib)*(mb-1.5d0)
4460 bb=-rp*log(z)
4461
4462 v1p1=qgfani(1.d0/xpomr,bb,0.d0,0.d0,0.d0,icdp,icz,2)
4463 v1p=min(v1p1,qgfani(1.d0/xpomr,bb,0.d0,0.d0,0.d0,icdp,icz,1))
4464 dps=dps+a1(ix)*a1(ib)*(min(0.d0,1.d0-exp(-v1p)-v1p)+v1p-v1p1)
4465 * *(1.d0-x/xpomr)**betp*(xpomr/x)**dels/z
4466 enddo
4467 enddo
4468 enddo
4469 enddo
4470 qggpdf=qggpdf-dps*dlog(x*sgap)*rp/g3p**2*pi*rr*(r3p*pi/.0389d0)
4471 * *(1.d0-dgqq)*cc(icdp,icz)
4472 endif
4473 enddo
4474
4475 1 qggpdf=qggpdf+4.*pi*rr*fp(icz)*qgftld(x,icz)/x**dels
4476 return
4477 end
4478
4479
4480 double precision function qgpdfb(x,bb,icz,jj)
4481
4482
4483
4484
4485
4486
4487
4488 implicit double precision (a-h,o-z)
4489 integer debug
4490 parameter(iapmax=208)
4491 common /qgarr6/ pi,bm,amws
4492 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
4493 common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
4494 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
4495 common /qgarr18/ alm,qt0,qtf,betp,dgqq
4496 common /qgarr43/ moniou
4497 common /qgdebug/ debug
4498 common /arr3/ x1(7),a1(7)
4499
4500 qgpdfb=0.d0
4501 if(x*sgap.lt.1.d0)then
4502 do icdp=1,2
4503 if(cd(icdp,icz).ne.0.d0)then
4504 dps=0.d0
4505 do ix=1,7
4506 do mx=1,2
4507 xpomr=(x*sgap)**(.5d0+x1(ix)*(mx-1.5d0))/sgap
4508 rp=(rq(icdp,icz)-alfp*log(xpomr))*2.d0*.0389d0
4509 rp1=alfp*dlog(xpomr/x)*4.d0*.0389d0
4510 rp2=rp1*rp/(rp1+rp)
4511 do ix2=1,7
4512 do mx2=1,2
4513 bb0=-rp2*log(.5d0+x1(ix2)*(mx2-1.5d0))
4514 do ix3=1,7
4515 do mx3=1,2
4516 phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
4517 bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
4518 * +bb0*sin(phi)**2
4519 bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
4520 * +bb0*sin(phi)**2
4521
4522 if(jj.eq.0)then
4523 v1i=(1.d0-x/xpomr)**betp*(1.d0-dgqq)
4524 else
4525 v1i=qgftlf(x/xpomr)*dgqq
4526 endif
4527 v1p1=qgfani(1.d0/xpomr,bb2,0.d0,0.d0,0.d0,icdp,icz,2)
4528 v1p=min(v1p1,qgfani(1.d0/xpomr,bb2,0.d0,0.d0,0.d0,icdp,icz,1))
4529
4530 dps=dps+a1(ix)*a1(ix2)*a1(ix3)*v1i
4531 * *(min(0.d0,1.d0-exp(-v1p)-v1p)+v1p-v1p1)
4532 * *(xpomr/x)**dels*rp/(rp1+rp)*exp(bb2/rp-bb/(rp1+rp))
4533 enddo
4534 enddo
4535 enddo
4536 enddo
4537 enddo
4538 enddo
4539 qgpdfb=qgpdfb-dps*dlog(x*sgap)*pi*rr*r3p/g3p**2/.0389d0/2.d0
4540 * *cc(icdp,icz)
4541 endif
4542 enddo
4543
4544 do icdp=1,2
4545 rp=(rq(icdp,icz)-alfp*dlog(x))*4.d0*.0389d0
4546 if(jj.eq.0)then
4547 qgpdfb=qgpdfb+4.d0*rr*fp(icz)*qgftld(x,icz)/x**dels
4548 * /rp*exp(-bb/rp)*cc(icdp,icz)
4549 else
4550 qgpdfb=qgpdfb+4.d0*rr*fp(icz)*qgftle(x,icz)/x**dels
4551 * /rp*exp(-bb/rp)*cc(icdp,icz)
4552 endif
4553 enddo
4554 endif
4555 return
4556 end
4557
4558
4559 double precision function qgpdfi(x,bb,icz,jj)
4560
4561
4562
4563 implicit double precision (a-h,o-z)
4564 integer debug
4565 dimension wk(3),wz(3)
4566 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
4567 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
4568 common /qgarr20/ spmax
4569 common /qgarr53/ qpdfb(51,11,3,2)
4570 common /qgarr43/ moniou
4571 common /qgdebug/ debug
4572
4573 qgpdfi=0.d0
4574 rp=(rq(1,icz)-alfp*dlog(x))*4.d0*.0389d0
4575 if(rp.le.1.d-10)then
4576 z=1.d0
4577 else
4578 z=exp(-bb/rp)
4579 endif
4580 if(z.lt..2d0*exp(-10.d0))then
4581 izmax=2
4582 jz=1
4583 wz(2)=5.d0*z*exp(10.d0)
4584 wz(1)=1.d0-wz(2)
4585 else
4586 if(z.gt..2d0)then
4587 zz=5.d0*z+6.d0
4588 else
4589 zz=(-bb/rp-log(0.2d0))/2.d0+7.d0
4590 endif
4591 jz=min(9,int(zz))
4592 jz=max(2,jz)
4593 if(jz.eq.6)jz=5
4594 wz(2)=zz-jz
4595 wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
4596 wz(1)=1.d0-wz(2)+wz(3)
4597 wz(2)=wz(2)-2.d0*wz(3)
4598 izmax=3
4599 endif
4600
4601 yl=-dlog(x)/log(spmax)*50.d0+1.d0
4602 k=max(1,int(yl))
4603 k=min(k,49)
4604 wk(2)=yl-k
4605 wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
4606 wk(1)=1.d0-wk(2)+wk(3)
4607 wk(2)=wk(2)-2.d0*wk(3)
4608
4609 do j1=1,izmax
4610 j2=jz+j1-1
4611 do k1=1,3
4612 k2=k+k1-1
4613 qgpdfi=qgpdfi+qpdfb(k2,j2,icz,jj+1)*wk(k1)*wz(j1)
4614 enddo
4615 enddo
4616 qgpdfi=exp(qgpdfi)*z*4.d0*rr*fp(icz)/x**dels/rp
4617 if(jj.eq.0)then
4618 qgpdfi=qgpdfi*qgftld(x,icz)
4619 else
4620 qgpdfi=qgpdfi*qgftle(x,icz)
4621 endif
4622 return
4623 end
4624
4625
4626 double precision function qgdgdf(x,xpomr,icz,jj)
4627
4628
4629
4630
4631
4632 implicit double precision (a-h,o-z)
4633 integer debug
4634 parameter(iapmax=208)
4635 common /qgarr6/ pi,bm,amws
4636 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
4637 common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
4638 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
4639 common /qgarr18/ alm,qt0,qtf,betp,dgqq
4640 common /qgarr43/ moniou
4641 common /qgdebug/ debug
4642 common /arr3/ x1(7),a1(7)
4643
4644 qgdgdf=0.d0
4645 do icdp=1,2
4646 if(cd(icdp,icz).ne.0.d0)then
4647 dps=0.d0
4648 if(jj.eq.1)then
4649 rp=(rq(icdp,icz)-alfp*log(xpomr))*2.d0*.0389d0
4650 do ib=1,7
4651 do mb=1,2
4652 z=.5d0+x1(ib)*(mb-1.5d0)
4653 bb=-rp*log(z)
4654
4655 v1p=qgfani(1.d0/xpomr,bb,0.d0,0.d0,0.d0,icdp,icz,1)
4656 dps=dps+a1(ib)*(1.d0-exp(-v1p))**2/z
4657 enddo
4658 enddo
4659 dps=dps*rp*pi*rr*(r3p*pi/.0389d0)*cc(icdp,icz)/g3p**2
4660 * *(1.d0-x/xpomr)**betp*(1.d0-dgqq)*(xpomr/x)**dels
4661
4662 elseif(jj.eq.2.and.xpomr/x.gt.sgap)then
4663 do ix1=1,7
4664 do mx1=1,2
4665 xpomr1=(x/xpomr*sgap)**(.5d0+x1(ix1)*(mx1-1.5d0))*xpomr/sgap
4666 rp=(rq(icdp,icz)-alfp*log(xpomr1))*2.d0*.0389d0
4667 do ib=1,7
4668 do mb=1,2
4669 z=.5d0+x1(ib)*(mb-1.5d0)
4670 bb=-rp*log(z)
4671
4672 vpf=qgfani(1.d0/xpomr1,bb,0.d0,0.d0,0.d0,icdp,icz,1)
4673 vpdf1=qgdfani(xpomr1,xpomr,bb,icdp,2)
4674 vpdf=min(vpdf1,qgdfani(xpomr1,xpomr,bb,icdp,1))
4675 vpdfi=qgdfani(xpomr1,xpomr,bb,icdp,3)
4676 dpx=vpdf*exp(2.d0*vpdfi-2.d0*vpf)-vpdf1
4677
4678 dps=dps+a1(ix1)*a1(ib)*dpx/z*rp
4679 * *(1.d0-x/xpomr1)**betp*(xpomr1/x)**dels
4680 enddo
4681 enddo
4682 enddo
4683 enddo
4684 dps=dps*rr*pi*(r3p*pi/.0389d0)*dlog(xpomr/x/sgap)/g3p**2
4685 * *(1.d0-dgqq)*cc(icdp,icz)
4686 endif
4687 qgdgdf=qgdgdf+dps
4688 endif
4689 enddo
4690 return
4691 end
4692
4693
4694 double precision function qgdpdf(x,xpomr,icz,jj)
4695
4696
4697
4698
4699
4700 implicit double precision (a-h,o-z)
4701 integer debug
4702 parameter(iapmax=208)
4703 common /qgarr6/ pi,bm,amws
4704 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
4705 common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
4706 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
4707 common /qgarr18/ alm,qt0,qtf,betp,dgqq
4708 common /qgarr43/ moniou
4709 common /qgdebug/ debug
4710 common /arr3/ x1(7),a1(7)
4711
4712 qgdpdf=0.d0
4713 do icdp=1,2
4714 if(cd(icdp,icz).ne.0.d0)then
4715 dps=0.d0
4716 if(jj.eq.1)then
4717 rp=(rq(icdp,icz)-alfp*log(xpomr))*2.d0*.0389d0
4718 do ib=1,7
4719 do mb=1,2
4720 z=.5d0+x1(ib)*(mb-1.5d0)
4721 bb=-rp*log(z)
4722
4723 v1p=qgfani(1.d0/xpomr,bb,0.d0,0.d0,0.d0,icdp,icz,1)
4724 dps=dps+a1(ib)*(1.d0-exp(-v1p))**2/z
4725 enddo
4726 enddo
4727 dps=dps*rp*pi*rr*(r3p*pi/.0389d0)*cc(icdp,icz)/g3p**2
4728 * *qgftlf(x/xpomr)*dgqq*(xpomr/x)**dels
4729
4730 elseif(jj.eq.2.and.xpomr/x.gt.sgap)then
4731 do ix1=1,7
4732 do mx1=1,2
4733 xpomr1=(x/xpomr*sgap)**(.5d0+x1(ix1)*(mx1-1.5d0))*xpomr/sgap
4734 rp=(rq(icdp,icz)-alfp*log(xpomr1))*2.d0*.0389d0
4735 do ib=1,7
4736 do mb=1,2
4737 z=.5d0+x1(ib)*(mb-1.5d0)
4738 bb=-rp*log(z)
4739
4740 vpf=qgfani(1.d0/xpomr1,bb,0.d0,0.d0,0.d0,icdp,icz,1)
4741 vpdf1=qgdfani(xpomr1,xpomr,bb,icdp,2)
4742 vpdf=min(vpdf1,qgdfani(xpomr1,xpomr,bb,icdp,1))
4743 vpdfi=qgdfani(xpomr1,xpomr,bb,icdp,3)
4744 dpx=vpdf*exp(2.d0*vpdfi-2.d0*vpf)-vpdf1
4745
4746 dps=dps+a1(ix1)*a1(ib)*dpx/z*rp
4747 * *qgftlf(x/xpomr1)*(xpomr1/x)**dels
4748 enddo
4749 enddo
4750 enddo
4751 enddo
4752 dps=dps*rr*pi*(r3p*pi/.0389d0)*dlog(xpomr/x/sgap)/g3p**2
4753 * *dgqq*cc(icdp,icz)
4754 endif
4755 qgdpdf=qgdpdf+dps
4756 endif
4757 enddo
4758 qgdpdf=qgdpdf/4.5d0
4759 return
4760 end
4761
4762
4763 double precision function qgfsh(sy,bb,icdp,icdt,icz,iqq)
4764
4765
4766
4767
4768
4769
4770
4771 implicit double precision (a-h,o-z)
4772 integer debug
4773 common /qgarr6/ pi,bm,amws
4774 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
4775 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
4776 common /qgarr18/ alm,qt0,qtf,betp,dgqq
4777 common /qgarr25/ ahv(3)
4778 common /qgarr26/ factk,fqscal
4779 common /arr3/ x1(7),a1(7)
4780 common /qgarr43/ moniou
4781 common /qgdebug/ debug
4782
4783 if(debug.ge.2)write (moniou,201)sy,bb,iqq,icz
4784
4785 qgfsh=0.d0
4786 s2min=4.d0*fqscal*qt0
4787 xmin=s2min/sy
4788 if(xmin.ge.1.d0)return
4789 xmin=xmin**(delh-dels)
4790 if(iqq.eq.1)then
4791 icv=icz
4792 icq=2
4793 elseif(iqq.eq.2)then
4794 icv=2
4795 icq=icz
4796 endif
4797 if(debug.ge.3)write (moniou,205)xmin,iqq
4798
4799
4800 do i=1,7
4801 do m=1,2
4802 z1=(.5d0*(1.d0+xmin-(2*m-3)*x1(i)*(1.d0-xmin)))
4803 * **(1.d0/(delh-dels))
4804 ww=z1*sy
4805 sjqq=qgjit(qt0,qt0,ww,2,2)
4806 sjqg=qgjit(qt0,qt0,ww,1,2)
4807 sjgg=qgjit(qt0,qt0,ww,1,1)
4808 if(debug.ge.3)write (moniou,203)ww,sjqq+sjqg+sjgg
4809
4810 if(iqq.eq.0)then
4811 st2=0.d0
4812 do j=1,7
4813 do k=1,2
4814 xx=.5d0*(1.d0+x1(j)*(2*k-3))
4815 xp=z1**xx
4816 xm=z1/xp
4817 glu1=qgftld(xp,icz)
4818 sea1=qgftle(xp,icz)
4819 glu2=qgftld(xm,2)
4820 sea2=qgftle(xm,2)
4821 st2=st2+a1(j)*(glu1*glu2*sjgg+(glu1*sea2+glu2*sea1)*sjqg
4822 * +sea1*sea2*sjqq)
4823 enddo
4824 enddo
4825 rh=rq(icdp,icz)+rq(icdt,2)-alfp*dlog(z1)
4826 qgfsh=qgfsh-a1(i)*dlog(z1)/z1**delh*st2
4827 * *exp(-bb/(4.d0*.0389d0*rh))/rh
4828
4829 else
4830 st2=0.d0
4831 alh=.5d0+dels
4832 xam=z1**alh
4833
4834 do j=1,7
4835 do k=1,2
4836 xp=(.5d0*(1.d0+xam+x1(j)*(2*k-3)*(1.d0-xam)))**(1.d0/alh)
4837 xm=z1/xp
4838 glu=qgftld(xm,icq)
4839 sea=qgftle(xm,icq)
4840 rh=rq(icdp,icz)+rq(icdt,2)-alfp*dlog(xm)
4841
4842 fst=(glu*sjqg+sea*sjqq)*(1.d0-xp)**ahv(icv)
4843 * *(qggrv(xp,qt0,icv,1)+qggrv(xp,qt0,icv,2))/dsqrt(xp)
4844 * *exp(-bb/(4.d0*.0389d0*rh))/rh
4845 st2=st2+a1(j)*fst
4846 enddo
4847 enddo
4848 st2=st2*(1.d0-xam)/alh
4849 qgfsh=qgfsh+a1(i)/z1**delh*st2
4850 endif
4851 enddo
4852 enddo
4853
4854 if(iqq.eq.0)then
4855 qgfsh=qgfsh*rr**2*(1.d0-xmin)/(delh-dels)*fp(icz)*fp(2)*factk
4856 * /2.d0*pi*cd(icdp,icz)*cd(icdt,2)
4857 else
4858 qgfsh=qgfsh*rr*fp(icq)*(1.d0-xmin)/(delh-dels)*factk/8.d0
4859 * *cd(icdp,icz)*cd(icdt,2)
4860 endif
4861
4862 if(debug.ge.3)write (moniou,202)qgfsh
4863 201 format(2x,'qgfsh - semihard interaction eikonal:'
4864 */4x,'sy=',e10.3,2x,'bb=',e10.3,2x,'iqq=',i1,2x,'icz=',i1)
4865 202 format(2x,'qgfsh=',e10.3)
4866 203 format(2x,'qgfsh:',2x,'s_hard=',e10.3,2x,'sigma_hard=',e10.3)
4867 205 format(2x,'qgfsh:',2x,'xmin=',e10.3,2x,'iqq=',i3)
4868 return
4869 end
4870
4871
4872 double precision function qgftld(z,icz)
4873
4874
4875
4876
4877
4878
4879
4880 implicit double precision (a-h,o-z)
4881 integer debug
4882 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
4883 common /qgarr18/ alm,qt0,qtf,betp,dgqq
4884 common /qgarr19/ ahl(3)
4885 common /qgarr43/ moniou
4886 common /qgdebug/ debug
4887 common /arr3/ x1(7),a1(7)
4888
4889 if(debug.ge.2)write (moniou,201)z,icz
4890
4891 qgftld=0.d0
4892 xpmin=z**(1.d0+dels)
4893 do i1=1,7
4894 do m1=1,2
4895 tp=1.d0-(1.d0-xpmin)*(.5d0+x1(i1)*(m1-1.5d0))
4896 * **(1.d0/(1.d0+ahl(icz)))
4897 xp=tp**(1.d0/(1.d0+dels))
4898 qgftld=qgftld+a1(i1)*((1.d0-xp)/(1.d0-tp))**ahl(icz)
4899 * *(1.d0-z/xp)**betp
4900 enddo
4901 enddo
4902 qgftld=qgftld*.5d0*(1.d0-xpmin)**(ahl(icz)+1.d0)
4903 */(ahl(icz)+1.d0)/(1.d0+dels)*(1.d0-dgqq)
4904
4905 if(debug.ge.3)write (moniou,202)qgftld
4906 201 format(2x,'qgftld:',2x,'z=',e10.3,2x,'icz=',i1)
4907 202 format(2x,'qgftld=',e10.3)
4908 return
4909 end
4910
4911
4912 double precision function qgftle(z,icz)
4913
4914
4915
4916
4917
4918
4919
4920 implicit double precision (a-h,o-z)
4921 integer debug
4922 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
4923 common /qgarr18/ alm,qt0,qtf,betp,dgqq
4924 common /qgarr19/ ahl(3)
4925 common /qgarr43/ moniou
4926 common /qgdebug/ debug
4927 common /arr3/ x1(7),a1(7)
4928
4929 if(debug.ge.2)write (moniou,201)z,icz
4930
4931 qgftle=0.d0
4932 xpmin=z**(1.d0+dels)
4933 do i1=1,7
4934 do m1=1,2
4935 tp=1.d0-(1.d0-xpmin)*(.5d0+x1(i1)*(m1-1.5d0))
4936 * **(1.d0/(1.d0+ahl(icz)))
4937 xp=tp**(1.d0/(1.d0+dels))
4938 qgftle=qgftle+a1(i1)*((1.d0-xp)/(1.d0-tp))**ahl(icz)
4939 * *qgftlf(z/xp)
4940 enddo
4941 enddo
4942 qgftle=qgftle*.5d0*(1.d0-xpmin)**(ahl(icz)+1.d0)
4943 */(ahl(icz)+1.d0)/(1.d0+dels)*dgqq
4944
4945 if(debug.ge.3)write (moniou,202)qgftle
4946 201 format(2x,'qgftle:',2x,'z=',e10.3,2x,'icz=',i1)
4947 202 format(2x,'qgftle=',e10.3)
4948 return
4949 end
4950
4951
4952 double precision function qgftlf(zz)
4953
4954
4955
4956
4957
4958
4959 implicit double precision (a-h,o-z)
4960 integer debug
4961 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
4962 common /qgarr18/ alm,qt0,qtf,betp,dgqq
4963 common /qgarr43/ moniou
4964 common /qgdebug/ debug
4965 common /arr3/ x1(7),a1(7)
4966
4967 if(debug.ge.2)write (moniou,201)zz
4968 201 format(2x,'qgftlf:',2x,'zz=',e10.3)
4969
4970 qgftlf=0.d0
4971 zmin=zz**(1.d0+dels)
4972 do i=1,7
4973 do m=1,2
4974 z=(.5d0*(1.d0+zmin+(2*m-3)*x1(i)*(1.d0-zmin)))**(1.d0/
4975 * (1.d0+dels))
4976 qgftlf=qgftlf+a1(i)*max(1.d-9,(1.d0-zz/z))**betp
4977 * *(z**2+(1.d0-z)**2)
4978 enddo
4979 enddo
4980 qgftlf=qgftlf*1.5d0*(1.d0-zmin)/(1.d0+dels) !1.5=naflav/2 at Q0
4981
4982 if(debug.ge.3)write (moniou,202)qgftlf
4983 202 format(2x,'qgftlf=',e10.3)
4984 return
4985 end
4986
4987
4988 subroutine qgfz(b,gz,iddp1,iddp2)
4989
4990
4991
4992 implicit double precision (a-h,o-z)
4993 integer debug
4994 parameter(iapmax=208)
4995 dimension gz(5),wt1(3),wt2(3)
4996 common /qgarr1/ ia(2),icz,icp
4997 common /qgarr2/ scm,wp0,wm0
4998 common /qgarr6/ pi,bm,amws
4999 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
5000 common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
5001 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
5002 common /qgarr43/ moniou
5003 common /arr3/ x1(7),a1(7)
5004 common /qgdebug/ debug
5005
5006 if(debug.ge.2)write (moniou,201)b,iddp1,iddp2
5007 do l=1,5
5008 gz(l)=0.d0
5009 enddo
5010 rp=(rq(1,icz)+rq(1,2)+alfp*log(scm))*4.d0*.0389d0
5011 g0=0.d0
5012 if(ia(2).eq.1.and.iddp1.eq.0.and.iddp2.eq.0)then
5013 g0=pi*rp*10.d0 !normalization factor (in mb)
5014 bm=2.d0*dsqrt(rp) !impact parameter for exp. fall-down
5015 endif
5016
5017 do i1=1,7
5018 do m=1,2
5019 z=.5d0+x1(i1)*(m-1.5d0)
5020 bb1=rp*z
5021 bb2=rp*(1.d0-dlog(z))
5022
5023 do l=1,3
5024 wt1(l)=0.d0
5025 wt2(l)=0.d0
5026 enddo
5027
5028 if(ia(2).eq.1)then
5029 do idd1=1,2
5030 do idd2=1,2
5031 vv1=exp(-qgpomi(scm,bb1,0.d0,0.d0,0.d0,idd1,idd2,icz,1))
5032 vv2=exp(-qgpomi(scm,bb2,0.d0,0.d0,0.d0,idd1,idd2,icz,1))
5033
5034 do l=1,2
5035 wt1(l)=wt1(l)+cc(idd1,icz)*cc(idd2,2)*vv1**l
5036 wt2(l)=wt2(l)+cc(idd1,icz)*cc(idd2,2)*vv2**l
5037 enddo
5038 do idd3=1,2
5039 wt1(3)=wt1(3)+cc(idd1,icz)*cc(idd2,2)*cc(idd3,icz)*vv1
5040 * *exp(-qgpomi(scm,bb1,0.d0,0.d0,0.d0,idd3,idd2,icz,1))
5041 wt2(3)=wt2(3)+cc(idd1,icz)*cc(idd2,2)*cc(idd3,icz)*vv2
5042 * *exp(-qgpomi(scm,bb2,0.d0,0.d0,0.d0,idd3,idd2,icz,1))
5043 enddo
5044 enddo
5045 enddo
5046 do l=1,2
5047 gz(l)=gz(l)+a1(i1)*((1.d0-wt1(l))+(1.d0-wt2(l))/z)
5048 enddo
5049 gz(3)=gz(3)+a1(i1)*((wt1(2)-wt1(3))+(wt2(2)-wt2(3))/z)
5050 gz(4)=gz(4)+a1(i1)*((wt1(3)-wt1(1)**2)+(wt2(3)-wt2(1)**2)/z)
5051 gz(5)=gz(5)+a1(i1)*((1.d0-wt1(1))*z+(1.d0-wt2(1))/z*(1.-log(z)))
5052
5053 else
5054 do idd1=1,2
5055 do idd2=1,2
5056 vv1=exp(-qgpomi(scm,bb1,0.d0,0.d0,0.d0,iddp1,idd1,icz,1)
5057 * -qgpomi(scm,bb1,0.d0,0.d0,0.d0,iddp2,idd2,icz,1))
5058 vv2=exp(-qgpomi(scm,bb2,0.d0,0.d0,0.d0,iddp1,idd1,icz,1)
5059 * -qgpomi(scm,bb2,0.d0,0.d0,0.d0,iddp2,idd2,icz,1))
5060
5061 if(idd1.eq.idd2)then
5062 wt1(1)=wt1(1)+cc(idd1,2)*vv1
5063 wt2(1)=wt2(1)+cc(idd1,2)*vv2
5064 endif
5065 wt1(2)=wt1(2)+cc(idd1,2)*cc(idd2,2)*vv1
5066 wt2(2)=wt2(2)+cc(idd1,2)*cc(idd2,2)*vv2
5067 enddo
5068 enddo
5069 cg1=qgrot(b,dsqrt(bb1))
5070 cg2=qgrot(b,dsqrt(bb2))
5071 do l=1,2
5072 gz(l)=gz(l)+a1(i1)*(cg1*(1.d0-wt1(l))+cg2*(1.d0-wt2(l))/z)
5073 enddo
5074 endif
5075 enddo
5076 enddo
5077 if(ia(2).eq.1.and.iddp1.eq.0.and.iddp2.eq.0)then !hadron-proton
5078 do l=1,5
5079 gz(l)=gz(l)*g0
5080 enddo
5081 gz(5)=gz(5)/gz(1)*(rq(1,icz)+rq(1,2)+alfp*log(scm))*2.d0
5082 endif
5083
5084 if(debug.ge.2)write (moniou,203)gz
5085 if(debug.ge.3)write (moniou,202)
5086 201 format(2x,'qgfz - hadronic cross-sections calculation'
5087 */4x,'b=',e10.3,2x,'iddp=',2i3)
5088 202 format(2x,'qgfz - end')
5089 203 format(2x,'qgfz: gz=',5e10.3)
5090 return
5091 end
5092
5093
5094 double precision function qghard(sy,bb,icdp,icdt,icz)
5095
5096
5097
5098
5099
5100 implicit double precision (a-h,o-z)
5101 integer debug
5102 common /qgarr6/ pi,bm,amws
5103 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
5104 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
5105 common /qgarr18/ alm,qt0,qtf,betp,dgqq
5106 common /qgarr25/ ahv(3)
5107 common /qgarr26/ factk,fqscal
5108 common /arr3/ x1(7),a1(7)
5109 common /qgarr43/ moniou
5110 common /qgdebug/ debug
5111
5112 if(debug.ge.2)write (moniou,201)sy,icz
5113
5114 qghard=0.d0
5115 s2min=4.d0*fqscal*qt0
5116 xmin=s2min/sy
5117 if(xmin.ge.1.d0)return
5118 xmin=xmin**(delh+.5d0)
5119
5120
5121 do i=1,7
5122 do m=1,2
5123 z1=(.5d0*(1.d0+xmin-(2*m-3)*x1(i)*(1.d0-xmin)))
5124 * **(1.d0/(delh+.5d0))
5125
5126 st2=0.d0
5127 do j=1,7
5128 do k=1,2
5129 xx=.5d0*(1.d0+x1(j)*(2*k-3))
5130 xp=z1**xx
5131 xm=z1/xp
5132 st2=st2+a1(j)*(1.d0-xp)**ahv(icz)*(1.d0-xm)**ahv(2)
5133 * *(qggrv(xp,qt0,icz,1)+qggrv(xp,qt0,icz,2))
5134 * *(qggrv(xm,qt0,2,1)+qggrv(xm,qt0,2,2))/dsqrt(z1)
5135 enddo
5136 enddo
5137 sj=qgjit(qt0,qt0,z1*sy,2,2)
5138 st2=-st2*dlog(z1)*sj
5139 if(debug.ge.3)write (moniou,203)z1*sy,sj
5140
5141 qghard=qghard+a1(i)/z1**delh*st2
5142 enddo
5143 enddo
5144 qghard=qghard*(1.d0-xmin)/(.5d0+delh)*.25d0*factk
5145 rh=rq(icdp,icz)+rq(icdt,2)
5146 qghard=qghard/(8.d0*pi*rh)*exp(-bb/(4.d0*.0389d0*rh))
5147 **cd(icdp,icz)*cd(icdt,2)
5148
5149 if(debug.ge.2)write (moniou,202)qghard
5150 201 format(2x,'qghard - hard quark-quark interaction eikonal:'
5151 */2x,'s=',e10.3,2x,'icz=',i1)
5152 202 format(2x,'qghard=',e10.3)
5153 203 format(2x,'qghard:',2x,'s_hard=',e10.3,2x,'sigma_hard=',e10.3)
5154 return
5155 end
5156
5157
5158 subroutine qgbdef(bba,bbb,xxa,yya,xxb,yyb,xxp,yyp,jb)
5159
5160
5161
5162 implicit double precision (a-h,o-z)
5163
5164 xx=xxa-xxb
5165 yy=yya-yyb
5166 bb=xx**2+yy**2
5167 if(bb.lt.1.d-5)then
5168 xxp=xxb+dsqrt(bba)
5169 yyp=yyb
5170 elseif(abs(yy).lt.1.d-8)then
5171 xxp=(bba-bbb+xxb**2-xxa**2)/2.d0/(xxb-xxa)
5172 yyp=yyb+(2*jb-3)*dsqrt(max(0.d0,bbb-(xxb-xxp)**2))
5173 else
5174 bbd=bb+bbb-bba
5175 discr=max(0.d0,4.d0*bb*bbb-bbd**2)
5176 xxp=(xx*bbd+(2*jb-3)*abs(yy)*dsqrt(discr))/2.d0/bb
5177 yyp=(bbd-2.d0*xx*xxp)/2.d0/yy
5178 xxp=xxp+xxb
5179 yyp=yyp+yyb
5180 endif
5181 return
5182 end
5183
5184
5185 subroutine qgv(x,y,xb,vin,vdd,vabs)
5186
5187
5188
5189 implicit double precision (a-h,o-z)
5190 integer debug
5191 parameter(iapmax=208)
5192 dimension xb(iapmax,3),vabs(2)
5193 common /qgarr1/ ia(2),icz,icp
5194 common /qgarr2/ scm,wp0,wm0
5195 common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
5196 common /qgarr43/ moniou
5197 common /qgdebug/ debug
5198
5199 if(debug.ge.2)write (moniou,201)x,y
5200
5201 vin=0.d0
5202 vdd=0.d0
5203 do iddp1=1,2
5204 dv=0.d0
5205 do m=1,ia(2)
5206 bb=(x-xb(m,1))**2+(y-xb(m,2))**2
5207 dv=dv+qgpomi(scm,bb,0.d0,0.d0,0.d0,iddp1,iddt(m),icz,1)
5208 enddo
5209 dv=exp(-dv)
5210 vabs(iddp1)=1.d0-dv**2 !1-exp(-2 * chi_i)
5211 vdd=vdd+cc(iddp1,icz)*dv**2 !sum_i cc(i) exp(-2 * chi_i)
5212 vin=vin+cc(iddp1,icz)*dv !sum_i cc(i) exp(-chi_i)
5213 enddo
5214 vin=1.d0-vin**2 !1-sum_ij cc(i) cc(j) exp(-chi_i-chi_j)
5215 vdd=vdd+vin-1.d0
5216 !sum_i cc(i) exp(-2*chi_i) - sum_ij cc(i) cc(j) exp(-chi_i-chi_j)
5217
5218 if(debug.ge.3)write (moniou,202)vin,vdd,vabs
5219 201 format(2x,'qgv - eikonal factor: nucleon coordinates x='
5220 * ,e10.3,2x,'y=',e10.3)
5221 202 format(2x,'vin=',e10.3,2x,'vdd=',e10.3,2x,'vabs=',2e10.3)
5222 return
5223 end
5224
5225
5226
5227 subroutine qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt
5228 * ,vvxpl,vvxtl,ip,it)
5229
5230
5231
5232
5233
5234
5235
5236
5237
5238
5239
5240
5241 implicit double precision (a-h,o-z)
5242 integer debug
5243 parameter(iapmax=208)
5244 dimension vpac(iapmax),vtac(iapmax)
5245 common /qgarr1/ ia(2),icz,icp
5246 common /qgarr2/ scm,wp0,wm0
5247 common /qgarr7/ xa(iapmax,3),xb(iapmax,3),b
5248 common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
5249 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
5250 common /qgarr43/ moniou
5251 common /qgarr46/ iconab(iapmax,iapmax),icona(iapmax)
5252 *,iconb(iapmax)
5253 common /qgdebug/ debug
5254
5255 if(debug.ge.3)write (moniou,201)xxp,yyp,xpomr,ip,it
5256
5257 vvx=0.d0
5258 vvxp=0.d0
5259 vvxt=0.d0
5260 vvxpl=0.d0
5261 vvxtl=0.d0
5262 if(scm.le.sgap**2)return
5263
5264 sumup0=0.d0 !proj. fans without targ. screening
5265 do ipp=1,ia(1)
5266 if(iconab(ipp,it).eq.0)then !no connection
5267 !(nucleon too far from the vertex)
5268 vpac(ipp)=0.d0
5269 else
5270 bbp=(xa(ipp,1)+b-xxp)**2+(xa(ipp,2)-yyp)**2
5271 vpac(ipp)=qgfani(1.d0/xpomr,bbp,1.d0-exp(-sumup0),0.d0,0.d0
5272 * ,iddp(ipp),icz,1)
5273 sumup0=sumup0+vpac(ipp)
5274 endif
5275 enddo
5276
5277 sumut0=0.d0 !targ. fans without proj. screening
5278 do itt=1,ia(2)
5279 if(iconab(ip,itt).eq.0)then !no connection
5280 vtac(itt)=0.d0
5281 else
5282 bbt=(xb(itt,1)-xxp)**2+(xb(itt,2)-yyp)**2
5283 vtac(itt)=qgfani(xpomr*scm,bbt,1.d0-exp(-sumut0),0.d0,0.d0
5284 * ,iddt(itt),2,1)
5285 sumut0=sumut0+vtac(itt)
5286 endif
5287 enddo
5288
5289 nn=0
5290 1 nn=nn+1
5291 sumup=0.d0 !proj. fans with targ. screening
5292 do ipp=1,ia(1)
5293 if(iconab(ipp,it).eq.0)then !no connection
5294 vpac(ipp)=0.d0
5295 else
5296 bbp=(xa(ipp,1)+b-xxp)**2+(xa(ipp,2)-yyp)**2
5297 vpac(ipp)=qgfani(1.d0/xpomr,bbp,1.d0-exp(-sumup-sumut0)
5298 * ,0.d0,0.d0,iddp(ipp),icz,1)
5299 sumup=sumup+vpac(ipp)
5300 endif
5301 enddo
5302
5303 sumut=0.d0 !targ. uncut fans with proj. screening
5304 do itt=1,ia(2)
5305 if(iconab(ip,itt).eq.0)then
5306 vtac(itt)=0.d0
5307 else
5308 bbt=(xb(itt,1)-xxp)**2+(xb(itt,2)-yyp)**2
5309 vtac(itt)=qgfani(xpomr*scm,bbt,1.d0-exp(-sumut-sumup0)
5310 * ,0.d0,0.d0,iddt(itt),2,1)
5311 sumut=sumut+vtac(itt)
5312 endif
5313 enddo
5314
5315 if((abs(sumup-sumup0).gt..01d0.or.abs(sumut-sumut0).gt..01d0)
5316 *.and.nn.lt.100)then
5317 sumup0=sumup
5318 sumut0=sumut
5319 goto 1
5320 endif
5321
5322 if(ia(1).gt.1)then
5323 do ipp=1,ia(1)
5324 if(ipp.lt.ip)then
5325 vvxpl=vvxpl+vpac(ipp)
5326 elseif(ipp.gt.ip)then
5327 vvxp=vvxp+vpac(ipp)
5328 endif
5329 enddo
5330 endif
5331
5332 if(ia(2).gt.1)then
5333 do itt=1,ia(2)
5334 if(itt.lt.it)then
5335 vvxtl=vvxtl+vtac(itt)
5336 elseif(itt.gt.it)then
5337 vvxt=vvxt+vtac(itt)
5338 endif
5339 enddo
5340 endif
5341 vvx=1.d0-exp(-vvxpl-vvxtl)
5342 vvxp=1.d0-exp(-vvxp)
5343 vvxpl=1.d0-exp(-vvxpl)
5344 vvxt=1.d0-exp(-vvxt)
5345 vvxtl=1.d0-exp(-vvxtl)
5346 if(debug.ge.4)write (moniou,202)
5347
5348 201 format(2x,'qgfdf - configuration of fan contributions:'
5349 */2x,'xxp=',e10.3,2x,'yyp=',e10.3,2x,'xpomr=',e10.3
5350 *,2x,'ip=',i3,2x,'it=',i3)
5351 202 format(2x,'qgfdf - end')
5352 return
5353 end
5354
5355
5356 subroutine qgconf
5357
5358
5359
5360
5361
5362
5363
5364
5365
5366
5367
5368
5369
5370
5371
5372
5373
5374
5375
5376
5377
5378
5379
5380
5381
5382
5383
5384
5385
5386
5387
5388
5389
5390
5391
5392
5393
5394
5395
5396
5397
5398
5399
5400
5401
5402
5403
5404
5405
5406
5407
5408
5409
5410
5411
5412
5413
5414
5415
5416
5417
5418
5419
5420 implicit double precision (a-h,o-z)
5421 integer debug
5422 parameter(iapmax=208,npbmax=1000,npnmax=900,npmax=900,legmax=900)
5423 dimension xas(iapmax,3),vabs(2),vabsi(2,iapmax),wdifi(iapmax)
5424 *,vpac(iapmax),vtac(iapmax),xpomip(npmax),xpomim(npmax)
5425 *,vvxim(npmax),bpomim(npmax),xpompi(legmax),xpomti(legmax)
5426 *,vvxpi(legmax),vvxti(legmax),bpompi(legmax),bpomti(legmax)
5427 *,ipompi(legmax),ipomti(legmax),ncola(iapmax),ncolb(iapmax)
5428 *,wdp(2,iapmax),wdt(2,iapmax),wabs(2,2),xrapmin(100),xrapmax(100)
5429 common /qgarr1/ ia(2),icz,icp
5430 common /qgarr2/ scm,wp0,wm0
5431 common /qgarr4/ ey0(3)
5432 common /qgarr6/ pi,bm,amws
5433 common /qgarr7/ xa(iapmax,3),xb(iapmax,3),b
5434 common /qgarr9/ iwp(iapmax),iwt(iapmax),lqa(iapmax),lqb(iapmax)
5435 *,iprcn(iapmax),itgcn(iapmax),ias(npbmax),ibs(npbmax),nqs(npbmax)
5436 *,npompr(npbmax),npomtg(npbmax),npomin(npbmax),nnpr(npmax,npbmax)
5437 *,nntg(npmax,npbmax),ilpr(legmax,npbmax),iltg(legmax,npbmax)
5438 *,lnpr(legmax,npbmax),lntg(legmax,npbmax)
5439 *,nbpi(npnmax,iapmax),nbti(npnmax,iapmax),idnpi(npnmax,iapmax)
5440 *,idnti(npnmax,iapmax),nppi(npnmax,iapmax),npti(npnmax,iapmax)
5441 *,nlpi(npnmax,iapmax),nlti(npnmax,iapmax)
5442 common /qgarr10/ am(7),ammu
5443 common /qgarr11/ b10
5444 common /qgarr12/ nsp
5445 common /qgarr13/ nsf,iaf(iapmax)
5446 common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
5447 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
5448 common /qgarr23/ bbpom(npbmax),vvxpom(npbmax)
5449 *,bpompr(npnmax,iapmax),bpomtg(npnmax,iapmax)
5450 *,vvxpr(npnmax,iapmax),vvxtg(npnmax,iapmax)
5451 *,xpompr(npnmax,iapmax),xpomtg(npnmax,iapmax)
5452 *,xpopin(npmax,npbmax),xpomin(npmax,npbmax),vvxin(npmax,npbmax)
5453 *,bpomin(npmax,npbmax)
5454 common /qgarr43/ moniou
5455 common /qgarr46/ iconab(iapmax,iapmax),icona(iapmax)
5456 *,iconb(iapmax)
5457 common /qgarr55/ nwt,nwp !N of wounded targ.(proj.) nucleons
5458 common /qgarr56/ nspec,nspect !N of spectators targ.(proj.) nucleons
5459 common /qgdebug/ debug
5460 common /qgsIInex1/xan(iapmax,3),xbn(iapmax,3) !used to link with nexus
5461 *,bqgs,bmaxqgs,bmaxnex,bminnex
5462 common/jdiff/bdiff,jdiff !for external use: impact parameter
5463 !for diffraction, diffraction type
5464
5465 integer ng1evt,ng2evt,ikoevt
5466 real rglevt,sglevt,eglevt,fglevt,typevt
5467 common/c2evt/ng1evt,ng2evt,rglevt,sglevt,eglevt,fglevt,ikoevt
5468 *,typevt !in epos.inc
5469
5470 external qgran
5471
5472 if(debug.ge.1)write (moniou,201)
5473 nsp=0
5474 nsf=0
5475 nsp0=nsp
5476
5477
5478 1 continue
5479 do i=1,ia(1)
5480 iddp(i)=1+int(qgran(b10)+cc(2,icz)) !diffractive eigenstates for proj.
5481 enddo
5482 do i=1,ia(2)
5483 iddt(i)=1+int(qgran(b10)+cc(2,2)) !diffractive eigenstates for targ.
5484 enddo
5485
5486
5487
5488 b=bm*dsqrt(qgran(b10))
5489 if(debug.ge.1)write (moniou,202)b
5490
5491 if(bmaxnex.ge.0.d0)then !used to link with nexus
5492 b1=bminnex
5493 b2=min(bm,bmaxnex)
5494 if(b1.gt.b2)stop'bmin > bmax in qgsjet'
5495 b=dsqrt(b1*b1+(b2*b2-b1*b1)*qgran(b10))
5496 bqgs=b
5497 endif
5498
5499
5500
5501 if(debug.ge.1)write (moniou,203)
5502 if(ia(1).gt.1)then !projectile nucleon coordinates
5503 call qggea(ia(1),xa,1) !xa(n,i), i=1,2,3 - x,y,z for n-th nucleon
5504 else
5505 do i=1,3
5506 xa(1,i)=0.d0 !projectile hadron
5507 enddo
5508 endif
5509 if(ia(2).gt.1)then !target nucleon coordinates
5510 call qggea(ia(2),xb,2) !xb(n,i), i=1,2,3 - x,y,z for n-th nucleon
5511 else
5512 do i=1,3
5513 xb(1,i)=0.d0 !target proton
5514 enddo
5515 endif
5516
5517
5518
5519 if(debug.ge.1)write (moniou,204)
5520 do it=1,ia(2)
5521 iconb(it)=0
5522 enddo
5523
5524 do ip=1,ia(1)
5525 icdp=iddp(ip)
5526 icona(ip)=0
5527 do it=1,ia(2)
5528 icdt=iddt(it)
5529 bbp=(xa(ip,1)+b-xb(it,1))**2+(xa(ip,2)-xb(it,2))**2
5530 vv1p=qgpomi(scm,bbp,0.d0,0.d0,0.d0,icdp,icdt,icz,1)
5531 if(vv1p.gt.1.d-3)then
5532 if(debug.ge.2)write (moniou,205)ip,it
5533 iconab(ip,it)=1
5534 icona(ip)=1
5535 iconb(it)=1
5536 if(debug.ge.2)write (moniou,206)ip
5537 if(debug.ge.2)write (moniou,207)it
5538 else
5539 iconab(ip,it)=0
5540 endif
5541 enddo
5542 enddo
5543
5544 nrej=0
5545 2 nrej=nrej+1
5546 if(debug.ge.2)write (moniou,208)nrej
5547 if(nrej.gt.10)then
5548 if(debug.ge.1)write (moniou,209)
5549 goto 1
5550 endif
5551 nsp=nsp0
5552 nbpom=0
5553 nwp=0
5554 nwt=0
5555 do i=1,ia(1)
5556 lqa(i)=0
5557 iwp(i)=0
5558 ncola(i)=0
5559 wdp(1,i)=0.d0
5560 wdp(2,i)=0.d0
5561 enddo
5562 do i=1,ia(2)
5563 lqb(i)=0
5564 iwt(i)=0
5565 ncolb(i)=0
5566 wdt(1,i)=0.d0
5567 wdt(2,i)=0.d0
5568 enddo
5569 nqs(1)=0
5570 npomin(1)=0
5571 npompr(1)=0
5572 npomtg(1)=0
5573
5574
5575
5576 if(debug.ge.1)write (moniou,210)
5577 do 4 ip=1,ia(1) !loop over all projectile nucleons
5578 if(debug.ge.2)write (moniou,211)ip
5579 if(icona(ip).eq.0)goto 4
5580 x=xa(ip,1)+b !proj. x is shifted by the impact parameter b
5581 y=xa(ip,2)
5582 icdp=iddp(ip) !diffr. eigenstate for ip
5583
5584 do 3 it=1,ia(2) !loop over all target nucleons
5585 if(debug.ge.2)write (moniou,212)it
5586 if(iconab(ip,it).eq.0)goto 3
5587 icdt=iddt(it) !diffr. eigenstate for it
5588 bbp=(x-xb(it,1))**2+(y-xb(it,2))**2 !distance squared between ip, it
5589
5590
5591 xpomr=1.d0/dsqrt(scm)
5592 xxp=.5d0*(x+xb(it,1))
5593 yyp=.5d0*(y+xb(it,2))
5594 call qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt,vvxpl,vvxtl
5595 * ,ip,it)
5596 vv=qgpomi(scm,bbp,vvx,vvxp,vvxt,icdp,icdt,icz,1) !total eikonal
5597 vv1p=min(vv,qgpomi(scm,bbp,vvx,vvxp,vvxt,icdp,icdt,icz,2)) !1P-eikonal
5598 if(debug.ge.2)write (moniou,213)vv,vv1p
5599
5600 if(qgran(b10).gt.1.d0-exp(-2.d0*vv))goto 3 !1.-exp(-2*vv) - probability
5601 !for inelastic interaction
5602 iwt(it)=1
5603 iwp(ip)=1
5604 ncola(ip)=ncola(ip)+1 !N of binary collisions for ip
5605 ncolb(it)=ncolb(it)+1 !N of binary collisions for it
5606
5607 n=npgen(2.d0*vv,1,50) !number of elem. inter. for (ip-it) collision
5608 nbpom=nbpom+1 !new Pomeron block
5609 if(nbpom.gt.npbmax)then
5610 goto 2
5611 endif
5612 ias(nbpom)=ip !proj. index for current elementary interaction
5613 ibs(nbpom)=it !targ. index for current elementary interaction
5614 bbpom(nbpom)=bbp !distance squared between ip, it
5615 vvxpom(nbpom)=1.d0-(1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxt)
5616 if(debug.ge.2)write (moniou,214)nbpom,ip,it,n
5617
5618 nqs(nbpom)=0
5619 npomin(nbpom)=0
5620 npompr(nbpom)=0
5621 npomtg(nbpom)=0
5622 do i=1,n
5623 if(qgran(b10).lt.vv1p/vv.or.scm.le.sgap**2)then !single Pomeron
5624 if(debug.ge.2)write (moniou,215)i
5625 np=nqs(nbpom)+1
5626 if(np.gt.legmax)then
5627 goto 2
5628 endif
5629 nqs(nbpom)=np !update Pomeron number in the block
5630 l0=lqa(ip)+1
5631 if(l0.gt.npnmax)then
5632 goto 2
5633 endif
5634 lqa(ip)=l0 !update number of connections for proj.
5635 nnpr(np,nbpom)=l0 !index for connected proj. participant
5636 nbpi(l0,ip)=nbpom
5637 idnpi(l0,ip)=0
5638 nppi(l0,ip)=np
5639 l0=lqb(it)+1
5640 if(l0.gt.npnmax)then
5641 goto 2
5642 endif
5643 lqb(it)=l0
5644 nntg(np,nbpom)=l0 !index for connected targ. participant
5645 nbti(l0,it)=nbpom
5646 idnti(l0,it)=0
5647 npti(l0,it)=np
5648
5649 else !multi-Pomeron vertex
5650 if(debug.ge.2)write (moniou,219)
5651 call qg3pdf(vvxpi,vvxti,xpompi,xpomti,bpompi,bpomti,xpomip
5652 * ,xpomim,vvxim,bpomim,npompi,npomti,npin,ipompi,ipomti
5653 * ,wdp,wdt,ip,it,iret)
5654 if(iret.ne.0)goto 2
5655
5656 if(npin.ne.0)then
5657 if(debug.ge.2)write (moniou,220)i,npin
5658 npomin(nbpom)=npomin(nbpom)+npin
5659 if(npomin(nbpom).gt.npmax)then
5660 goto 2
5661 endif
5662 do l=1,npin
5663 l1=npomin(nbpom)+l-npin
5664 xpopin(l1,nbpom)=xpomip(l)
5665 xpomin(l1,nbpom)=xpomim(l)
5666 vvxin(l1,nbpom)=vvxim(l)
5667 bpomin(l1,nbpom)=bpomim(l)
5668 enddo
5669 endif
5670 if(npompi.ne.0)then
5671 if(debug.ge.2)write (moniou,221)i,npompi
5672 do m=1,npompi
5673 np=npompr(nbpom)+1
5674 if(np.gt.legmax)then
5675 goto 2
5676 endif
5677 npompr(nbpom)=np
5678 ipp=ipompi(m)
5679 iwp(ipp)=1
5680 ilpr(np,nbpom)=ipp
5681 l0=lqa(ipp)+1
5682 if(l0.gt.npnmax)then
5683 goto 2
5684 endif
5685 lqa(ipp)=l0
5686 lnpr(np,nbpom)=l0
5687 nbpi(l0,ipp)=nbpom
5688 idnpi(l0,ipp)=1
5689 nlpi(l0,ipp)=np
5690 vvxpr(l0,ipp)=vvxpi(m)
5691 xpompr(l0,ipp)=1.d0/xpompi(m)/scm
5692 bpompr(l0,ipp)=bpompi(m)
5693 enddo
5694 endif
5695 if(npomti.ne.0)then
5696 if(debug.ge.2)write (moniou,222)i,npomti
5697 do m=1,npomti
5698 np=npomtg(nbpom)+1
5699 if(np.gt.legmax)then
5700 goto 2
5701 endif
5702 npomtg(nbpom)=np
5703 itt=ipomti(m)
5704 iwt(itt)=1
5705 iltg(np,nbpom)=itt
5706 l0=lqb(itt)+1
5707 if(l0.gt.npnmax)then
5708 goto 2
5709 endif
5710 lqb(itt)=l0
5711 lntg(np,nbpom)=l0
5712 nbti(l0,itt)=nbpom
5713 idnti(l0,itt)=1
5714 nlti(l0,itt)=np
5715 vvxtg(l0,itt)=vvxti(m)
5716 xpomtg(l0,itt)=xpomti(m)
5717 bpomtg(l0,itt)=bpomti(m)
5718 enddo
5719 endif
5720 endif
5721 enddo !end of Pomeron loop
5722 3 continue !end of it-loop
5723 4 continue !end of ip-loop
5724
5725
5726
5727 if(ia(1).eq.1.and.ia(2).eq.1.and.iwp(1).eq.0.and.iwt(1).eq.0)then
5728 wel=0.d0
5729 winel=0.d0
5730 do icdp=1,2
5731 do icdt=1,2
5732 vv=qgpomi(scm,b*b,0.d0,0.d0,0.d0,icdp,icdt,icz,1) !total eikonal
5733 wabs(icdp,icdt)=exp(-vv)
5734 wel=wel+cc(icdp,icz)*cc(icdt,2)*wabs(icdp,icdt)
5735 winel=winel+cc(icdp,icz)*cc(icdt,2)*wabs(icdp,icdt)**2
5736 enddo
5737 enddo
5738 if(qgran(b10).le.wel**2/winel)then
5739 if(debug.ge.1)write (moniou,231)
5740 goto 1
5741 endif
5742
5743 wdifp=cc(1,icz)*cc(2,icz)*(cc(1,2)**2*(wabs(1,1)-wabs(2,1))**2
5744 * +cc(2,2)**2*(wabs(1,2)-wabs(2,2))**2+2.d0*cc(1,2)*cc(2,2)
5745 * *(wabs(1,1)-wabs(2,1))*(wabs(1,2)-wabs(2,2)))
5746 wdift=cc(1,2)*cc(2,2)*(cc(1,icz)**2*(wabs(1,1)-wabs(1,2))**2
5747 * +cc(2,icz)**2*(wabs(2,1)-wabs(2,2))**2+2.d0*cc(1,icz)*cc(2,icz)
5748 * *(wabs(1,1)-wabs(1,2))*(wabs(2,1)-wabs(2,2)))
5749 wdifd=cc(1,icz)*cc(2,icz)*cc(1,2)*cc(2,2)
5750 * *(wabs(1,1)+wabs(2,2)-wabs(1,2)-wabs(2,1))**2
5751 aks=(wdifp+wdift+wdifd)*qgran(b10)
5752 if(aks.lt.wdifp)then
5753 nwp=nwp+1
5754 iwp(1)=2
5755 iprcn(1)=1
5756 iwt(1)=-1
5757 elseif(aks.lt.wdifp+wdift)then
5758 nwt=nwt+1
5759 iwt(1)=2
5760 itgcn(1)=1
5761 iwp(1)=-1
5762 else
5763 nwp=nwp+1
5764 nwt=nwt+1
5765 iwp(1)=2
5766 iwt(1)=2
5767 iprcn(1)=1
5768 itgcn(1)=1
5769 endif
5770 goto 9
5771 endif
5772
5773
5774
5775 do ip=1,ia(1) !loop over all projectile nucleons
5776 x=xa(ip,1)+b !proj. x is shifted by b
5777 y=xa(ip,2)
5778 if(iwp(ip).ne.0)then
5779 nwp=nwp+1 !one more wounded proj. nucleon
5780 if(lqa(ip).eq.0.and.(wdp(1,ip).ne.0.d0.or.wdp(2,ip).ne.0.d0))
5781 * then
5782 icdps=iddp(ip)
5783 xpomr=1.d0/dsqrt(scm)
5784 do it=1,ia(2)
5785 if(iconab(ip,it).ne.0)then
5786 bbp=(x-xb(it,1))**2+(y-xb(it,2))**2
5787 xxp=.5d0*(x+xb(it,1))
5788 yyp=.5d0*(y+xb(it,2))
5789 icdt=iddt(it)
5790 do icdp=1,2
5791 iddp(ip)=icdp
5792 call qgfdf(xxp,yyp,xpomr,vpac,vtac
5793 * ,vvx,vvxp,vvxt,vvxpl,vvxtl,ip,it)
5794 vv=qgpomi(scm,bbp,vvx,vvxp,vvxt,icdp,icdt,icz,1) !total eikonal
5795 wdp(icdp,ip)=wdp(icdp,ip)*exp(-vv)
5796 enddo
5797 endif
5798 enddo
5799 iddp(ip)=icdps
5800 wdifr=cc(1,icz)*cc(2,icz)*(wdp(1,ip)-wdp(2,ip))**2
5801 * /(cc(1,icz)*wdp(1,ip)**2+cc(2,icz)*wdp(2,ip)**2)
5802 if(qgran(b10).lt.wdifr)iwp(ip)=3 !LMD excitation
5803 endif
5804
5805 elseif(icona(ip).ne.0)then
5806 if(debug.ge.2)write (moniou,223)ip
5807 vabs(1)=0.d0
5808 vabs(2)=0.d0
5809 icdps=iddp(ip)
5810 do it=1,ia(2)
5811 bbp=(x-xb(it,1))**2+(y-xb(it,2))**2
5812 icdt=iddt(it)
5813 do icdp=1,2
5814 if(iconab(ip,it).eq.0)then
5815 vabsi(icdp,it)=0.d0
5816 else
5817 iddp(ip)=icdp
5818 xpomr=1.d0/dsqrt(scm)
5819 xxp=.5d0*(x+xb(it,1))
5820 yyp=.5d0*(y+xb(it,2))
5821 call qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt,vvxpl,vvxtl
5822 * ,ip,it)
5823 vv=qgpomi(scm,bbp,vvx,vvxp,vvxt,icdp,icdt,icz,1) !total eikonal
5824 vabsi(icdp,it)=vv
5825 vabs(icdp)=vabs(icdp)+vv
5826 endif
5827 enddo
5828 enddo
5829 iddp(ip)=icdps
5830 wdifr=cc(1,icz)*cc(2,icz)*(exp(-vabs(1))-exp(-vabs(2)))**2
5831 * /(cc(1,icz)*exp(-2.d0*vabs(1))+cc(2,icz)*exp(-2.d0*vabs(2)))
5832
5833 if(qgran(b10).lt.wdifr)then !projectile diffraction
5834 wdift=0.d0
5835 do it=1,ia(2)
5836 if(iwt(it).ne.-1)then
5837 wdifi(it)=cc(1,icz)*cc(2,icz)*(exp(-vabsi(1,it))
5838 * -exp(-vabsi(2,it)))**2/(cc(1,icz)*exp(-2.d0*vabsi(1,it))
5839 * +cc(2,icz)*exp(-2.d0*vabsi(2,it)))
5840 wdift=wdift+wdifi(it)
5841 else
5842 wdifi(it)=0.d0
5843 endif
5844 enddo
5845 if(wdift.ne.0.d0)then
5846 nwp=nwp+1
5847 iwp(ip)=2
5848 aks=qgran(b10)*wdift
5849 do it=1,ia(2)
5850 aks=aks-wdifi(it)
5851 if(aks.lt.0.d0)goto 5
5852 enddo
5853 5 continue
5854 iprcn(ip)=it
5855 if(iwt(it).eq.0)iwt(it)=-1
5856 if(debug.ge.2)write (moniou,224)ip,it
5857 endif
5858 endif
5859 endif
5860 enddo !end of ip-loop
5861
5862 do 8 it=1,ia(2) !check target diffraction
5863 if(iwt(it).gt.0)then
5864 nwt=nwt+1 !one more wounded targ. nucleon
5865 if(lqb(it).eq.0.and.(wdt(1,it).ne.0.d0.or.wdt(2,it).ne.0.d0))
5866 * then
5867 icdts=iddt(it)
5868 xpomr=1.d0/dsqrt(scm)
5869 do ip=1,ia(1)
5870 if(iconab(ip,it).ne.0)then
5871 bbp=(xa(ip,1)+b-xb(it,1))**2+(xa(ip,2)-xb(it,2))**2
5872 xxp=.5d0*(xa(ip,1)+b+xb(it,1))
5873 yyp=.5d0*(xa(ip,2)+xb(it,2))
5874 icdp=iddp(ip)
5875 do icdt=1,2
5876 iddt(it)=icdt
5877 call qgfdf(xxp,yyp,xpomr,vpac,vtac
5878 * ,vvx,vvxp,vvxt,vvxpl,vvxtl,ip,it)
5879 vv=qgpomi(scm,bbp,vvx,vvxp,vvxt,icdp,icdt,icz,1) !total eikonal
5880 wdt(icdt,it)=wdt(icdt,it)*exp(-vv)
5881 enddo
5882 endif
5883 enddo
5884 iddt(it)=icdts
5885 wdifr=cc(1,2)*cc(2,2)*(wdt(1,it)-wdt(2,it))**2
5886 * /(cc(1,2)*wdt(1,it)**2+cc(2,2)*wdt(2,it)**2)
5887 if(qgran(b10).lt.wdifr)iwt(it)=3
5888 endif
5889
5890 elseif(iconb(it).ne.0)then
5891 if(debug.ge.2)write (moniou,225)it
5892 vabs(1)=0.d0
5893 vabs(2)=0.d0
5894 icdts=iddt(it)
5895 do ip=1,ia(1)
5896 bbp=(xa(ip,1)+b-xb(it,1))**2+(xa(ip,2)-xb(it,2))**2
5897 icdp=iddp(ip)
5898 do icdt=1,2
5899 if(iconab(ip,it).eq.0)then
5900 vabsi(icdt,ip)=0.d0
5901 else
5902 iddt(it)=icdt
5903 xpomr=1.d0/dsqrt(scm)
5904 xxp=.5d0*(xa(ip,1)+b+xb(it,1))
5905 yyp=.5d0*(xa(ip,2)+xb(it,2))
5906 call qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt,vvxpl,vvxtl
5907 * ,ip,it)
5908 vv=qgpomi(scm,bbp,vvx,vvxp,vvxt,icdp,icdt,icz,1) !total eikonal
5909 vabsi(icdt,ip)=vv
5910 vabs(icdt)=vabs(icdt)+vv
5911 endif
5912 enddo
5913 enddo
5914 iddt(it)=icdts
5915 wdifr=cc(1,2)*cc(2,2)*(exp(-vabs(1))-exp(-vabs(2)))**2
5916 * /(cc(1,2)*exp(-2.d0*vabs(1))+cc(2,2)*exp(-2.d0*vabs(2)))
5917
5918 if(qgran(b10).lt.wdifr)then !target diffraction
5919 wdift=0.d0
5920 do ip=1,ia(1)
5921 if(iwp(ip).eq.-1)then
5922 wdifi(ip)=0.d0
5923 else
5924 if(iwp(ip).eq.2)then
5925 itt=iprcn(ip)
5926 if(itt.eq.it)goto 7
5927 if(iwt(itt).eq.2)then
5928 wdifi(ip)=0.d0
5929 goto 6
5930 endif
5931 endif
5932 wdifi(ip)=cc(1,2)*cc(2,2)*(exp(-vabsi(1,ip))
5933 * -exp(-vabsi(2,ip)))**2/(cc(1,2)*exp(-2.d0*vabsi(1,ip))
5934 * +cc(2,2)*exp(-2.d0*vabsi(2,ip)))
5935 endif
5936 6 wdift=wdift+wdifi(ip)
5937 enddo
5938 if(wdift.eq.0.d0)goto 8
5939 nwt=nwt+1
5940 iwt(it)=2
5941 aks=qgran(b10)*wdift
5942 do ip=1,ia(1)
5943 aks=aks-wdifi(ip)
5944 if(aks.lt.0.d0)goto 7
5945 enddo
5946 7 continue
5947 itgcn(it)=ip
5948 if(debug.ge.2)write (moniou,226)it,ip
5949 if(iwp(ip).eq.0)then
5950 iwp(ip)=-1
5951 elseif(iwp(ip).eq.2)then
5952 itt=iprcn(ip)
5953 iprcn(ip)=it
5954 if(itt.ne.it.and.iwt(itt).eq.-1)iwt(itt)=0
5955 endif
5956 endif
5957 endif
5958 8 continue
5959
5960
5961 9 jdiff=0 !non-diffractive
5962 if(ia(1).eq.1.and.ia(2).eq.1.and.(nwp.ne.0.or.nwt.ne.0)
5963 *.and.nqs(1).eq.0)then
5964 if(lqa(1).eq.0.and.lqb(1).eq.0)then
5965 if(nbpom.eq.0.or.npomin(1).eq.0)then
5966 if(iwp(1).ge.2.and.iwt(1).lt.2)then
5967 jdiff=6 !SD(LM)-proj
5968 elseif(iwp(1).lt.2.and.iwt(1).ge.2)then
5969 jdiff=7 !SD(LM)-targ
5970 elseif(iwp(1).ge.2.and.iwt(1).ge.2)then
5971 jdiff=8 !DD(LM)
5972 else
5973 goto 12
5974 endif
5975 else
5976 if(iwp(1).lt.2.and.iwt(1).lt.2)then
5977 jdiff=9 !CD(DPE)
5978 else
5979 jdiff=10 !CD+LMD
5980 endif
5981 endif
5982 elseif(lqa(1).gt.0.and.lqb(1).eq.0.and.iwt(1).lt.2)then
5983 jdiff=1 !SD(HM)-proj
5984 elseif(lqa(1).eq.0.and.lqb(1).gt.0.and.iwp(1).lt.2)then
5985 jdiff=2 !SD(HM)-targ
5986 elseif(lqa(1).gt.0.and.lqb(1).eq.0.and.iwt(1).ge.2)then
5987 jdiff=3 !DD(LHM)-proj
5988 elseif(lqa(1).eq.0.and.lqb(1).gt.0.and.iwp(1).ge.2)then
5989 jdiff=4 !DD(LHM)-targ
5990
5991 elseif(lqa(1).gt.0.and.lqb(1).gt.0)then
5992 if(npompr(1).eq.0)stop'problem with npompr!!!'
5993 xrapmax(1)=1.d0
5994 do i=1,npompr(1)
5995 xrapmax(1)=min(xrapmax(1),1.d0/xpompr(i,1)/scm)
5996 enddo
5997 if(npomtg(1).eq.0)stop'problem with npomtg!!!'
5998 xrapmin(1)=1.d0/scm
5999 do i=1,npomtg(1)
6000 xrapmin(1)=max(xrapmin(1),xpomtg(i,1))
6001 enddo
6002 if(xrapmin(1).gt..999d0*xrapmax(1))goto 12
6003 nraps=1
6004 irap=1
6005 11 if(nraps.gt.90)stop'nraps>90'
6006 if(npomin(1).gt.0)then
6007 do i=1,npomin(1)
6008 if(xpomin(i,1).lt..999d0*xrapmax(irap)
6009 * .and.xpopin(i,1).gt.1.001d0*xrapmin(irap))then
6010 if(xpomin(i,1).lt.1.001d0*xrapmin(irap)
6011 * .and.xpopin(i,1).gt..999d0*xrapmax(irap))then
6012 nraps=nraps-1
6013 if(nraps.eq.0)goto 12
6014 irap=irap-1
6015 goto 11
6016 elseif(xpopin(i,1).gt..999d0*xrapmax(irap))then
6017 xrapmax(irap)=xpomin(i,1)
6018 if(xrapmin(irap).gt..999d0*xrapmax(irap))then
6019 nraps=nraps-1
6020 if(nraps.eq.0)goto 12
6021 irap=irap-1
6022 goto 11
6023 endif
6024 elseif(xpomin(i,1).lt.1.001d0*xrapmin(irap))then
6025 xrapmin(irap)=xpopin(i,1)
6026 if(xrapmin(irap).gt..999d0*xrapmax(irap))then
6027 nraps=nraps-1
6028 if(nraps.eq.0)goto 12
6029 irap=irap-1
6030 goto 11
6031 endif
6032 else
6033 xrapmin(irap+1)=xrapmin(irap)
6034 xrapmin(irap)=xpopin(i,1)
6035 xrapmax(irap+1)=xpomin(i,1)
6036 if(xrapmin(irap).lt..999d0*xrapmax(irap)
6037 * .and.xrapmin(irap+1).lt..999d0*xrapmax(irap+1))then
6038 irap=irap+1
6039 nraps=nraps+1
6040 goto 11
6041 elseif(xrapmin(irap).lt..999d0*xrapmax(irap))then
6042 goto 11
6043 elseif(xrapmin(irap+1).lt..999d0*xrapmax(irap+1))then
6044 xrapmin(irap)=xrapmin(irap+1)
6045 xrapmax(irap)=xrapmax(irap+1)
6046 goto 11
6047 else
6048 nraps=nraps-1
6049 if(nraps.eq.0)goto 12
6050 irap=irap-1
6051 goto 11
6052 endif
6053 endif
6054 endif
6055 enddo !end of npin-loop
6056 endif
6057 jdiff=5 !DD(HM)
6058 endif
6059 endif !end of diffr. check
6060 12 bdiff=b
6061
6062
6063 typevt=0 !no interaction
6064 if(ia(1).eq.1.and.ia(2).eq.1.and.(nwp.gt.0.or.nwt.gt.0))then !only for h-h
6065 if(jdiff.eq.0)then !ND (no rap-gaps)
6066 typevt=1
6067 elseif(jdiff.eq.8.or.jdiff.eq.10.or.
6068 * (jdiff.gt.2.and.jdiff.lt.6))then !DD + (CD+LMD)
6069 typevt=2
6070 elseif(jdiff.eq.1.or.jdiff.eq.6)then !SD pro
6071 typevt=4
6072 elseif(jdiff.eq.2.or.jdiff.eq.7)then !SD tar
6073 typevt=-4
6074 elseif(jdiff.eq.9)then !CD
6075 typevt=3
6076 else
6077 stop'problem with typevt!'
6078 endif
6079 endif
6080
6081
6082
6083 if(debug.ge.1)write (moniou,227)
6084 nspec=0
6085 do ip=1,ia(1)
6086 if(iwp(ip).eq.0)then
6087 if(debug.ge.2)write (moniou,228)ip
6088 nspec=nspec+1
6089 do l=1,3
6090 xas(nspec,l)=xa(ip,l)
6091 enddo
6092 endif
6093 enddo
6094
6095 nspect=0
6096 do it=1,ia(2)
6097 if(iwt(it).eq.0)nspect=nspect+1
6098 enddo
6099
6100
6101 if(nwp.ne.0.or.nwt.ne.0)then
6102 if(ia(1).eq.nspec.or.ia(2).eq.nspect)stop'ia(1)=nspec!!!'
6103 if(debug.ge.1)write (moniou,229)
6104
6105 call qgsha(nbpom,ncola,ncolb,iret)
6106 if(iret.ne.0)goto 1
6107 if(nsp.le.nsp0+2)then
6108 if(debug.ge.1)write (moniou,230)
6109 goto 1
6110 endif
6111 else !no interaction
6112 if(debug.ge.1)write (moniou,231)
6113 goto 1
6114 endif
6115 if(debug.ge.1)write (moniou,232)nsp
6116
6117
6118 if(debug.ge.1)write (moniou,233)
6119 call qgfrgm(nspec,xas)
6120 if(debug.ge.1)write (moniou,234)nsf
6121 if(debug.ge.1)write (moniou,235)
6122
6123 201 format(2x,'qgconf - configuration of the interaction')
6124 202 format(2x,'qgconf: impact parameter b=',e10.3,' fm')
6125 203 format(2x,'qgconf: nuclear configurations')
6126 204 format(2x,'qgconf: check connections')
6127 205 format(2x,'qgconf: ',i3,'-th proj. nucleon may interact with '
6128 *,i3,'-th target nucleon')
6129 206 format(2x,'qgconf: ',i3,'-th projectile nucleon may interact')
6130 207 format(2x,'qgconf: ',i3,'-th target nucleon may interact')
6131 208 format(2x,'qgconf: ',i3,'-th rejection,'
6132 *,' redo Pomeron configuration')
6133 209 format(2x,'qgconf: too many rejections,'
6134 *,' redo nuclear configuartions')
6135 210 format(2x,'qgconf: Pomeron configuration')
6136 211 format(2x,'qgconf: check ',i3,'-th projectile nucleon')
6137 212 format(2x,'qgconf: interaction with ',i3,'-th target nucleon?')
6138 213 format(2x,'qgconf: eikonals - total: ',e10.3,2x,'single: ',e10.3)
6139 214 format(2x,'qgconf: ',i4,'-th Pomeron block connected to ',i3
6140 *,'-th proj. nucleon and'/4x,i3,'-th targ. nucleon;'
6141 *,' number of element. processes in the block: ',i3)
6142 215 format(2x,'qgconf: ',i3
6143 *,'-th process in the block is single cut Pomeron')
6144 219 format(2x,'qgconf: configuration of multi-Pomeron vertexes')
6145 220 format(2x,'qgconf: ',i3,'-th process in the block contains '
6146 *,i3,' interm. Pomerons')
6147 221 format(2x,'qgconf: ',i3,'-th process in the block contains '
6148 *,i3,' proj. legs')
6149 222 format(2x,'qgconf: ',i3,'-th process in the block contains '
6150 *,i3,' targ. legs')
6151 223 format(2x,'qgconf: check diffraction for ',i3,'-th proj. nucleon')
6152 224 format(2x,'qgconf: diffr. of ',i3,'-th proj. nucleon,'
6153 *,' recoil of ',i3,'-th targ. nucleon')
6154 225 format(2x,'qgconf: check diffraction for ',i3,'-th targ. nucleon')
6155 226 format(2x,'qgconf: diffr. of ',i3,'-th targ. nucleon,'
6156 *,' recoil of ',i3,'-th proj. nucleon')
6157 227 format(2x,'qgconf: projectile spectator part')
6158 228 format(2x,'qgconf: ',i3,'-th proj. nucleon stays idle')
6159 229 format(2x,'qgconf: inelastic interaction: energy sharing'
6160 *,' and particle production')
6161 230 format(2x,'qgconf: no particle produced - rejection')
6162 231 format(2x,'qgconf: no interaction - rejection')
6163 232 format(2x,'qgconf: ',i5,' particles have been produced')
6164 233 format(2x,'qgconf: fragmentation of the proj. spectator part')
6165 234 format(2x,'qgconf: ',i3,' proj. fragments have been produced')
6166 235 format(2x,'qgconf - end')
6167 return
6168 end
6169
6170
6171 subroutine qg3pdf(vvxpi,vvxti,xpompi,xpomti,bpompi,bpomti
6172 *,xpomip,xpomim,vvxim,bpomim,nppr,nptg,npin,ipompi,ipomti
6173 *,wdp,wdt,ip,it,iret)
6174
6175
6176
6177
6178
6179
6180
6181
6182
6183
6184
6185
6186
6187
6188
6189
6190
6191
6192
6193
6194
6195 implicit double precision (a-h,o-z)
6196 integer debug
6197 parameter(iapmax=208,npbmax=1000,npnmax=900,npmax=900
6198 *,levmax=20,legmax=900)
6199 dimension vpac(iapmax),vtac(iapmax)
6200 *,vpac0(iapmax),vtac0(iapmax),vpact(iapmax),vtact(iapmax)
6201 *,xpomip(npmax),xpomim(npmax),vvxim(npmax),bpomim(npmax)
6202 *,xpompi(legmax),xpomti(legmax)
6203 *,vvxpi(legmax),vvxti(legmax),bpompi(legmax),bpomti(legmax)
6204 *,ipompi(legmax),ipomti(legmax),ippr0(legmax),iptg0(legmax)
6205 *,nppm(levmax),ippm(legmax,levmax),ii(levmax),xpomm(levmax)
6206 *,wgpm(levmax),xxm(levmax),yym(levmax)
6207 *,itypr0(legmax),itytg0(legmax),itypm(legmax,levmax),vv(12)
6208 *,wdp(2,iapmax),wdt(2,iapmax)
6209 common /qgarr1/ ia(2),icz,icp
6210 common /qgarr2/ scm,wp0,wm0
6211 common /qgarr6/ pi,bm,amws
6212 common /qgarr7/ xa(iapmax,3),xb(iapmax,3),b
6213 common /qgarr9/ iwp(iapmax),iwt(iapmax),lqa(iapmax),lqb(iapmax)
6214 *,iprcn(iapmax),itgcn(iapmax),ias(npbmax),ibs(npbmax),nqs(npbmax)
6215 *,npompr(npbmax),npomtg(npbmax),npomin(npbmax),nnpr(npmax,npbmax)
6216 *,nntg(npmax,npbmax),ilpr(legmax,npbmax),iltg(legmax,npbmax)
6217 *,lnpr(legmax,npbmax),lntg(legmax,npbmax)
6218 *,nbpi(npnmax,iapmax),nbti(npnmax,iapmax),idnpi(npnmax,iapmax)
6219 *,idnti(npnmax,iapmax),nppi(npnmax,iapmax),npti(npnmax,iapmax)
6220 *,nlpi(npnmax,iapmax),nlti(npnmax,iapmax)
6221 common /qgarr11/ b10
6222 common /qgarr12/ nsp
6223 common /qgarr13/ nsf,iaf(iapmax)
6224 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
6225 common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
6226 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
6227 common /qgarr19/ ahl(3)
6228 common /qgarr23/ bbpom(npbmax),vvxpom(npbmax)
6229 *,bpompr(npnmax,iapmax),bpomtg(npnmax,iapmax)
6230 *,vvxpr(npnmax,iapmax),vvxtg(npnmax,iapmax)
6231 *,xpompr(npnmax,iapmax),xpomtg(npnmax,iapmax)
6232 *,xpopin(npmax,npbmax),xpomin(npmax,npbmax),vvxin(npmax,npbmax)
6233 *,bpomin(npmax,npbmax)
6234 common /qgarr43/ moniou
6235 common /qgarr46/ iconab(iapmax,iapmax),icona(iapmax)
6236 *,iconb(iapmax)
6237 common /qgdebug/ debug
6238 external qgran
6239
6240 if(debug.ge.2)write (moniou,201)ip,it
6241
6242 if(scm.le.sgap**2)stop'qg3pdf: scm<sgap**2!'
6243 iret=0
6244 vpacng=0.d0
6245 vtacng=0.d0
6246 vpacpe=0.d0
6247 vtacpe=0.d0
6248 vimp=0.d0
6249 viuc=0.d0
6250 viuu=0.d0
6251 vip=0.d0
6252 vicc=0.d0
6253 vicu=0.d0
6254
6255 xpomr=1.d0/dsqrt(scm)
6256 bpt=dsqrt((xa(ip,1)+b-xb(it,1))**2+(xa(ip,2)-xb(it,2))**2)
6257 rp1=(rq(iddp(ip),icz)-alfp*dlog(xpomr))*4.d0*.0389d0
6258 rp2=(rq(iddt(it),2)+alfp*dlog(xpomr*scm))*4.d0*.0389d0
6259 rp0=rp1*rp2/(rp1+rp2)
6260 bbpr=(bpt*rp1/(rp1+rp2))**2
6261 bbtg=(bpt*rp2/(rp1+rp2))**2
6262 call qgbdef(bbpr,bbtg,xa(ip,1)+b,xa(ip,2),xb(it,1),xb(it,2)
6263 *,xxp,yyp,1)
6264
6265 rpmax=max(rq(iddp(ip),icz),rq(iddt(it),2))*4.d0*.0389d0
6266 rpmin=min(rq(iddp(ip),icz),rq(iddt(it),2))*4.d0*.0389d0
6267 if(rpmax.eq.rpmin)then
6268 rpmax=rpmax+alfp*dlog(scm)*2.d0*.0389d0
6269 rpmin=rpmin+alfp*dlog(scm)*2.d0*.0389d0
6270 else
6271 rpmin=rpmin+alfp*dlog(scm/sgap)*4.d0*.0389d0
6272 endif
6273 rp0=rpmax*rpmin/(rpmax+rpmin)
6274
6275 call qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt,vvxpl,vvxtl
6276 *,ip,it)
6277 vvxts=1.d0-(1.d0-vvx)*(1.d0-vvxt)*exp(-vtac(it))
6278 vpl=qglegi(1.d0/xpomr,bbpr,iddp(ip),icz,2)
6279 vplc=min(vpl
6280 *,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp,vvxpl,iddp(ip),icz,7))
6281 vplc0=min(vplc
6282 *,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp,vvxpl,iddp(ip),icz,8))
6283 vplcpe=min(vplc0
6284 *,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp,vvxpl,iddp(ip),icz,10))
6285 vplcp=min(vplcpe
6286 *,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp,vvxpl,iddp(ip),icz,9))
6287
6288 vvxps=1.d0-(1.d0-vvx)*(1.d0-vvxp)*exp(-vpac(ip))
6289 vtl=qglegi(xpomr*scm,bbtg,iddt(it),2,2)
6290 vtlc=min(vtl
6291 *,qgfani(xpomr*scm,bbtg,vvxps,vvxt,vvxtl,iddt(it),2,7))
6292 vtlc0=min(vtlc
6293 *,qgfani(xpomr*scm,bbtg,vvxps,vvxt,vvxtl,iddt(it),2,8))
6294 vtlcpe=min(vtlc0
6295 *,qgfani(xpomr*scm,bbtg,vvxps,vvxt,vvxtl,iddt(it),2,10))
6296 vtlcp=min(vtlcpe
6297 *,qgfani(xpomr*scm,bbtg,vvxps,vvxt,vvxtl,iddt(it),2,9))
6298
6299 sumcp0=0.d0
6300 sumup=0.d0
6301 do i=1,ia(1)
6302 sumup=sumup+vpac(i)
6303 enddo
6304 vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
6305 do i=1,ia(1)-ip+1
6306 ipp=ia(1)-i+1
6307 bbp=(xa(ipp,1)+b-xxp)**2+(xa(ipp,2)-yyp)**2
6308 sumup=sumup-vpac(ipp)
6309 vpac0(ipp)=min(vpac(ipp)
6310 * ,qgfani(1.d0/xpomr,bbp,1.d0-vvxs*exp(-sumup)
6311 * ,1.d0-exp(-sumcp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
6312 if(ipp.gt.ip)sumcp0=sumcp0+vpac0(ipp)
6313 enddo
6314 sumct0=0.d0
6315 sumut=0.d0
6316 do i=1,ia(2)
6317 sumut=sumut+vtac(i)
6318 enddo
6319 vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
6320 do i=1,ia(2)-it+1
6321 itt=ia(2)-i+1
6322 bbt=(xb(itt,1)-xxp)**2+(xb(itt,2)-yyp)**2
6323 sumut=sumut-vtac(itt)
6324 vtac0(itt)=min(vtac(itt)
6325 * ,qgfani(xpomr*scm,bbt,1.d0-vvxs*exp(-sumut)
6326 * ,1.d0-exp(-sumct0),1.d0-exp(-sumut),iddt(itt),2,3))
6327 if(itt.gt.it)sumct0=sumct0+vtac0(itt)
6328 enddo
6329 vvxp0=1.d0-exp(-sumcp0)
6330 vvxt0=1.d0-exp(-sumct0)
6331
6332
6333
6334 vv(1)=(max(0.d0,1.d0-exp(-2.d0*vpac(ip))*(1.d0+2.d0*vpac(ip)))
6335 *+2.d0*vpac(ip)*exp(-2.d0*vpac(ip))*(1.d0-(1.d0-vvxp)**2))
6336 **(max(0.d0,1.d0-exp(-2.d0*vtac(it))*(1.d0+2.d0*vtac(it)))
6337 *+2.d0*vtac(it)*exp(-2.d0*vtac(it))*(1.d0-(1.d0-vvxt)**2))
6338 **(1.d0-vvx)**2
6339 *-2.d0*(max(0.d0,exp(vpac(ip)-vpac0(ip))-1.d0
6340 *-(vpac(ip)-vpac0(ip)))
6341 **(1.d0-vvxp0)+(vpac(ip)-vpac0(ip))*(vvxp-vvxp0))*exp(-vpac(ip))
6342 **(max(0.d0,1.d0-exp(-2.d0*vtac(it))*(1.d0+2.d0*vtac(it)))
6343 *+2.d0*vtac(it)*exp(-2.d0*vtac(it))*(1.d0-(1.d0-vvxt)**2))
6344 **(1.d0-vvx)*(1.d0-vvxtl)
6345 *-2.d0*(max(0.d0,1.d0-exp(-2.d0*vpac(ip))*(1.d0+2.d0*vpac(ip)))
6346 *+2.d0*vpac(ip)*exp(-2.d0*vpac(ip))*(1.d0-(1.d0-vvxp)**2))
6347 **(max(0.d0,exp(vtac(it)-vtac0(it))-1.d0-(vtac(it)-vtac0(it)))
6348 **(1.d0-vvxt0)+(vtac(it)-vtac0(it))*(vvxt-vvxt0))*exp(-vtac(it))
6349 **(1.d0-vvx)*(1.d0-vvxpl)
6350
6351 vv(2)=((1.d0-exp(-vpac(ip)))**2*(1.d0-vvxpl)
6352 *+2.d0*(1.d0-exp(-vpac(ip)))*vvxpl)
6353 **((1.d0-exp(-vtac(it)))**2*(1.d0-vvxtl)
6354 *+2.d0*(1.d0-exp(-vtac(it)))*vvxtl)*(1.d0-vvx)
6355
6356 vv(3)=((1.d0-exp(-vpac(ip)))**2*(1.d0-vvxpl)
6357 *+2.d0*(1.d0-exp(-vpac(ip)))*vvxpl)*(1.d0-vvx)
6358 **((max(0.d0,1.d0-exp(-2.d0*vtac(it))*(1.d0+2.d0*vtac(it)))
6359 *+2.d0*vtac(it)*exp(-2.d0*vtac(it))*(1.d0-(1.d0-vvxt)**2))
6360 **(1.d0-vvxtl)
6361 *-2.d0*(max(0.d0,exp(vtac(it)-vtac0(it))-1.d0
6362 *-(vtac(it)-vtac0(it)))
6363 **(1.d0-vvxt0)+(vtac(it)-vtac0(it))*(vvxt-vvxt0))*exp(-vtac(it)))
6364
6365 vv(4)=((max(0.d0,1.d0-exp(-2.d0*vpac(ip))*(1.d0+2.d0*vpac(ip)))
6366 *+2.d0*vpac(ip)*exp(-2.d0*vpac(ip))*(1.d0-(1.d0-vvxp)**2))
6367 **(1.d0-vvxpl)
6368 *-2.d0*(max(0.d0,exp(vpac(ip)-vpac0(ip))-1.d0
6369 *-(vpac(ip)-vpac0(ip)))
6370 **(1.d0-vvxp0)+(vpac(ip)-vpac0(ip))*(vvxp-vvxp0))*exp(-vpac(ip)))
6371 **((1.d0-exp(-vtac(it)))**2*(1.d0-vvxtl)
6372 *+2.d0*(1.d0-exp(-vtac(it)))*vvxtl)*(1.d0-vvx)
6373
6374 vv(5)=4.d0*(1.d0-exp(-vpac(ip)))*(1.d0-vvx)
6375 **(max(0.d0,exp(vtac(it)-vtac0(it))-1.d0-(vtac(it)-vtac0(it)))
6376 **(1.d0-vvxt0)+(vtac(it)-vtac0(it))*(vvxt-vvxt0))*exp(-vtac(it))
6377 if(xpomr*scm.lt.1.1d0*sgap**2)vv(5)=0.d0
6378
6379 vv(6)=4.d0*(max(0.d0,exp(vpac(ip)-vpac0(ip))-1.d0
6380 *-(vpac(ip)-vpac0(ip)))*(1.d0-vvxp0)
6381 *+(vpac(ip)-vpac0(ip))*(vvxp-vvxp0))*exp(-vpac(ip))
6382 **(1.d0-exp(-vtac(it)))*(1.d0-vvx)
6383 if(xpomr*sgap**2.gt..9d0)vv(6)=0.d0
6384
6385 vv(7)=(max(0.d0,1.d0-exp(-2.d0*vpac(ip))*(1.d0+2.d0*vpac(ip)))
6386 *+2.d0*vpac(ip)*exp(-2.d0*vpac(ip))*(1.d0-(1.d0-vvxp)**2))
6387 **((vtac0(it)+vtlc0)*exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
6388 *-(vtac(it)+vtlc-vtac0(it)-vtlc0)
6389 **(1.d0-exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)))*exp(-vtac(it))
6390 **(1.d0-vvx)*(1.d0-vvxpl)*(1.d0-vvxt)
6391 *-2.d0*(max(0.d0,exp(vpac(ip)-vpac0(ip))-1.d0
6392 *-(vpac(ip)-vpac0(ip)))
6393 **(1.d0-vvxp0)+(vpac(ip)-vpac0(ip))*(vvxp-vvxp0))
6394 **(vtac(it)+vtlc)*exp(-vpac(ip)-2.d0*vtac(it))
6395 **(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)
6396
6397 vv(8)=((vpac0(ip)+vplc0)*exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
6398 *-(vpac(ip)+vplc-vpac0(ip)-vplc0)
6399 **(1.d0-exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)))*exp(-vpac(ip))
6400 **(max(0.d0,1.d0-exp(-2.d0*vtac(it))*(1.d0+2.d0*vtac(it)))
6401 *+2.d0*vtac(it)*exp(-2.d0*vtac(it))*(1.d0-(1.d0-vvxt)**2))
6402 **(1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxtl)
6403 *-2.d0*(vpac(ip)+vplc)*exp(-2.d0*vpac(ip)-vtac(it))
6404 **(max(0.d0,exp(vtac(it)-vtac0(it))-1.d0-(vtac(it)-vtac0(it)))
6405 **(1.d0-vvxt0)+(vtac(it)-vtac0(it))*(vvxt-vvxt0))
6406 **(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)
6407
6408 vv(9)=((1.d0-exp(-vpac(ip)))**2*(1.d0-vvxpl)
6409 *+2.d0*(1.d0-exp(-vpac(ip)))*vvxpl)*(1.d0-vvx)*(1.d0-vvxt)
6410 **((vtac0(it)+vtlc0)*exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
6411 *-(vtac(it)+vtlc-vtac0(it)-vtlc0)
6412 **(1.d0-exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)))*exp(-vtac(it))
6413
6414 vv(10)=((vpac0(ip)+vplc0)*exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
6415 *-(vpac(ip)+vplc-vpac0(ip)-vplc0)
6416 **(1.d0-exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)))*exp(-vpac(ip))
6417 **((1.d0-exp(-vtac(it)))**2*(1.d0-vvxtl)
6418 *+2.d0*(1.d0-exp(-vtac(it)))*vvxtl)*(1.d0-vvx)*(1.d0-vvxp)
6419
6420 vv(11)=2.d0*vplcp*((vtlc0-vtlcpe)
6421 **exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
6422 *-(vtlc-vtlc0)*(1.d0-exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)))
6423 **exp(-2.d0*vpac(ip)-vtac(it))
6424 **(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)*(1.d0-vvxt)
6425 if(xpomr*scm.lt.1.1d0*sgap**2)vv(11)=0.d0
6426
6427 vv(12)=2.d0*vtlcp*((vplc0-vplcpe)
6428 **exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
6429 *-(vplc-vplc0)*(1.d0-exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)))
6430 **exp(-2.d0*vtac(it)-vpac(ip))
6431 **(1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxt)**2*(1.d0-vvxtl)
6432 if(xpomr*sgap**2.gt..9d0)vv(12)=0.d0
6433
6434 gb0=0.d0
6435 do i=1,12
6436 gb0=gb0+max(0.d0,vv(i))/4.d0
6437 enddo
6438
6439 if(gb0.le.0.d0)then !so170712
6440 if(debug.ge.3)write (moniou,202)
6441 iret=1
6442 goto 31
6443 endif
6444 if(debug.ge.3)write (moniou,203)gb0
6445
6446 1 continue
6447 xpomr=(scm/sgap**2)**(-qgran(b10))/sgap !proposed LC momentum for 3P-vertex
6448 rp1=(rq(iddp(ip),icz)-alfp*dlog(xpomr))*4.d0*.0389d0
6449 rp2=(rq(iddt(it),2)+alfp*dlog(xpomr*scm))*4.d0*.0389d0
6450 rp=rp1*rp2/(rp1+rp2)
6451 z=qgran(b10)
6452 phi=pi*qgran(b10)
6453 b0=dsqrt(-rp*dlog(z))
6454 bbpr=(bpt*rp1/(rp1+rp2)+b0*cos(phi))**2+(b0*sin(phi))**2
6455 bbtg=(bpt*rp2/(rp1+rp2)-b0*cos(phi))**2+(b0*sin(phi))**2
6456 call qgbdef(bbpr,bbtg,xa(ip,1)+b,xa(ip,2),xb(it,1),xb(it,2)
6457 *,xxp,yyp,int(1.5d0+qgran(b10))) !determine coordinates for the vertex
6458
6459 call qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt,vvxpl,vvxtl
6460 *,ip,it)
6461 vvxts=1.d0-(1.d0-vvx)*(1.d0-vvxt)*exp(-vtac(it))
6462 vpl=qglegi(1.d0/xpomr,bbpr,iddp(ip),icz,2)
6463 vplc=min(vpl
6464 *,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp,vvxpl,iddp(ip),icz,7))
6465 vplc0=min(vplc
6466 *,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp,vvxpl,iddp(ip),icz,8))
6467 vplcpe=min(vplc0
6468 *,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp,vvxpl,iddp(ip),icz,10))
6469 vplcp=min(vplcpe
6470 *,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp,vvxpl,iddp(ip),icz,9))
6471
6472 vvxps=1.d0-(1.d0-vvx)*(1.d0-vvxp)*exp(-vpac(ip))
6473 vtl=qglegi(xpomr*scm,bbtg,iddt(it),2,2)
6474 vtlc=min(vtl
6475 *,qgfani(xpomr*scm,bbtg,vvxps,vvxt,vvxtl,iddt(it),2,7))
6476 vtlc0=min(vtlc
6477 *,qgfani(xpomr*scm,bbtg,vvxps,vvxt,vvxtl,iddt(it),2,8))
6478 vtlcpe=min(vtlc0
6479 *,qgfani(xpomr*scm,bbtg,vvxps,vvxt,vvxtl,iddt(it),2,10))
6480 vtlcp=min(vtlcpe
6481 *,qgfani(xpomr*scm,bbtg,vvxps,vvxt,vvxtl,iddt(it),2,9))
6482
6483 sumcp0=0.d0
6484 sumup=0.d0
6485 do i=1,ia(1)
6486 sumup=sumup+vpac(i)
6487 enddo
6488 vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
6489 do i=1,ia(1)-ip+1
6490 ipp=ia(1)-i+1
6491 bbp=(xa(ipp,1)+b-xxp)**2+(xa(ipp,2)-yyp)**2
6492 sumup=sumup-vpac(ipp)
6493 vpac0(ipp)=min(vpac(ipp)
6494 * ,qgfani(1.d0/xpomr,bbp,1.d0-vvxs*exp(-sumup)
6495 * ,1.d0-exp(-sumcp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
6496 if(ipp.gt.ip)sumcp0=sumcp0+vpac0(ipp)
6497 enddo
6498 sumct0=0.d0
6499 sumut=0.d0
6500 do i=1,ia(2)
6501 sumut=sumut+vtac(i)
6502 enddo
6503 vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
6504 do i=1,ia(2)-it+1
6505 itt=ia(2)-i+1
6506 bbt=(xb(itt,1)-xxp)**2+(xb(itt,2)-yyp)**2
6507 sumut=sumut-vtac(itt)
6508 vtac0(itt)=min(vtac(itt)
6509 * ,qgfani(xpomr*scm,bbt,1.d0-vvxs*exp(-sumut)
6510 * ,1.d0-exp(-sumct0),1.d0-exp(-sumut),iddt(itt),2,3))
6511 if(itt.gt.it)sumct0=sumct0+vtac0(itt)
6512 enddo
6513 vvxp0=1.d0-exp(-sumcp0)
6514 vvxt0=1.d0-exp(-sumct0)
6515
6516
6517
6518 vv(1)=(max(0.d0,1.d0-exp(-2.d0*vpac(ip))*(1.d0+2.d0*vpac(ip)))
6519 *+2.d0*vpac(ip)*exp(-2.d0*vpac(ip))*(1.d0-(1.d0-vvxp)**2))
6520 **(max(0.d0,1.d0-exp(-2.d0*vtac(it))*(1.d0+2.d0*vtac(it)))
6521 *+2.d0*vtac(it)*exp(-2.d0*vtac(it))*(1.d0-(1.d0-vvxt)**2))
6522 **(1.d0-vvx)**2
6523 *-2.d0*(max(0.d0,exp(vpac(ip)-vpac0(ip))-1.d0
6524 *-(vpac(ip)-vpac0(ip)))
6525 **(1.d0-vvxp0)+(vpac(ip)-vpac0(ip))*(vvxp-vvxp0))*exp(-vpac(ip))
6526 **(max(0.d0,1.d0-exp(-2.d0*vtac(it))*(1.d0+2.d0*vtac(it)))
6527 *+2.d0*vtac(it)*exp(-2.d0*vtac(it))*(1.d0-(1.d0-vvxt)**2))
6528 **(1.d0-vvx)*(1.d0-vvxtl)
6529 *-2.d0*(max(0.d0,1.d0-exp(-2.d0*vpac(ip))*(1.d0+2.d0*vpac(ip)))
6530 *+2.d0*vpac(ip)*exp(-2.d0*vpac(ip))*(1.d0-(1.d0-vvxp)**2))
6531 **(max(0.d0,exp(vtac(it)-vtac0(it))-1.d0-(vtac(it)-vtac0(it)))
6532 **(1.d0-vvxt0)+(vtac(it)-vtac0(it))*(vvxt-vvxt0))*exp(-vtac(it))
6533 **(1.d0-vvx)*(1.d0-vvxpl)
6534
6535 vv(2)=((1.d0-exp(-vpac(ip)))**2*(1.d0-vvxpl)
6536 *+2.d0*(1.d0-exp(-vpac(ip)))*vvxpl)
6537 **((1.d0-exp(-vtac(it)))**2*(1.d0-vvxtl)
6538 *+2.d0*(1.d0-exp(-vtac(it)))*vvxtl)*(1.d0-vvx)
6539
6540 vv(3)=((1.d0-exp(-vpac(ip)))**2*(1.d0-vvxpl)
6541 *+2.d0*(1.d0-exp(-vpac(ip)))*vvxpl)*(1.d0-vvx)
6542 **((max(0.d0,1.d0-exp(-2.d0*vtac(it))*(1.d0+2.d0*vtac(it)))
6543 *+2.d0*vtac(it)*exp(-2.d0*vtac(it))*(1.d0-(1.d0-vvxt)**2))
6544 **(1.d0-vvxtl)
6545 *-2.d0*(max(0.d0,exp(vtac(it)-vtac0(it))-1.d0
6546 *-(vtac(it)-vtac0(it)))
6547 **(1.d0-vvxt0)+(vtac(it)-vtac0(it))*(vvxt-vvxt0))*exp(-vtac(it)))
6548
6549 vv(4)=((max(0.d0,1.d0-exp(-2.d0*vpac(ip))*(1.d0+2.d0*vpac(ip)))
6550 *+2.d0*vpac(ip)*exp(-2.d0*vpac(ip))*(1.d0-(1.d0-vvxp)**2))
6551 **(1.d0-vvxpl)
6552 *-2.d0*(max(0.d0,exp(vpac(ip)-vpac0(ip))-1.d0
6553 *-(vpac(ip)-vpac0(ip)))
6554 **(1.d0-vvxp0)+(vpac(ip)-vpac0(ip))*(vvxp-vvxp0))*exp(-vpac(ip)))
6555 **((1.d0-exp(-vtac(it)))**2*(1.d0-vvxtl)
6556 *+2.d0*(1.d0-exp(-vtac(it)))*vvxtl)*(1.d0-vvx)
6557
6558 vv(5)=4.d0*(1.d0-exp(-vpac(ip)))*(1.d0-vvx)
6559 **(max(0.d0,exp(vtac(it)-vtac0(it))-1.d0-(vtac(it)-vtac0(it)))
6560 **(1.d0-vvxt0)+(vtac(it)-vtac0(it))*(vvxt-vvxt0))*exp(-vtac(it))
6561 if(xpomr*scm.le.sgap**2)vv(5)=0.d0
6562
6563 vv(6)=4.d0*(max(0.d0,exp(vpac(ip)-vpac0(ip))-1.d0
6564 *-(vpac(ip)-vpac0(ip)))*(1.d0-vvxp0)
6565 *+(vpac(ip)-vpac0(ip))*(vvxp-vvxp0))*exp(-vpac(ip))
6566 **(1.d0-exp(-vtac(it)))*(1.d0-vvx)
6567 if(xpomr*sgap**2.ge.1.d0)vv(6)=0.d0
6568
6569 vv(7)=(max(0.d0,1.d0-exp(-2.d0*vpac(ip))*(1.d0+2.d0*vpac(ip)))
6570 *+2.d0*vpac(ip)*exp(-2.d0*vpac(ip))*(1.d0-(1.d0-vvxp)**2))
6571 **((vtac0(it)+vtlc0)*exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
6572 *-(vtac(it)+vtlc-vtac0(it)-vtlc0)
6573 **(1.d0-exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)))*exp(-vtac(it))
6574 **(1.d0-vvx)*(1.d0-vvxpl)*(1.d0-vvxt)
6575 *-2.d0*(max(0.d0,exp(vpac(ip)-vpac0(ip))-1.d0
6576 *-(vpac(ip)-vpac0(ip)))
6577 **(1.d0-vvxp0)+(vpac(ip)-vpac0(ip))*(vvxp-vvxp0))
6578 **(vtac(it)+vtlc)*exp(-vpac(ip)-2.d0*vtac(it))
6579 **(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)
6580
6581 vv(8)=((vpac0(ip)+vplc0)*exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
6582 *-(vpac(ip)+vplc-vpac0(ip)-vplc0)
6583 **(1.d0-exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)))*exp(-vpac(ip))
6584 **(max(0.d0,1.d0-exp(-2.d0*vtac(it))*(1.d0+2.d0*vtac(it)))
6585 *+2.d0*vtac(it)*exp(-2.d0*vtac(it))*(1.d0-(1.d0-vvxt)**2))
6586 **(1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxtl)
6587 *-2.d0*(vpac(ip)+vplc)*exp(-2.d0*vpac(ip)-vtac(it))
6588 **(max(0.d0,exp(vtac(it)-vtac0(it))-1.d0-(vtac(it)-vtac0(it)))
6589 **(1.d0-vvxt0)+(vtac(it)-vtac0(it))*(vvxt-vvxt0))
6590 **(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)
6591
6592 vv(9)=((1.d0-exp(-vpac(ip)))**2*(1.d0-vvxpl)
6593 *+2.d0*(1.d0-exp(-vpac(ip)))*vvxpl)*(1.d0-vvx)*(1.d0-vvxt)
6594 **((vtac0(it)+vtlc0)*exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
6595 *-(vtac(it)+vtlc-vtac0(it)-vtlc0)
6596 **(1.d0-exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)))*exp(-vtac(it))
6597
6598 vv(10)=((vpac0(ip)+vplc0)*exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
6599 *-(vpac(ip)+vplc-vpac0(ip)-vplc0)
6600 **(1.d0-exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)))*exp(-vpac(ip))
6601 **((1.d0-exp(-vtac(it)))**2*(1.d0-vvxtl)
6602 *+2.d0*(1.d0-exp(-vtac(it)))*vvxtl)*(1.d0-vvx)*(1.d0-vvxp)
6603
6604 vv(11)=2.d0*vplcp*((vtlc0-vtlcpe)
6605 **exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
6606 *-(vtlc-vtlc0)*(1.d0-exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)))
6607 **exp(-2.d0*vpac(ip)-vtac(it))
6608 **(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)*(1.d0-vvxt)
6609 if(xpomr*scm.lt.1.1d0*sgap**2)vv(11)=0.d0
6610
6611 vv(12)=2.d0*vtlcp*((vplc0-vplcpe)
6612 **exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
6613 *-(vplc-vplc0)*(1.d0-exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)))
6614 **exp(-2.d0*vtac(it)-vpac(ip))
6615 **(1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxt)**2*(1.d0-vvxtl)
6616 if(xpomr*sgap**2.gt..9d0)vv(12)=0.d0
6617
6618 gb=0.d0
6619 do i=1,12
6620 vv(i)=max(0.d0,vv(i))
6621 gb=gb+vv(i)/4.d0
6622 enddo
6623 gb=gb/gb0/z*rp/rp0 /max(2.d0,dlog10(scm)-1.d0) /2.
6624 if(debug.ge.5)write (moniou,204)xpomr,bbpr,bbtg,gb
6625
6626 if(qgran(b10).gt.gb)goto 1
6627 if(debug.ge.3)write (moniou,205)xpomr,bbpr,bbtg,xxp,yyp
6628
6629 vplcng=min(vplc0
6630 *,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp,vvxpl,iddp(ip),icz,11))
6631 vtlcng=min(vtlc0
6632 *,qgfani(xpomr*scm,bbtg,vvxps,vvxt,vvxtl,iddt(it),2,11))
6633
6634 sumcpt=0.d0
6635 sumcp0=0.d0
6636 sumup=0.d0
6637 vvxp0l=0.d0
6638 do i=1,ia(1)
6639 sumup=sumup+vpac(i)
6640 enddo
6641 vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
6642 do i=1,ia(1)
6643 ipp=ia(1)-i+1
6644 bbp=(xa(ipp,1)+b-xxp)**2+(xa(ipp,2)-yyp)**2
6645 sumup=sumup-vpac(ipp)
6646 if(ipp.ge.ip)vpact(ipp)=max(vpac(ipp)
6647 * ,qgfani(1.d0/xpomr,bbp,1.d0-vvxs*exp(-sumup)
6648 * ,1.d0-exp(-sumcpt),1.d0-exp(-sumup),iddp(ipp),icz,6))
6649 vpac0(ipp)=min(vpac(ipp)
6650 * ,qgfani(1.d0/xpomr,bbp,1.d0-vvxs*exp(-sumup)
6651 * ,1.d0-exp(-sumcp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
6652 if(ipp.gt.ip)then
6653 sumcpt=sumcpt+vpact(ipp)
6654 elseif(ipp.lt.ip)then
6655 vvxp0l=vvxp0l+vpac0(ipp)
6656 endif
6657 sumcp0=sumcp0+vpac0(ipp)
6658 enddo
6659 sumctt=0.d0
6660 sumct0=0.d0
6661 sumut=0.d0
6662 vvxt0l=0.d0
6663 do i=1,ia(2)
6664 sumut=sumut+vtac(i)
6665 enddo
6666 vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
6667 do i=1,ia(2)
6668 itt=ia(2)-i+1
6669 bbt=(xb(itt,1)-xxp)**2+(xb(itt,2)-yyp)**2
6670 sumut=sumut-vtac(itt)
6671 if(itt.ge.it)vtact(itt)=max(vtac(itt)
6672 * ,qgfani(xpomr*scm,bbt,1.d0-vvxs*exp(-sumut)
6673 * ,1.d0-exp(-sumctt),1.d0-exp(-sumut),iddt(itt),2,6))
6674 vtac0(itt)=min(vtac(itt)
6675 * ,qgfani(xpomr*scm,bbt,1.d0-vvxs*exp(-sumut)
6676 * ,1.d0-exp(-sumct0),1.d0-exp(-sumut),iddt(itt),2,3))
6677 if(itt.gt.it)then
6678 sumctt=sumctt+vtact(itt)
6679 elseif(itt.lt.it)then
6680 vvxt0l=vvxt0l+vtac0(itt)
6681 endif
6682 sumct0=sumct0+vtac0(itt)
6683 enddo
6684 vvxpt=1.d0-exp(-sumcpt)
6685 vvxtt=1.d0-exp(-sumctt)
6686 vvxp0l=1.d0-exp(-vvxp0l)
6687 vvxt0l=1.d0-exp(-vvxt0l)
6688
6689 vvt=0.d0
6690 do i=1,12
6691 vvt=vvt+vv(i)
6692 enddo
6693 if(.not.(vvt.gt.0.d0))stop'vvt<0'
6694
6695 aks=qgran(b10)*vvt
6696 do jt=1,12
6697 aks=aks-vv(jt)
6698 if(aks.lt.0.d0)goto 2
6699 enddo
6700 stop'jt>12!'
6701
6702 2 continue
6703 if(xpomr*scm.gt.sgap**2)then
6704 wzgp=-2.d0*(1.d0-exp(-2.d0*vpac(ip)))*(1.d0-vvxpl)**2
6705 * *(max(0.d0,1.d0-exp(-vtact(it))*(1.d0+vtact(it)))*(1.d0-vvxtt)
6706 * -max(0.d0,1.d0-exp(-vtac0(it))*(1.d0+vtac0(it)))*(1.d0-vvxt0)
6707 * +vtact(it)*exp(-vtact(it))*(1.d0-vvxtt
6708 * -exp(vtact(it)-vtac(it))*(1.d0-vvxtl)*(1.d0-vvxt))
6709 * -vtac0(it)*exp(-vtac0(it))*(1.d0-vvxt0
6710 * -exp(vtac0(it)-vtac(it))*(1.d0-vvxtl)*(1.d0-vvxt)))
6711 else
6712 wzgp=0.d0
6713 endif
6714 if(xpomr*sgap**2.lt.1.d0)then
6715 wzgt=-2.d0*(1.d0-exp(-2.d0*vtac(it)))*(1.d0-vvxtl)**2
6716 * *(max(0.d0,1.d0-exp(-vpact(ip))*(1.d0+vpact(ip)))*(1.d0-vvxpt)
6717 * -max(0.d0,1.d0-exp(-vpac0(ip))*(1.d0+vpac0(ip)))*(1.d0-vvxp0)
6718 * +vpact(ip)*exp(-vpact(ip))*(1.d0-vvxpt
6719 * -exp(vpact(ip)-vpac(ip))*(1.d0-vvxpl)*(1.d0-vvxp))
6720 * -vpac0(ip)*exp(-vpac0(ip))*(1.d0-vvxp0
6721 * -exp(vpac0(ip)-vpac(ip))*(1.d0-vvxpl)*(1.d0-vvxp)))
6722 else
6723 wzgt=0.d0
6724 endif
6725
6726 nppr0=0
6727 nptg0=0
6728 npprh0=0
6729 nptgh0=0
6730 wgpr0=0.d0
6731 wgtg0=0.d0
6732 if(jt.eq.1.or.jt.eq.4.or.jt.eq.7)then
6733 ntry=0
6734 3 ntry=ntry+1
6735 npprh0=0
6736 if(ip.eq.ia(1).or.ntry.gt.100)then
6737 nppr0=npgen(2.d0*vpac(ip),2,20)
6738 do i=1,nppr0
6739 if(qgran(b10).le.vpac0(ip)/vpac(ip).or.xpomr*sgap**2.ge.1.d0)
6740 * then
6741 itypr0(i)=0
6742 else
6743 npprh0=npprh0+1
6744 itypr0(i)=1
6745 endif
6746 ippr0(i)=ip
6747 enddo
6748 wh=(vpac(ip)/vpac0(ip)-1.d0)/nppr0
6749 else
6750 nppr0=npgen(2.d0*vpac(ip),1,20)
6751 do i=1,nppr0
6752 if(qgran(b10).le.vpac0(ip)/vpac(ip).or.xpomr*sgap**2.ge.1.d0)
6753 * then
6754 itypr0(i)=0
6755 else
6756 npprh0=npprh0+1
6757 itypr0(i)=1
6758 endif
6759 ippr0(i)=ip
6760 enddo
6761 wh=(vpac(ip)/vpac0(ip)-1.d0)/nppr0
6762 do ipp=ip+1,ia(1)
6763 ninc=npgen(2.d0*vpac(ipp),0,20)
6764 if(ninc.ne.0)then
6765 nppr0=nppr0+ninc
6766 nh0=npprh0
6767 if(nppr0.gt.legmax)then
6768 iret=1
6769 goto 31
6770 endif
6771 do i=nppr0-ninc+1,nppr0
6772 if(qgran(b10).le.vpac0(ipp)/vpac(ipp)
6773 * .or.xpomr*sgap**2.ge.1.d0)then
6774 itypr0(i)=0
6775 else
6776 npprh0=npprh0+1
6777 itypr0(i)=1
6778 endif
6779 ippr0(i)=ipp
6780 enddo
6781 if(ninc.gt.npprh0-nh0)wh=(vpac(ipp)/vpac0(ipp)-1.d0)/ninc
6782 endif
6783 enddo
6784 if(nppr0.eq.1)goto 3
6785 endif
6786 if(nppr0.le.npprh0+1)then
6787 if(jt.ne.7)then
6788 wh0=1.d0-exp(vpac(ip)+(1.d0-nppr0)*dlog(2.d0))
6789 * /(1.d0-vvxp)/(1.d0-vvxpl)
6790 else
6791 wh0=1.d0-exp(vpac(ip)+(1.d0-nppr0)*dlog(2.d0))
6792 * /(1.d0-vvxp)/(1.d0-vvxpl)
6793 * *(vtac(it)+vtlc)*exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
6794 * /((vtac0(it)+vtlc0)*exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
6795 * -(vtac(it)+vtlc-vtac0(it)-vtlc0)
6796 * *(1.d0-exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)))
6797 endif
6798 if(nppr0.eq.npprh0.and.wh0.lt.0.d0
6799 * .or.nppr0.eq.npprh0+1.and.qgran(b10).gt.1.d0+wh*wh0)goto 3
6800 endif
6801 endif
6802
6803 if(jt.eq.1.or.jt.eq.3.or.jt.eq.8)then
6804 ntry=0
6805 4 ntry=ntry+1
6806 nptgh0=0
6807 if(it.eq.ia(2).or.ntry.gt.100)then
6808 nptg0=npgen(2.d0*vtac(it),2,20)
6809 do i=1,nptg0
6810 if(qgran(b10).le.vtac0(it)/vtac(it).or.xpomr*scm.le.sgap**2)
6811 * then
6812 itytg0(i)=0
6813 else
6814 nptgh0=nptgh0+1
6815 itytg0(i)=1
6816 endif
6817 iptg0(i)=it
6818 enddo
6819 wh=(vtac(it)/vtac0(it)-1.d0)/nptg0
6820 else
6821 nptg0=npgen(2.d0*vtac(it),1,20)
6822 do i=1,nptg0
6823 if(qgran(b10).le.vtac0(it)/vtac(it).or.xpomr*scm.le.sgap**2)
6824 * then
6825 itytg0(i)=0
6826 else
6827 nptgh0=nptgh0+1
6828 itytg0(i)=1
6829 endif
6830 iptg0(i)=it
6831 enddo
6832 wh=(vtac(it)/vtac0(it)-1.d0)/nptg0
6833 do itt=it+1,ia(2)
6834 ninc=npgen(2.d0*vtac(itt),0,20)
6835 if(ninc.ne.0)then
6836 nptg0=nptg0+ninc
6837 nh0=nptgh0
6838 if(nptg0.gt.legmax)then
6839 iret=1
6840 goto 31
6841 endif
6842 do i=nptg0-ninc+1,nptg0
6843 if(qgran(b10).le.vtac0(itt)/vtac(itt)
6844 * .or.xpomr*scm.le.sgap**2) then
6845 itytg0(i)=0
6846 else
6847 nptgh0=nptgh0+1
6848 itytg0(i)=1
6849 endif
6850 iptg0(i)=itt
6851 enddo
6852 if(ninc.gt.nptgh0-nh0)wh=(vtac(itt)/vtac0(itt)-1.d0)/ninc
6853 endif
6854 enddo
6855 if(nptg0.eq.1)goto 4
6856 endif
6857 if(nptg0.le.nptgh0+1)then
6858 if(jt.ne.8)then
6859 wh0=1.d0-exp(vtac(it)+(1.d0-nptg0)*dlog(2.d0))
6860 * /(1.d0-vvxt)/(1.d0-vvxtl)
6861 else
6862 wh0=1.d0-exp(vtac(it)+(1.d0-nptg0)*dlog(2.d0))
6863 * /(1.d0-vvxt)/(1.d0-vvxtl)
6864 * *(vpac(ip)+vplc)*exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
6865 * /((vpac0(ip)+vplc0)*exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
6866 * -(vpac(ip)+vplc-vpac0(ip)-vplc0)
6867 * *(1.d0-exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)))
6868 endif
6869 if(nptg0.eq.nptgh0.and.wh0.lt.0.d0
6870 * .or.nptg0.eq.nptgh0+1.and.qgran(b10).gt.1.d0+wh*wh0)goto 4
6871 endif
6872 endif
6873
6874 if(jt.eq.6)then
6875 ntry=0
6876 5 ntry=ntry+1
6877 if(ip.eq.ia(1).or.ntry.gt.100)then
6878 nppr0=npgen(vpac(ip)-vpac0(ip),2,20)
6879 do i=1,nppr0
6880 itypr0(i)=1
6881 ippr0(i)=ip
6882 enddo
6883 else
6884 nppr0=npgen(vpac(ip)-vpac0(ip),1,20)
6885 do i=1,nppr0
6886 itypr0(i)=1
6887 ippr0(i)=ip
6888 enddo
6889 do ipp=ip+1,ia(1)
6890 ninc=npgen(vpac(ipp)-vpac0(ipp),0,20)
6891 if(ninc.ne.0)then
6892 nppr0=nppr0+ninc
6893 if(nppr0.gt.legmax)then
6894 iret=1
6895 goto 31
6896 endif
6897 do i=nppr0-ninc+1,nppr0
6898 itypr0(i)=1
6899 ippr0(i)=ipp
6900 enddo
6901 endif
6902 enddo
6903 if(nppr0.eq.1)goto 5
6904 endif
6905 endif
6906
6907 if(jt.eq.5)then
6908 ntry=0
6909 6 ntry=ntry+1
6910 if(it.eq.ia(2).or.ntry.gt.100)then
6911 nptg0=npgen(vtac(it)-vtac0(it),2,20)
6912 do i=1,nptg0
6913 itytg0(i)=1
6914 iptg0(i)=it
6915 enddo
6916 else
6917 nptg0=npgen(vtac(it)-vtac0(it),1,20)
6918 do i=1,nptg0
6919 itytg0(i)=1
6920 iptg0(i)=it
6921 enddo
6922 do itt=it+1,ia(2)
6923 ninc=npgen(vtac(itt)-vtac0(itt),0,20)
6924 if(ninc.ne.0)then
6925 nptg0=nptg0+ninc
6926 if(nptg0.gt.legmax)then
6927 iret=1
6928 goto 31
6929 endif
6930 do i=nptg0-ninc+1,nptg0
6931 itytg0(i)=1
6932 iptg0(i)=itt
6933 enddo
6934 endif
6935 enddo
6936 if(nptg0.eq.1)goto 6
6937 endif
6938 endif
6939
6940 gbt=1.d0
6941 if((jt.eq.1.and.nptgh0.lt.nptg0.or.jt.eq.4)
6942 *.and.npprh0.eq.nppr0)then
6943 gbt=1.d0-exp(vpac(ip)+(1.d0-nppr0)*dlog(2.d0))
6944 * /(1.d0-vvxp)/(1.d0-vvxpl)
6945 elseif((jt.eq.1.and.npprh0.lt.nppr0.or.jt.eq.3)
6946 *.and.nptgh0.eq.nptg0)then
6947 gbt=1.d0-exp(vtac(it)+(1.d0-nptg0)*dlog(2.d0))
6948 * /(1.d0-vvxt)/(1.d0-vvxtl)
6949 elseif(jt.eq.1.and.nptgh0.eq.nptg0.and.npprh0.eq.nppr0)then
6950 gbt=1.d0-exp(vpac(ip)+(1.d0-nppr0)*dlog(2.d0))
6951 * /(1.d0-vvxp)/(1.d0-vvxpl)
6952 * -exp(vtac(it)+(1.d0-nptg0)*dlog(2.d0))/(1.d0-vvxt)/(1.d0-vvxtl)
6953 elseif(jt.eq.7.and.npprh0.eq.nppr0)then
6954 gbt=1.d0-exp(vpac(ip)+(1.d0-nppr0)*dlog(2.d0))
6955 * /(1.d0-vvxp)/(1.d0-vvxpl)
6956 * *(vtac(it)+vtlc)*exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
6957 * /((vtac0(it)+vtlc0)*exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
6958 * -(vtac(it)+vtlc-vtac0(it)-vtlc0)
6959 * *(1.d0-exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)))
6960 elseif(jt.eq.8.and.nptgh0.eq.nptg0)then
6961 gbt=1.d0-exp(vtac(it)+(1.d0-nptg0)*dlog(2.d0))
6962 * /(1.d0-vvxt)/(1.d0-vvxtl)
6963 * *(vpac(ip)+vplc)*exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
6964 * /((vpac0(ip)+vplc0)*exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
6965 * -(vpac(ip)+vplc-vpac0(ip)-vplc0)
6966 * *(1.d0-exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)))
6967 endif
6968 if(qgran(b10).gt.gbt)goto 2
6969
6970
6971
6972
6973
6974
6975
6976 if(jt.eq.7.or.jt.eq.9.or.jt.eq.11.or.jt.eq.12)then
6977 nptg0=1
6978 iptg0(1)=it
6979 endif
6980 if(jt.eq.8.or.jt.eq.10.or.jt.eq.11.or.jt.eq.12)then
6981 nppr0=1
6982 ippr0(1)=ip
6983 endif
6984
6985 if(jt.eq.8.and.nptgh0.lt.nptg0.or.jt.eq.10)then !'fan' from cut vertex
6986 vpacng=min(vpac0(ip)
6987 * ,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp0,vvxpl,iddp(ip),icz,4))
6988
6989 factor=exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
6990 wng=(vpacng+vplcng)*factor
6991 wgap=max(0.d0,(vpac0(ip)+vplc0)*factor
6992 * -(vpac(ip)+vplc-vpac0(ip)-vplc0)*(1.d0-factor)-wng)
6993 if(qgran(b10).ge.wgap/(wgap+wng).or.xpomr*sgap**2.gt..9d0)then
6994 if(qgran(b10).lt.vpacng/(vpacng+vplcng)
6995 * .and.xpomr*sgap**2.lt..9d0)then
6996 itypr0(1)=2 !cut 'fan' (no gap at the end)
6997 else
6998 itypr0(1)=4 !cut 'leg' (no gap at the end)
6999 endif
7000 else
7001 wfg=max(0.d0,(vpac0(ip)-vpacng)*factor
7002 * -(vpac(ip)-vpac0(ip))*(1.d0-factor))
7003 wlg=max(0.d0,(vplc0-vplcng)*factor-(vplc-vplc0)*(1.d0-factor))
7004 if(qgran(b10).lt.wfg/(wfg+wlg))then
7005 itypr0(1)=3 !cut 'fan' (gap at the end)
7006 else
7007 itypr0(1)=5 !cut 'leg' (gap at the end)
7008 endif
7009 wgpr0=(1.d0-factor)/factor
7010 endif
7011
7012 elseif(jt.eq.8.and.nptgh0.eq.nptg0)then !'fan' from cut/uncut vertex
7013 vpacng=min(vpac0(ip)
7014 * ,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp0,vvxpl,iddp(ip),icz,4))
7015
7016 factor=exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
7017 wng=(vpacng+vplcng)*factor*(1.d0-exp(vtac(it)
7018 * +(1.d0-nptg0)*dlog(2.d0))/(1.d0-vvxt)/(1.d0-vvxtl))
7019 wgap=max(0.d0,(vpac0(ip)+vplc0)*factor
7020 * -(vpac(ip)+vplc-vpac0(ip)-vplc0)*(1.d0-factor)
7021 * -exp(vtac(it)+(1.d0-nptg0)*dlog(2.d0))/(1.d0-vvxt)/(1.d0-vvxtl)
7022 * *(vpac(ip)+vplc)*factor-wng)
7023 if(qgran(b10).ge.wgap/(wgap+wng).or.xpomr*sgap**2.gt..9d0)then
7024 if(qgran(b10).lt.vpacng/(vpacng+vplcng)
7025 * .and.xpomr*sgap**2.lt..9d0)then
7026 itypr0(1)=2 !cut 'fan' (no gap at the end)
7027 else
7028 itypr0(1)=4 !cut 'leg' (no gap at the end)
7029 endif
7030 else
7031 wfg=max(0.d0,(vpac0(ip)-vpacng)*factor
7032 * -(vpac(ip)-vpac0(ip))*(1.d0-factor)
7033 * -exp(vtac(it)+(1.d0-nptg0)*dlog(2.d0))
7034 * /(1.d0-vvxt)/(1.d0-vvxtl)*(vpac(ip)-vpacng)*factor)
7035 wlg=max(0.d0,(vplc0-vplcng)*factor-(vplc-vplc0)*(1.d0-factor)
7036 * -exp(vtac(it)+(1.d0-nptg0)*dlog(2.d0))
7037 * /(1.d0-vvxt)/(1.d0-vvxtl)*(vplc-vplcng)*factor)
7038 if(qgran(b10).lt.wfg/(wfg+wlg))then
7039 itypr0(1)=3 !cut 'fan' (gap at the end)
7040 else
7041 itypr0(1)=5 !cut 'leg' (gap at the end)
7042 endif
7043 wgpr0=1.d0/factor/(1.d0-exp(vtac(it)+(1.d0-nptg0)*dlog(2.d0))
7044 * /(1.d0-vvxt)/(1.d0-vvxtl))-1.d0
7045 endif
7046
7047 elseif(jt.eq.11)then
7048 itypr0(1)=6
7049 elseif(jt.eq.12)then
7050 factor=exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
7051 wng=max(0.d0,vplcng-vplcpe)*factor
7052 * /((vplc0-vplcpe)*factor-(vplc-vplc0)*(1.d0-factor))
7053 if(qgran(b10).le.wng)then
7054 itypr0(1)=7 !cut 'leg' (>1 cut Poms at the end)
7055 else
7056 itypr0(1)=5 !cut 'leg' (gap at the end)
7057 wgpr0=(1.d0-factor)/factor
7058 endif
7059 endif
7060
7061 if(jt.eq.7.and.npprh0.lt.nppr0.or.jt.eq.9)then !'fan' from cut vertex
7062 vtacng=min(vtac0(it)
7063 * ,qgfani(xpomr*scm,bbtg,vvxps,vvxt0,vvxtl,iddt(it),2,4))
7064
7065 factor=exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
7066 wng=(vtacng+vtlcng)*factor
7067 wgap=max(0.d0,(vtac0(it)+vtlc0)*factor
7068 * -(vtac(it)+vtlc-vtac0(it)-vtlc0)*(1.d0-factor)-wng)
7069 if(qgran(b10).ge.wgap/(wgap+wng)
7070 * .or.xpomr*scm.lt.1.1d0*sgap**2)then
7071 if(qgran(b10).lt.vtacng/(vtacng+vtlcng)
7072 * .and.xpomr*scm.gt.1.1d0*sgap**2)then
7073 itytg0(1)=2 !cut 'fan' (no gap at the end)
7074 else
7075 itytg0(1)=4 !cut 'leg' (no gap at the end)
7076 endif
7077 else
7078 wfg=max(0.d0,(vtac0(it)-vtacng)*factor
7079 * -(vtac(it)-vtac0(it))*(1.d0-factor))
7080 wlg=max(0.d0,(vtlc0-vtlcng)*factor-(vtlc-vtlc0)*(1.d0-factor))
7081 if(qgran(b10).lt.wfg/(wfg+wlg))then
7082 itytg0(1)=3 !cut 'fan' (gap at the end)
7083 else
7084 itytg0(1)=5 !cut 'leg' (gap at the end)
7085 endif
7086 wgtg0=(1.d0-factor)/factor
7087 endif
7088
7089 elseif(jt.eq.7.and.npprh0.eq.nppr0)then !'fan' from cut/uncut vertex
7090 vtacng=min(vtac0(it)
7091 * ,qgfani(xpomr*scm,bbtg,vvxps,vvxt0,vvxtl,iddt(it),2,4))
7092
7093 factor=exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
7094 wng=(vtacng+vtlcng)*factor*(1.d0-exp(vpac(ip)
7095 * +(1.d0-nppr0)*dlog(2.d0))/(1.d0-vvxp)/(1.d0-vvxpl))
7096 wgap=max(0.d0,(vtac0(it)+vtlc0)*factor
7097 * -(vtac(it)+vtlc-vtac0(it)-vtlc0)*(1.d0-factor)
7098 * -exp(vpac(ip)+(1.d0-nppr0)*dlog(2.d0))/(1.d0-vvxp)/(1.d0-vvxpl)
7099 * *(vtac(it)+vtlc)*factor-wng)
7100 if(qgran(b10).ge.wgap/(wgap+wng)
7101 * .or.xpomr*scm.lt.1.1d0*sgap**2)then
7102 if(qgran(b10).lt.vtacng/(vtacng+vtlcng)
7103 * .and.xpomr*scm.gt.1.1d0*sgap**2)then
7104 itytg0(1)=2 !cut 'fan' (no gap at the end)
7105 else
7106 itytg0(1)=4 !cut 'leg' (no gap at the end)
7107 endif
7108 else
7109 wfg=max(0.d0,(vtac0(it)-vtacng)*factor
7110 * -(vtac(it)-vtac0(it))*(1.d0-factor)
7111 * -exp(vpac(ip)+(1.d0-nppr0)*dlog(2.d0))
7112 * /(1.d0-vvxp)/(1.d0-vvxpl)*(vtac(it)-vtacng)*factor)
7113 wlg=max(0.d0,(vtlc0-vtlcng)*factor-(vtlc-vtlc0)*(1.d0-factor)
7114 * -exp(vpac(ip)+(1.d0-nppr0)*dlog(2.d0))
7115 * /(1.d0-vvxp)/(1.d0-vvxpl)*(vtlc-vtlcng)*factor)
7116 if(qgran(b10).lt.wfg/(wfg+wlg))then
7117 itytg0(1)=3 !cut 'fan' (gap at the end)
7118 else
7119 itytg0(1)=5 !cut 'leg' (gap at the end)
7120 endif
7121 wgtg0=1.d0/factor/(1.d0-exp(vpac(ip)+(1.d0-nppr0)*dlog(2.d0))
7122 * /(1.d0-vvxp)/(1.d0-vvxpl))-1.d0
7123 endif
7124
7125 elseif(jt.eq.12)then
7126 itytg0(1)=6
7127 elseif(jt.eq.11)then
7128 factor=exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
7129 wng=max(0.d0,vtlcng-vtlcpe)*factor
7130 * /((vtlc0-vtlcpe)*factor-(vtlc-vtlc0)*(1.d0-factor))
7131 if(qgran(b10).le.wng)then
7132 itytg0(1)=7 !cut 'leg' (>1 cut Poms at the end)
7133 else
7134 itytg0(1)=5 !cut 'leg' (gap at the end)
7135 wgtg0=(1.d0-factor)/factor
7136 endif
7137 endif
7138 if(debug.ge.3)write (moniou,206)nppr0,nptg0
7139
7140 nppr=0
7141 nptg=0
7142 npin=0
7143
7144 if(nppr0.eq.1.and.itypr0(1).eq.6)then !single cut Pomeron
7145 nppr=1
7146 xpompi(nppr)=xpomr
7147 vvxpi(nppr)=1.d0-(1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxt)
7148 * *exp(-vtac(it))
7149 ipompi(nppr)=ip
7150 bpompi(nppr)=bbpr
7151 if(debug.ge.4)write (moniou,209)nppr,ip,bbpr,xpompi(nppr)
7152 * ,vvxpi(nppr)
7153 nppr0=0
7154 endif
7155 if(nptg0.eq.1.and.itytg0(1).eq.6)then !single cut Pomeron
7156 nptg=1
7157 xpomti(nptg)=xpomr
7158 vvxti(nptg)=1.d0-(1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxt)
7159 * *exp(-vpac(ip))
7160 ipomti(nptg)=it
7161 bpomti(nptg)=bbtg
7162 if(debug.ge.4)write (moniou,217)nptg,it,bbtg,xpomti(nptg)
7163 * ,vvxti(nptg)
7164 nptg0=0
7165 endif
7166
7167 vvxps=vvxp
7168 vvxpls=vvxpl
7169 vvxp0s=vvxp0
7170 if(nppr0.ne.0)then
7171 i=0
7172 7 i=i+1
7173 ityp=itypr0(i)
7174 if(ityp.eq.0.or.ityp.eq.2.or.ityp.eq.4)then
7175 ipp=ippr0(i)
7176 bbp=(xa(ipp,1)+b-xxp)**2+(xa(ipp,2)-yyp)**2
7177 vvxp=0.d0
7178 vvxpl=0.d0
7179 vvxp0=0.d0
7180 if(ia(1).gt.1)then
7181 do l=1,ia(1)
7182 if(l.lt.ipp)then
7183 vvxpl=vvxpl+vpac(l)
7184 elseif(l.gt.ipp)then
7185 vvxp=vvxp+vpac(l)
7186 vvxp0=vvxp0+vpac0(l)
7187 endif
7188 enddo
7189 endif
7190 vvxp=1.d0-exp(-vvxp)
7191 vvxpl=1.d0-exp(-vvxpl)
7192 vvxp0=1.d0-exp(-vvxp0)
7193 vvxts=1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*(1.d0-vvxpl)*exp(-vtac(it))
7194 if(ityp.ne.4)then
7195 vpacng=min(vpac0(ipp)
7196 * ,qgfani(1.d0/xpomr,bbp,vvxts,vvxp0,vvxpl,iddp(ipp),icz,4))
7197 vpacpe=min(vpacng
7198 * ,qgfani(1.d0/xpomr,bbp,vvxts,vvxp0,vvxpl,iddp(ipp),icz,5))
7199 vplcp=min(vpacpe
7200 * ,qgfani(1.d0/xpomr,bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,9))
7201 else
7202 vplcng=min(vpac0(ipp)
7203 * ,qgfani(1.d0/xpomr,bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,11))
7204 vplcpe=min(vplcng
7205 * ,qgfani(1.d0/xpomr,bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,10))
7206 vplcp=min(vplcpe
7207 * ,qgfani(1.d0/xpomr,bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,9))
7208 endif
7209
7210 if(ityp.eq.0)then
7211 aks=qgran(b10)*vpac0(ipp)
7212 if(aks.le.vplcp.or.xpomr*sgap**2.gt..9d0)then
7213 itypr0(i)=6 !single cut Pomeron
7214 elseif(aks.lt.vpacpe)then
7215 itypr0(i)=-1 !'fan' (cut Pomeron end)
7216 elseif(aks.lt.vpacng)then
7217 itypr0(i)=2 !'fan' (>1 cut Poms at the end)
7218 endif
7219 elseif(ityp.eq.2)then
7220 aks=qgran(b10)*vpacng
7221 if(aks.le.vplcp.or.xpomr*sgap**2.gt..9d0)then
7222 itypr0(i)=6 !single cut Pomeron
7223 elseif(aks.lt.vpacpe)then
7224 itypr0(i)=-1 !'fan' (cut Pomeron end)
7225 endif
7226 elseif(ityp.eq.4)then
7227 aks=qgran(b10)*vplcng
7228 if(aks.le.vplcp.or.xpomr*sgap**2.gt..9d0)then
7229 itypr0(i)=6 !single cut Pomeron
7230 elseif(aks.gt.vplcpe.or.xpomr*sgap**3.gt..9d0)then
7231 itypr0(i)=7 !'leg' (>1 cut Poms at the end)
7232 endif
7233 endif
7234
7235 if(itypr0(i).eq.6)then !single cut Pomeron
7236 nppr=nppr+1
7237 xpompi(nppr)=xpomr
7238 vvxpi(nppr)=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*(1.d0-vvxt)
7239 * *(1.d0-vvxtl)*exp(-vtac(it))
7240 ipompi(nppr)=ipp
7241 bpompi(nppr)=bbp
7242 if(debug.ge.4)write (moniou,209)nppr,ipp,bbp,xpompi(nppr)
7243 * ,vvxpi(nppr)
7244 nppr0=nppr0-1
7245 if(nppr0.ge.i)then
7246 do l=i,nppr0
7247 ippr0(l)=ippr0(l+1)
7248 itypr0(l)=itypr0(l+1)
7249 enddo
7250 endif
7251 i=i-1
7252 endif
7253 endif
7254 if(i.lt.nppr0)goto 7
7255 endif
7256
7257 vvxp=vvxps
7258 vvxpl=vvxpls
7259 vvxp0=vvxp0s
7260 vvxts=vvxt
7261 vvxtls=vvxtl
7262 vvxt0s=vvxt0
7263 if(nptg0.ne.0)then
7264 i=0
7265 8 i=i+1
7266 ityt=itytg0(i)
7267 if(ityt.eq.0.or.ityt.eq.2.or.ityt.eq.4)then
7268 itt=iptg0(i)
7269 bbt=(xb(itt,1)-xxp)**2+(xb(itt,2)-yyp)**2
7270 vvxt=0.d0
7271 vvxtl=0.d0
7272 vvxt0=0.d0
7273 if(ia(2).gt.1)then
7274 do l=1,ia(2)
7275 if(l.lt.itt)then
7276 vvxtl=vvxtl+vtac(l)
7277 elseif(l.gt.itt)then
7278 vvxt=vvxt+vtac(l)
7279 vvxt0=vvxt0+vtac0(l)
7280 endif
7281 enddo
7282 endif
7283 vvxt=1.d0-exp(-vvxt)
7284 vvxtl=1.d0-exp(-vvxtl)
7285 vvxt0=1.d0-exp(-vvxt0)
7286 vvxps=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*(1.d0-vvxtl)*exp(-vpac(ip))
7287 if(ityt.ne.4)then
7288 vtacng=min(vtac0(itt)
7289 * ,qgfani(xpomr*scm,bbt,vvxps,vvxt0,vvxtl,iddt(itt),2,4))
7290 vtacpe=min(vtacng
7291 * ,qgfani(xpomr*scm,bbt,vvxps,vvxt0,vvxtl,iddt(itt),2,5))
7292 vtlcp=min(vtacpe
7293 * ,qgfani(xpomr*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,9))
7294 else
7295 vtlcng=min(vtac0(itt)
7296 * ,qgfani(xpomr*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,11))
7297 vtlcpe=min(vtlcng
7298 * ,qgfani(xpomr*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,10))
7299 vtlcp=min(vtlcpe
7300 * ,qgfani(xpomr*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,9))
7301 endif
7302
7303 if(ityt.eq.0)then
7304 aks=qgran(b10)*vtac0(itt)
7305 if(aks.le.vtlcp.or.xpomr*scm.lt.1.1d0*sgap**2)then
7306 itytg0(i)=6 !single cut Pomeron
7307 elseif(aks.lt.vtacpe)then
7308 itytg0(i)=-1 !'fan' (cut Pomeron end)
7309 elseif(aks.lt.vtacng)then
7310 itytg0(i)=2 !'fan' (>1 cut Poms at the end)
7311 endif
7312 elseif(ityt.eq.2)then
7313 aks=qgran(b10)*vtacng
7314 if(aks.le.vtlcp.or.xpomr*scm.lt.1.1d0*sgap**2)then
7315 itytg0(i)=6 !single cut Pomeron
7316 elseif(aks.lt.vtacpe)then
7317 itytg0(i)=-1 !'fan' (cut Pomeron end)
7318 endif
7319 elseif(ityt.eq.4)then
7320 aks=qgran(b10)*vtlcng
7321 if(aks.le.vtlcp.or.xpomr*scm.lt.1.1d0*sgap**2)then
7322 itytg0(i)=6
7323 elseif(aks.gt.vtlcpe.or.xpomr*scm.lt.1.1d0*sgap**3)then
7324 itytg0(i)=7 !'leg' (>1 cut Poms at the end)
7325 endif
7326 endif
7327
7328 if(itytg0(i).eq.6)then !single cut Pomeron
7329 nptg=nptg+1
7330 xpomti(nptg)=xpomr
7331 vvxti(nptg)=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*(1.d0-vvxt)
7332 * *(1.d0-vvxtl)*exp(-vpac(ip))
7333 ipomti(nptg)=itt
7334 bpomti(nptg)=bbt
7335 if(debug.ge.4)write (moniou,217)nptg,itt,bbt,xpomti(nptg)
7336 * ,vvxti(nptg)
7337 nptg0=nptg0-1
7338 if(nptg0.ge.i)then
7339 do l=i,nptg0
7340 iptg0(l)=iptg0(l+1)
7341 itytg0(l)=itytg0(l+1)
7342 enddo
7343 endif
7344 i=i-1
7345 endif
7346 endif
7347 if(i.lt.nptg0)goto 8
7348 endif
7349 vvxt=vvxts
7350 vvxtl=vvxtls
7351 vvxt0=vvxt0s
7352
7353 if((jt-1)*(jt-4)*(jt-7).eq.0.and.xpomr*sgap**2.lt..9d0)then
7354 vvxts=1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
7355 vvxt0s=1.d0-(1.d0-vvxt0)*(1.d0-vvxt0l)*exp(-vtac0(it))
7356 vvxs=((1.d0-vvxp)*(1.d0-vvxpl))**2*exp(-2.d0*vpac(ip))
7357 vvx0s=((1.d0-vvxp0)*(1.d0-vvxp0l))**2*exp(-2.d0*vpac0(ip))
7358
7359 wzzp=2.d0*qgrevi(1.d0/xpomr,bbpr,vvxt0s,vvxts
7360 * ,vvxpt,vvxp0,vvxpl,iddp(ip),icz)
7361 * *((1.d0-exp(-vtact(it)))*(1.d0-vvxtt)*(1.d0-vvxs)
7362 * +vvxs*(max(0.d0,1.d0-exp(-vtact(it))*(1.d0+vtact(it)))
7363 * *(1.d0-vvxtt)
7364 * -max(0.d0,1.d0-exp(-vtac0(it))*(1.d0+vtac0(it)))*(1.d0-vvxt0))
7365 * +vtact(it)*exp(-vtact(it))*((1.d0-vvxtt)*vvxs
7366 * -exp(vtact(it)-vtac0(it))*(1.d0-vvxt0)*(1.d0-vvxt0l)*vvx0s)
7367 * -vtac0(it)*exp(-vtac0(it))*(1.d0-vvxt0)
7368 * *(vvxs-vvx0s+vvxt0l*vvx0s))
7369 wzzp=max(0.d0,wzzp)
7370 nzzp=npgen(wzzp/(vv(1)+vv(4)+vv(7)),0,50)
7371 else
7372 nzzp=0
7373 endif
7374
7375 if((jt-1)*(jt-3)*(jt-8).eq.0.and.xpomr*scm.gt.1.1d0*sgap**2)then
7376 vvxps=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
7377 vvxp0s=1.d0-(1.d0-vvxp0)*(1.d0-vvxp0l)*exp(-vpac0(ip))
7378 vvxs=((1.d0-vvxt)*(1.d0-vvxtl))**2*exp(-2.d0*vtac(it))
7379 vvx0s=((1.d0-vvxt0)*(1.d0-vvxt0l))**2*exp(-2.d0*vtac0(it))
7380 wzzt=2.d0*qgrevi(xpomr*scm,bbtg,vvxp0s,vvxps
7381 * ,vvxtt,vvxt0,vvxtl,iddt(it),2)
7382 * *((1.d0-exp(-vpact(ip)))*(1.d0-vvxpt)*(1.d0-vvxs)
7383 * +vvxs*(max(0.d0,1.d0-exp(-vpact(ip))*(1.d0+vpact(ip)))
7384 * *(1.d0-vvxpt)
7385 * -max(0.d0,1.d0-exp(-vpac0(ip))*(1.d0+vpac0(ip)))*(1.d0-vvxp0))
7386 * +vpact(ip)*exp(-vpact(ip))*((1.d0-vvxpt)*vvxs
7387 * -exp(vpact(ip)-vpac0(ip))*(1.d0-vvxp0)*(1.d0-vvxp0l)*vvx0s)
7388 * -vpac0(ip)*exp(-vpac0(ip))*(1.d0-vvxp0)
7389 * *(vvxs-vvx0s+vvxp0l*vvx0s))
7390 wzzt=max(0.d0,wzzt)
7391 nzzt=npgen(wzzt/(vv(1)+vv(3)+vv(8)),0,50)
7392 else
7393 nzzt=0
7394 endif
7395
7396 if(nzzp.ne.0)then
7397 bpm=(xa(ip,1)+b-xxp)**2+(xa(ip,2)-yyp)**2
7398 xpomr0=min(dsqrt(xpomr),1.d0/sgap)
7399 xpomr0=max(xpomr0,xpomr*sgap)
7400 rp1=(rq(iddp(ip),icz)-alfp*dlog(xpomr0))*4.d0*.0389d0
7401 rp2=alfp*dlog(xpomr0/xpomr)*4.d0*.0389d0
7402 rp0=rp1*rp2/(rp1+rp2)
7403 bbp=bpm*(rp1/(rp1+rp2))**2
7404 bbi=bpm*(rp2/(rp1+rp2))**2
7405 call qgbdef(bbp,bbi,xa(ip,1)+b,xa(ip,2),xxp,yyp,xxp0,yyp0,1)
7406 call qgfdf(xxp0,yyp0,xpomr0,vpac,vtac,vvx,vvxp,vvxt
7407 * ,vvxpl,vvxtl,ip,it)
7408
7409 sumcp0=0.d0
7410 sumcpt=0.d0
7411 sumup=0.d0
7412 vvxp0=0.d0
7413 vvxp0l=0.d0
7414 do i=1,ia(1)
7415 sumup=sumup+vpac(i)
7416 enddo
7417 vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
7418 do i=1,ia(1)
7419 ipp=ia(1)-i+1
7420 bbpi=(xa(ipp,1)+b-xxp0)**2+(xa(ipp,2)-yyp0)**2
7421 sumup=sumup-vpac(ipp)
7422 vpac0(ipp)=min(vpac(ipp)
7423 * ,qgfani(1.d0/xpomr0,bbpi,1.d0-vvxs*exp(-sumup)
7424 * ,1.d0-exp(-sumcp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
7425 if(ipp.ge.ip)vpact(ipp)=max(vpac(ipp)
7426 * ,qgfani(1.d0/xpomr0,bbpi,1.d0-vvxs*exp(-sumup)
7427 * ,1.d0-exp(-sumcpt),1.d0-exp(-sumup),iddp(ipp),icz,6))
7428 if(ipp.gt.ip)then
7429 vvxp0=vvxp0+vpac0(ipp)
7430 sumcpt=sumcpt+vpact(ipp)
7431 elseif(ipp.lt.ip)then
7432 vvxp0l=vvxp0l+vpac0(ipp)
7433 endif
7434 sumcp0=sumcp0+vpac0(ipp)
7435 enddo
7436 vvxpt=1.d0-exp(-sumcpt)
7437 vvxp0=1.d0-exp(-vvxp0)
7438 vvxp0l=1.d0-exp(-vvxp0l)
7439
7440 sumut=0.d0
7441 sumct0=0.d0
7442 vvxt0=0.d0
7443 vvxt0l=0.d0
7444 do i=1,ia(2)
7445 sumut=sumut+vtac(i)
7446 enddo
7447 vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
7448 do i=1,ia(2)
7449 itt=ia(2)-i+1
7450 bbti=(xb(itt,1)-xxp0)**2+(xb(itt,2)-yyp0)**2
7451 sumut=sumut-vtac(itt)
7452 vtac0(itt)=min(vtac(itt)
7453 * ,qgfani(xpomr0*scm,bbti,1.d0-vvxs*exp(-sumut)
7454 * ,1.d0-exp(-sumct0),1.d0-exp(-sumut),iddt(itt),2,3))
7455 if(itt.gt.it)then
7456 vvxt0=vvxt0+vtac0(itt)
7457 elseif(itt.lt.it)then
7458 vvxt0l=vvxt0l+vtac0(itt)
7459 endif
7460 sumct0=sumct0+vtac0(itt)
7461 enddo
7462 vvxt0=1.d0-exp(-vvxt0)
7463 vvxt0l=1.d0-exp(-vvxt0l)
7464
7465 viu=qgpini(xpomr0/xpomr,bbi,0.d0,0.d0,2)
7466 vim=2.d0*min(viu,qgpini(xpomr0/xpomr,bbi,0.d0,0.d0,8))
7467 vvxpin=1.d0-(1.d0-vvxp0)*(1.d0-vvxp0l)*exp(-vpac0(ip))
7468 vvxtin=1.d0-(1.d0-vvxt0)*(1.d0-vvxt0l)*exp(-vtac0(it))
7469 vi=qgpini(xpomr0/xpomr,bbi,vvxpin,vvxtin,21)*(1.d0-exp(-viu))
7470 * -qgpini(xpomr0/xpomr,bbi,vvxpin,vvxtin,23)*((1.d0-exp(-viu))**2
7471 * +(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))/2.d0
7472
7473 vvx0s=(1.d0-vvxtin)**2
7474 vvxs=((1.d0-vvxt)*(1.d0-vvxtl))**2*exp(-2.d0*vtac(it))
7475
7476 gb0=vi *15.
7477 * *((1.d0-exp(-vpact(ip)))*(1.d0-vvxpt)*(1.d0-vvxs)
7478 * +vvxs*(max(0.d0,1.d0-exp(-vpact(ip))*(1.d0+vpact(ip)))
7479 * *(1.d0-vvxpt)
7480 * -max(0.d0,1.d0-exp(-vpac0(ip))*(1.d0+vpac0(ip)))*(1.d0-vvxp0))
7481 * +vpact(ip)*exp(-vpact(ip))*((1.d0-vvxpt)*vvxs
7482 * -exp(vpact(ip)-vpac0(ip))*(1.d0-vvxp0)*(1.d0-vvxp0l)*vvx0s)
7483 * -vpac0(ip)*exp(-vpac0(ip))*(1.d0-vvxp0)
7484 * *(vvxs-vvx0s+vvxp0l*vvx0s))
7485
7486 do in=1,nzzp
7487 nrej=0
7488 32 xpomri=(xpomr*sgap**2)**qgran(b10)/sgap
7489 rp1=(rq(iddp(ip),icz)-alfp*dlog(xpomri))*4.d0*.0389d0
7490 rp2=alfp*dlog(xpomri/xpomr)*4.d0*.0389d0
7491 rp=rp1*rp2/(rp1+rp2)
7492 z=qgran(b10)
7493 phi=pi*qgran(b10)
7494 b0=dsqrt(-rp*dlog(z))
7495 bbp=(dsqrt(bpm)*rp1/(rp1+rp2)+b0*cos(phi))**2+(b0*sin(phi))**2
7496 bbi=(dsqrt(bpm)*rp2/(rp1+rp2)-b0*cos(phi))**2+(b0*sin(phi))**2
7497 call qgbdef(bbp,bbi,xa(ip,1)+b,xa(ip,2),xxp,yyp
7498 * ,xxi,yyi,int(1.5d0+qgran(b10))) !coordinates for the vertex
7499 call qgfdf(xxi,yyi,xpomri,vpac,vtac
7500 * ,vvx,vvxp,vvxt,vvxpl,vvxtl,ip,it)
7501
7502 sumcp0=0.d0
7503 sumcpt=0.d0
7504 sumup=0.d0
7505 vvxp0=0.d0
7506 vvxp0l=0.d0
7507 do i=1,ia(1)
7508 sumup=sumup+vpac(i)
7509 enddo
7510 vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
7511 do i=1,ia(1)
7512 ipp=ia(1)-i+1
7513 bbpi=(xa(ipp,1)+b-xxi)**2+(xa(ipp,2)-yyi)**2
7514 sumup=sumup-vpac(ipp)
7515 vpac0(ipp)=min(vpac(ipp)
7516 * ,qgfani(1.d0/xpomri,bbpi,1.d0-vvxs*exp(-sumup)
7517 * ,1.d0-exp(-sumcp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
7518 if(ipp.ge.ip)vpact(ipp)=max(vpac(ipp)
7519 * ,qgfani(1.d0/xpomri,bbpi,1.d0-vvxs*exp(-sumup)
7520 * ,1.d0-exp(-sumcpt),1.d0-exp(-sumup),iddp(ipp),icz,6))
7521 if(ipp.gt.ip)then
7522 vvxp0=vvxp0+vpac0(ipp)
7523 sumcpt=sumcpt+vpact(ipp)
7524 elseif(ipp.lt.ip)then
7525 vvxp0l=vvxp0l+vpac0(ipp)
7526 endif
7527 sumcp0=sumcp0+vpac0(ipp)
7528 enddo
7529 vvxpt=1.d0-exp(-sumcpt)
7530 vvxp0=1.d0-exp(-vvxp0)
7531 vvxp0l=1.d0-exp(-vvxp0l)
7532
7533 sumut=0.d0
7534 sumct0=0.d0
7535 vvxt0=0.d0
7536 vvxt0l=0.d0
7537 do i=1,ia(2)
7538 sumut=sumut+vtac(i)
7539 enddo
7540 vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
7541 do i=1,ia(2)
7542 itt=ia(2)-i+1
7543 bbti=(xb(itt,1)-xxi)**2+(xb(itt,2)-yyi)**2
7544 sumut=sumut-vtac(itt)
7545 vtac0(itt)=min(vtac(itt)
7546 * ,qgfani(xpomri*scm,bbti,1.d0-vvxs*exp(-sumut)
7547 * ,1.d0-exp(-sumct0),1.d0-exp(-sumut),iddt(itt),2,3))
7548 if(itt.gt.it)then
7549 vvxt0=vvxt0+vtac0(itt)
7550 elseif(itt.lt.it)then
7551 vvxt0l=vvxt0l+vtac0(itt)
7552 endif
7553 sumct0=sumct0+vtac0(itt)
7554 enddo
7555 vvxt0=1.d0-exp(-vvxt0)
7556 vvxt0l=1.d0-exp(-vvxt0l)
7557
7558 viu=qgpini(xpomri/xpomr,bbi,0.d0,0.d0,2)
7559 vim=2.d0*min(viu,qgpini(xpomri/xpomr,bbi,0.d0,0.d0,8))
7560 vvxpin=1.d0-(1.d0-vvxp0)*(1.d0-vvxp0l)*exp(-vpac0(ip))
7561 vvxtin=1.d0-(1.d0-vvxt0)*(1.d0-vvxt0l)*exp(-vtac0(it))
7562 vi=qgpini(xpomri/xpomr,bbi,vvxpin,vvxtin,21)*(1.d0-exp(-viu))
7563 * -qgpini(xpomri/xpomr,bbi,vvxpin,vvxtin,23)*((1.d0-exp(-viu))**2
7564 * +(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))/2.d0
7565
7566 vvx0s=(1.d0-vvxtin)**2
7567 vvxs=((1.d0-vvxt)*(1.d0-vvxtl))**2*exp(-2.d0*vtac(it))
7568
7569 gb=vi
7570 * *((1.d0-exp(-vpact(ip)))*(1.d0-vvxpt)*(1.d0-vvxs)
7571 * +vvxs*(max(0.d0,1.d0-exp(-vpact(ip))*(1.d0+vpact(ip)))
7572 * *(1.d0-vvxpt)
7573 * -max(0.d0,1.d0-exp(-vpac0(ip))*(1.d0+vpac0(ip)))*(1.d0-vvxp0))
7574 * +vpact(ip)*exp(-vpact(ip))*((1.d0-vvxpt)*vvxs
7575 * -exp(vpact(ip)-vpac0(ip))*(1.d0-vvxp0)*(1.d0-vvxp0l)*vvx0s)
7576 * -vpac0(ip)*exp(-vpac0(ip))*(1.d0-vvxp0)
7577 * *(vvxs-vvx0s+vvxp0l*vvx0s))
7578
7579 gb=gb/gb0/z*rp/rp0
7580 nrej=nrej+1
7581 if(qgran(b10).gt.gb.and.nrej.lt.10000)goto 32
7582
7583 vi1p=qgpini(xpomri/xpomr,bbi,1.d0-(1.d0-vvxpin)**2*vvx0s
7584 * ,0.d0,16)*exp(-vim)
7585 vimp=max(0.d0,(1.d0-exp(-vim)*(1.d0+vim)))/2.d0
7586
7587 if(qgran(b10).le.(vi1p+vimp)/vi
7588 * .or.xpomri/xpomr.lt.1.1d0*sgap**2)then
7589 if(qgran(b10).le.vi1p/(vi1p+vimp))then !single cut Pomeron
7590 npin=npin+1
7591 if(npin.gt.npmax)then
7592 iret=1
7593 goto 31
7594 endif
7595 xpomim(npin)=1.d0/xpomr/scm
7596 xpomip(npin)=xpomri
7597 vvxim(npin)=1.d0-(1.d0-vvxpin)**2*vvx0s
7598 bpomim(npin)=bbi
7599 if(debug.ge.4)write (moniou,211)npin,xpomip(npin)
7600 * ,xpomim(npin),vvxim(npin),bpomim(npin)
7601 else !more than 1 cut Pomeron
7602 ninc=npgen(vim,2,20)
7603 npin=npin+ninc
7604 if(npin.gt.npmax)then
7605 iret=1
7606 goto 31
7607 endif
7608 do i=npin-ninc+1,npin
7609 xpomim(i)=1.d0/xpomr/scm
7610 xpomip(i)=xpomri
7611 vvxim(i)=0.d0
7612 bpomim(i)=bbi
7613 if(debug.ge.4)write (moniou,211)i,xpomip(i),xpomim(i)
7614 * ,vvxim(i),bpomim(i)
7615 enddo
7616 endif
7617
7618 else !additional vertices
7619 xpomz0=dsqrt(xpomr*xpomri)
7620 rp0=alfp*dlog(xpomri/xpomr)*.0389d0
7621 xxz0=.5d0*(xxp+xxi)
7622 yyz0=.5d0*(yyp+yyi)
7623 bbzp=.25d0*bbi
7624 bbzt=bbzp
7625 call qgfdf(xxz0,yyz0,xpomz0,vpac,vtac,vvx,vvxp,vvxt
7626 * ,vvxpl,vvxtl,ip,it)
7627
7628 vvxp0=0.d0
7629 sumup=0.d0
7630 do i=1,ia(1)
7631 sumup=sumup+vpac(i)
7632 enddo
7633 vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
7634 do i=1,ia(1)
7635 ipp=ia(1)-i+1
7636 bbpi=(xa(ipp,1)+b-xxz0)**2+(xa(ipp,2)-yyz0)**2
7637 sumup=sumup-vpac(ipp)
7638 vpac0(ipp)=min(vpac(ipp)
7639 * ,qgfani(1.d0/xpomz0,bbpi,1.d0-vvxs*exp(-sumup)
7640 * ,1.d0-exp(-vvxp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
7641 vvxp0=vvxp0+vpac0(ipp)
7642 enddo
7643 vvxp0=1.d0-exp(-vvxp0)
7644
7645 sumut=0.d0
7646 vvxt0=0.d0
7647 do i=1,ia(2)
7648 sumut=sumut+vtac(i)
7649 enddo
7650 vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
7651 do i=1,ia(2)
7652 itt=ia(2)-i+1
7653 bbti=(xb(itt,1)-xxz0)**2+(xb(itt,2)-yyz0)**2
7654 sumut=sumut-vtac(itt)
7655 vtac0(itt)=min(vtac(itt)
7656 * ,qgfani(xpomz0*scm,bbti,1.d0-vvxs*exp(-sumut)
7657 * ,1.d0-exp(-vvxt0),1.d0-exp(-sumut),iddt(itt),2,3))
7658 vvxt0=vvxt0+vtac0(itt)
7659 enddo
7660 vvxt0=1.d0-exp(-vvxt0)
7661
7662 viu=qgpini(xpomri/xpomz0,bbzp,0.d0,0.d0,2)
7663 vilu=1.d0-exp(-viu)
7664 vimu=2.d0*min(viu,qgpini(xpomri/xpomz0,bbzp,0.d0,0.d0,8))
7665 vimpu=max(0.d0,(1.d0-exp(-vimu)*(1.d0+vimu)))/2.d0
7666 vid=qgpini(xpomz0/xpomr,bbzt,0.d0,0.d0,2)
7667 vild=1.d0-exp(-vid)
7668 vimd=2.d0*min(vid,qgpini(xpomz0/xpomr,bbzt,0.d0,0.d0,8))
7669 vimpd=max(0.d0,(1.d0-exp(-vimd)*(1.d0+vimd)))/2.d0
7670
7671 vi1pu=qgpini(xpomri/xpomz0,bbzp
7672 * ,1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2,0.d0,16)*exp(-vimu)
7673 vguu=qgpini(xpomri/xpomz0,bbzp,vvxp0,vvxt0,21)*vilu !uu+uc
7674 vgcu=qgpini(xpomri/xpomz0,bbzp,vvxp0,vvxt0,23)
7675 * *(vilu**2+(exp(2.d0*viu-vimu)-1.d0)*exp(-2.d0*viu))/2.d0 !cc+cu
7676 vi1pd=qgpini(xpomz0/xpomr,bbzt
7677 * ,1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2,0.d0,16)*exp(-vimd)
7678 vgud=qgpini(xpomz0/xpomr,bbzt,vvxt0,vvxp0,21)*vild !uu+uc
7679 vgcd=qgpini(xpomz0/xpomr,bbzt,vvxt0,vvxp0,23)
7680 * *(vild**2+(exp(2.d0*vid-vimd)-1.d0)*exp(-2.d0*vid))/2.d0 !cc+cu
7681
7682 gbz0=(vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd+vimpu*vgcd
7683 * +vgcu*vimpd+vi1pu*vgcd+vgcu*vi1pd)*(1.d0-vvxp0)*(1.d0-vvxt0)
7684 * +(vimpu+vi1pu)*vgud*(1.d0-vvxp0)*vvxt0
7685 * +(vimpd+vi1pd)*vguu*(1.d0-vvxt0)*vvxp0
7686
7687 nrej=0
7688 34 xpomz=xpomr*sgap*(xpomri/xpomr/sgap**2)**qgran(b10)
7689 rpp=alfp*dlog(xpomri/xpomz)*4.d0*.0389d0
7690 rpt=alfp*dlog(xpomz/xpomr)*4.d0*.0389d0
7691 rp=rpp*rpt/(rpp+rpt)
7692 z=qgran(b10)
7693 phi=pi*qgran(b10)
7694 b0=dsqrt(-rp*dlog(z))
7695 bbzp=(dsqrt(bbi)*rpp/(rpp+rpt)+b0*cos(phi))**2
7696 * +(b0*sin(phi))**2
7697 bbzt=(dsqrt(bbi)*rpt/(rpp+rpt)-b0*cos(phi))**2
7698 * +(b0*sin(phi))**2
7699 call qgbdef(bbzp,bbzt,xxi,yyi,xxp,yyp,xxz,yyz
7700 * ,int(1.5d0+qgran(b10))) !coordinates for the vertex
7701 call qgfdf(xxz,yyz,xpomz,vpac,vtac
7702 * ,vvx,vvxp,vvxt,vvxpl,vvxtl,ip,it)
7703
7704 vvxp0=0.d0
7705 sumup=0.d0
7706 do i=1,ia(1)
7707 sumup=sumup+vpac(i)
7708 enddo
7709 vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
7710 do i=1,ia(1)
7711 ipp=ia(1)-i+1
7712 bbpi=(xa(ipp,1)+b-xxz)**2+(xa(ipp,2)-yyz)**2
7713 sumup=sumup-vpac(ipp)
7714 vpac0(ipp)=min(vpac(ipp)
7715 * ,qgfani(1.d0/xpomz,bbpi,1.d0-vvxs*exp(-sumup)
7716 * ,1.d0-exp(-vvxp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
7717 vvxp0=vvxp0+vpac0(ipp)
7718 enddo
7719 vvxp0=1.d0-exp(-vvxp0)
7720
7721 sumut=0.d0
7722 vvxt0=0.d0
7723 do i=1,ia(2)
7724 sumut=sumut+vtac(i)
7725 enddo
7726 vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
7727 do i=1,ia(2)
7728 itt=ia(2)-i+1
7729 bbti=(xb(itt,1)-xxz)**2+(xb(itt,2)-yyz)**2
7730 sumut=sumut-vtac(itt)
7731 vtac0(itt)=min(vtac(itt)
7732 * ,qgfani(xpomz*scm,bbti,1.d0-vvxs*exp(-sumut)
7733 * ,1.d0-exp(-vvxt0),1.d0-exp(-sumut),iddt(itt),2,3))
7734 vvxt0=vvxt0+vtac0(itt)
7735 enddo
7736 vvxt0=1.d0-exp(-vvxt0)
7737
7738 viu=qgpini(xpomri/xpomz,bbzp,0.d0,0.d0,2)
7739 vilu=1.d0-exp(-viu)
7740 vimu=2.d0*min(viu,qgpini(xpomri/xpomz,bbzp,0.d0,0.d0,8))
7741 vimpu=max(0.d0,(1.d0-exp(-vimu)*(1.d0+vimu)))/2.d0
7742 vid=qgpini(xpomz/xpomr,bbzt,0.d0,0.d0,2)
7743 vild=1.d0-exp(-vid)
7744 vimd=2.d0*min(vid,qgpini(xpomz/xpomr,bbzt,0.d0,0.d0,8))
7745 vimpd=max(0.d0,(1.d0-exp(-vimd)*(1.d0+vimd)))/2.d0
7746
7747 vi1pu=qgpini(xpomri/xpomz,bbzp
7748 * ,1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2,0.d0,16)*exp(-vimu)
7749 vguu=qgpini(xpomri/xpomz,bbzp,vvxp0,vvxt0,21)*vilu !uu+uc
7750 vgcu=qgpini(xpomri/xpomz,bbzp,vvxp0,vvxt0,23)
7751 * *(vilu**2+(exp(2.d0*viu-vimu)-1.d0)*exp(-2.d0*viu))/2.d0 !cc+cu
7752 vi1pd=qgpini(xpomz/xpomr,bbzt
7753 * ,1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2,0.d0,16)*exp(-vimd)
7754 vgud=qgpini(xpomz/xpomr,bbzt,vvxt0,vvxp0,21)*vild !uu+uc
7755 vgcd=qgpini(xpomz/xpomr,bbzt,vvxt0,vvxp0,23)
7756 * *(vild**2+(exp(2.d0*vid-vimd)-1.d0)*exp(-2.d0*vid))/2.d0 !cc+cu
7757
7758 vvcc=vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd+vimpu*vgcd+vgcu*vimpd
7759 * +vi1pu*vgcd+vgcu*vi1pd
7760 vvt=vvcc*(1.d0-vvxp0)*(1.d0-vvxt0)
7761 * +(vimpu+vi1pu)*vgud*(1.d0-vvxp0)*vvxt0
7762 * +(vimpd+vi1pd)*vguu*(1.d0-vvxt0)*vvxp0
7763
7764 gbz=vvt/gbz0/z*rp/rp0 /1.4d0
7765 nrej=nrej+1
7766 if(qgran(b10).gt.gbz.and.nrej.lt.10000)goto 34
7767
7768 aks=vvt*qgran(b10)
7769 if(aks.gt.vvcc*(1.d0-vvxp0)*(1.d0-vvxt0)
7770 * +(vimpu+vi1pu)*vgud*(1.d0-vvxp0)*vvxt0)then
7771 jtu=0
7772 if(qgran(b10).lt.vimpd/(vimpd+vi1pd))then
7773 jtd=2
7774 else
7775 jtd=1
7776 endif
7777 elseif(aks.gt.vvcc*(1.d0-vvxp0)*(1.d0-vvxt0))then
7778 jtd=0
7779 if(qgran(b10).lt.vimpu/(vimpu+vi1pu))then
7780 jtu=2
7781 else
7782 jtu=1
7783 endif
7784 else
7785 aks=vvcc*qgran(b10)
7786 if(aks.lt.vimpu*vimpd)then
7787 jtu=2
7788 jtd=2
7789 elseif(aks.lt.vimpu*vimpd+vimpu*vi1pd)then
7790 jtu=2
7791 jtd=1
7792 elseif(aks.lt.vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd)then
7793 jtu=1
7794 jtd=2
7795 elseif(aks.lt.vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd
7796 * +vimpu*vgcd)then
7797 jtu=2
7798 jtd=0
7799 elseif(aks.lt.vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd
7800 * +vimpu*vgcd+vgcu*vimpd)then
7801 jtu=0
7802 jtd=2
7803 elseif(aks.lt.vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd
7804 * +vimpu*vgcd+vgcu*vimpd+vi1pu*vgcd)then
7805 jtu=1
7806 jtd=0
7807 else
7808 jtu=0
7809 jtd=1
7810 endif
7811 endif
7812
7813 if(jtu.eq.1)then !single cut Pomeron
7814 npin=npin+1
7815 if(npin.gt.npmax)then
7816 iret=1
7817 goto 31
7818 endif
7819 xpomim(npin)=1.d0/xpomz/scm
7820 xpomip(npin)=xpomri
7821 vvxim(npin)=1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2
7822 bpomim(npin)=bbzp
7823 if(debug.ge.4)write (moniou,211)npin,xpomip(npin)
7824 * ,xpomim(npin),vvxim(npin),bpomim(npin)
7825 elseif(jtu.eq.2)then !more than 1 cut Pomeron
7826 ninc=npgen(vimu,2,20)
7827 npin=npin+ninc
7828 if(npin.gt.npmax)then
7829 iret=1
7830 goto 31
7831 endif
7832 do i=npin-ninc+1,npin
7833 xpomim(i)=1.d0/xpomz/scm
7834 xpomip(i)=xpomri
7835 vvxim(i)=0.d0
7836 bpomim(i)=bbzp
7837 if(debug.ge.4)write (moniou,211)i,xpomip(i),xpomim(i)
7838 * ,vvxim(i),bpomim(i)
7839 enddo
7840 endif
7841
7842 if(jtd.eq.1)then !single cut Pomeron
7843 npin=npin+1
7844 if(npin.gt.npmax)then
7845 iret=1
7846 goto 31
7847 endif
7848 xpomim(npin)=1.d0/xpomr/scm
7849 xpomip(npin)=xpomz
7850 vvxim(npin)=1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2
7851 bpomim(npin)=bbzt
7852 if(debug.ge.4)write (moniou,211)npin,xpomip(npin)
7853 * ,xpomim(npin),vvxim(npin),bpomim(npin)
7854 elseif(jtu.eq.2)then !more than 1 cut Pomeron
7855 ninc=npgen(vimd,2,20)
7856 npin=npin+ninc
7857 if(npin.gt.npmax)then
7858 iret=1
7859 goto 31
7860 endif
7861 do i=npin-ninc+1,npin
7862 xpomim(i)=1.d0/xpomr/scm
7863 xpomip(i)=xpomz
7864 vvxim(i)=0.d0
7865 bpomim(i)=bbzt
7866 if(debug.ge.4)write (moniou,211)i,xpomip(i),xpomim(i)
7867 * ,vvxim(i),bpomim(i)
7868 enddo
7869 endif
7870 endif
7871 enddo !end of the zigzag-loop
7872 endif !nzzp.ne.0
7873
7874 if(nzzt.ne.0)then
7875 btm=(xb(it,1)-xxp)**2+(xb(it,2)-yyp)**2
7876 xpomr0=max(dsqrt(xpomr/scm),sgap/scm)
7877 xpomr0=min(xpomr0,xpomr/sgap)
7878 rp1=(rq(iddt(it),2)+alfp*dlog(xpomr0*scm))*4.d0*.0389d0
7879 rp2=alfp*dlog(xpomr/xpomr0)*4.d0*.0389d0
7880 rp0=rp1*rp2/(rp1+rp2)
7881 bbt=btm*(rp1/(rp1+rp2))**2
7882 bbi=btm*(rp2/(rp1+rp2))**2
7883 call qgbdef(bbt,bbi,xb(it,1),xb(it,2),xxp,yyp,xxp0,yyp0,1)
7884 call qgfdf(xxp0,yyp0,xpomr0,vpac,vtac
7885 * ,vvx,vvxp,vvxt,vvxpl,vvxtl,ip,it)
7886
7887 sumct0=0.d0
7888 sumctt=0.d0
7889 sumut=0.d0
7890 vvxt0=0.d0
7891 vvxt0l=0.d0
7892 do i=1,ia(2)
7893 sumut=sumut+vtac(i)
7894 enddo
7895 vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
7896 do i=1,ia(2)
7897 itt=ia(2)-i+1
7898 bbti=(xb(itt,1)-xxp0)**2+(xb(itt,2)-yyp0)**2
7899 sumut=sumut-vtac(itt)
7900 vtac0(itt)=min(vtac(itt)
7901 * ,qgfani(xpomr0*scm,bbti,1.d0-vvxs*exp(-sumut)
7902 * ,1.d0-exp(-sumct0),1.d0-exp(-sumut),iddt(itt),2,3))
7903 if(itt.ge.it)vtact(itt)=max(vtac(itt)
7904 * ,qgfani(xpomr0*scm,bbti,1.d0-vvxs*exp(-sumut)
7905 * ,1.d0-exp(-sumctt),1.d0-exp(-sumut),iddt(itt),2,6))
7906 if(itt.gt.it)then
7907 vvxt0=vvxt0+vtac0(itt)
7908 sumctt=sumctt+vtact(itt)
7909 elseif(itt.lt.it)then
7910 vvxt0l=vvxt0l+vtac0(itt)
7911 endif
7912 sumct0=sumct0+vtac0(itt)
7913 enddo
7914 vvxtt=1.d0-exp(-sumctt)
7915 vvxt0=1.d0-exp(-vvxt0)
7916 vvxt0l=1.d0-exp(-vvxt0l)
7917
7918 sumcp0=0.d0
7919 sumup=0.d0
7920 vvxp0=0.d0
7921 vvxp0l=0.d0
7922 do i=1,ia(1)
7923 sumup=sumup+vpac(i)
7924 enddo
7925 vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
7926 do i=1,ia(1)
7927 ipp=ia(1)-i+1
7928 bbpi=(xa(ipp,1)+b-xxp0)**2+(xa(ipp,2)-yyp0)**2
7929 sumup=sumup-vpac(ipp)
7930 vpac0(ipp)=min(vpac(ipp)
7931 * ,qgfani(1.d0/xpomr0,bbpi,1.d0-vvxs*exp(-sumup)
7932 * ,1.d0-exp(-sumcp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
7933 if(ipp.gt.ip)then
7934 vvxp0=vvxp0+vpac0(ipp)
7935 elseif(ipp.lt.ip)then
7936 vvxp0l=vvxp0l+vpac0(ipp)
7937 endif
7938 sumcp0=sumcp0+vpac0(ipp)
7939 enddo
7940 vvxp0=1.d0-exp(-vvxp0)
7941 vvxp0l=1.d0-exp(-vvxp0l)
7942
7943 viu=qgpini(xpomr/xpomr0,bbi,0.d0,0.d0,2)
7944 vim=2.d0*min(viu,qgpini(xpomr/xpomr0,bbi,0.d0,0.d0,8))
7945 vvxpin=1.d0-(1.d0-vvxp0)*(1.d0-vvxp0l)*exp(-vpac0(ip))
7946 vvxtin=1.d0-(1.d0-vvxt0)*(1.d0-vvxt0l)*exp(-vtac0(it))
7947 vi=qgpini(xpomr/xpomr0,bbi,vvxtin,vvxpin,21)*(1.d0-exp(-viu))
7948 * -qgpini(xpomr/xpomr0,bbi,vvxtin,vvxpin,23)*((1.d0-exp(-viu))**2
7949 * +(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))/2.d0
7950
7951 vvx0s=(1.d0-vvxpin)**2
7952 vvxs=((1.d0-vvxp)*(1.d0-vvxpl))**2*exp(-2.d0*vpac(ip))
7953
7954 gb0=vi *15.
7955 * *((1.d0-exp(-vtact(it)))*(1.d0-vvxtt)*(1.d0-vvxs)
7956 * +vvxs*(max(0.d0,1.d0-exp(-vtact(it))*(1.d0+vtact(it)))
7957 * *(1.d0-vvxtt)
7958 * -max(0.d0,1.d0-exp(-vtac0(it))*(1.d0+vtac0(it)))*(1.d0-vvxt0))
7959 * +vtact(it)*exp(-vtact(it))*((1.d0-vvxtt)*vvxs
7960 * -exp(vtact(it)-vtac0(it))*(1.d0-vvxt0)*(1.d0-vvxt0l)*vvx0s)
7961 * -vtac0(it)*exp(-vtac0(it))*(1.d0-vvxt0)
7962 * *(vvxs-vvx0s+vvxt0l*vvx0s))
7963
7964 do in=1,nzzt
7965 nrej=0
7966 33 xpomri=xpomr/sgap/(xpomr*scm/sgap**2)**qgran(b10)
7967 rp1=(rq(iddt(it),2)+alfp*dlog(xpomri*scm))*4.d0*.0389d0
7968 rp2=alfp*dlog(xpomr/xpomri)*4.d0*.0389d0
7969 rp=rp1*rp2/(rp1+rp2)
7970 z=qgran(b10)
7971 phi=pi*qgran(b10)
7972 b0=dsqrt(-rp*dlog(z))
7973 bbt=(dsqrt(btm)*rp1/(rp1+rp2)+b0*cos(phi))**2+(b0*sin(phi))**2
7974 bbi=(dsqrt(btm)*rp2/(rp1+rp2)-b0*cos(phi))**2+(b0*sin(phi))**2
7975 call qgbdef(bbt,bbi,xb(it,1),xb(it,2),xxp,yyp,xxi,yyi
7976 * ,int(1.5d0+qgran(b10))) !coordinates for the vertex
7977 call qgfdf(xxi,yyi,xpomri,vpac,vtac
7978 * ,vvx,vvxp,vvxt,vvxpl,vvxtl,ip,it)
7979
7980 sumct0=0.d0
7981 sumctt=0.d0
7982 sumut=0.d0
7983 vvxt0=0.d0
7984 vvxt0l=0.d0
7985 do i=1,ia(2)
7986 sumut=sumut+vtac(i)
7987 enddo
7988 vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
7989 do i=1,ia(2)
7990 itt=ia(2)-i+1
7991 bbti=(xb(itt,1)-xxi)**2+(xb(itt,2)-yyi)**2
7992 sumut=sumut-vtac(itt)
7993 vtac0(itt)=min(vtac(itt)
7994 * ,qgfani(xpomri*scm,bbti,1.d0-vvxs*exp(-sumut)
7995 * ,1.d0-exp(-sumct0),1.d0-exp(-sumut),iddt(itt),2,3))
7996 if(itt.ge.it)vtact(itt)=max(vtac(itt)
7997 * ,qgfani(xpomri*scm,bbti,1.d0-vvxs*exp(-sumut)
7998 * ,1.d0-exp(-sumctt),1.d0-exp(-sumut),iddt(itt),2,6))
7999 if(itt.gt.it)then
8000 vvxt0=vvxt0+vtac0(itt)
8001 sumctt=sumctt+vtact(itt)
8002 elseif(itt.lt.it)then
8003 vvxt0l=vvxt0l+vtac0(itt)
8004 endif
8005 sumct0=sumct0+vtac0(itt)
8006 enddo
8007 vvxtt=1.d0-exp(-sumctt)
8008 vvxt0=1.d0-exp(-vvxt0)
8009 vvxt0l=1.d0-exp(-vvxt0l)
8010
8011 sumcp0=0.d0
8012 sumup=0.d0
8013 vvxp0=0.d0
8014 vvxp0l=0.d0
8015 do i=1,ia(1)
8016 sumup=sumup+vpac(i)
8017 enddo
8018 vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8019 do i=1,ia(1)
8020 ipp=ia(1)-i+1
8021 bbpi=(xa(ipp,1)+b-xxi)**2+(xa(ipp,2)-yyi)**2
8022 sumup=sumup-vpac(ipp)
8023 vpac0(ipp)=min(vpac(ipp)
8024 * ,qgfani(1.d0/xpomri,bbpi,1.d0-vvxs*exp(-sumup)
8025 * ,1.d0-exp(-sumcp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
8026 if(ipp.gt.ip)then
8027 vvxp0=vvxp0+vpac0(ipp)
8028 elseif(ipp.lt.ip)then
8029 vvxp0l=vvxp0l+vpac0(ipp)
8030 endif
8031 sumcp0=sumcp0+vpac0(ipp)
8032 enddo
8033 vvxp0=1.d0-exp(-vvxp0)
8034 vvxp0l=1.d0-exp(-vvxp0l)
8035
8036 viu=qgpini(xpomr/xpomri,bbi,0.d0,0.d0,2)
8037 vim=2.d0*min(viu,qgpini(xpomr/xpomri,bbi,0.d0,0.d0,8))
8038 vvxpin=1.d0-(1.d0-vvxp0)*(1.d0-vvxp0l)*exp(-vpac0(ip))
8039 vvxtin=1.d0-(1.d0-vvxt0)*(1.d0-vvxt0l)*exp(-vtac0(it))
8040 vi=qgpini(xpomr/xpomri,bbi,vvxtin,vvxpin,21)*(1.d0-exp(-viu))
8041 * -qgpini(xpomr/xpomri,bbi,vvxtin,vvxpin,23)*((1.d0-exp(-viu))**2
8042 * +(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))/2.d0
8043
8044 vvx0s=(1.d0-vvxpin)**2
8045 vvxs=((1.d0-vvxp)*(1.d0-vvxpl))**2*exp(-2.d0*vpac(ip))
8046
8047 gb=vi
8048 * *((1.d0-exp(-vtact(it)))*(1.d0-vvxtt)*(1.d0-vvxs)
8049 * +vvxs*(max(0.d0,1.d0-exp(-vtact(it))*(1.d0+vtact(it)))
8050 * *(1.d0-vvxtt)
8051 * -max(0.d0,1.d0-exp(-vtac0(it))*(1.d0+vtac0(it)))*(1.d0-vvxt0))
8052 * +vtact(it)*exp(-vtact(it))*((1.d0-vvxtt)*vvxs
8053 * -exp(vtact(it)-vtac0(it))*(1.d0-vvxt0)*(1.d0-vvxt0l)*vvx0s)
8054 * -vtac0(it)*exp(-vtac0(it))*(1.d0-vvxt0)
8055 * *(vvxs-vvx0s+vvxt0l*vvx0s))
8056
8057 gb=gb/gb0/z*rp/rp0
8058 nrej=nrej+1
8059 if(qgran(b10).gt.gb.and.nrej.lt.10000)goto 33
8060
8061 vi1p=qgpini(xpomr/xpomri,bbi,1.d0-(1.d0-vvxtin)**2*vvx0s
8062 * ,0.d0,16)*exp(-vim)
8063 vimp=max(0.d0,(1.d0-exp(-vim)*(1.d0+vim)))/2.d0
8064
8065 if(qgran(b10).le.(vi1p+vimp)/vi
8066 * .or.xpomr/xpomri.lt.1.1d0*sgap**2)then
8067 if(qgran(b10).le.vi1p/(vi1p+vimp))then !single cut Pomeron
8068 npin=npin+1
8069 if(npin.gt.npmax)then
8070 iret=1
8071 goto 31
8072 endif
8073 xpomim(npin)=1.d0/xpomri/scm
8074 xpomip(npin)=xpomr
8075 vvxim(npin)=1.d0-(1.d0-vvxtin)**2*vvx0s
8076 bpomim(npin)=bbi
8077 if(debug.ge.4)write (moniou,211)npin,xpomip(npin)
8078 * ,xpomim(npin),vvxim(npin),bpomim(npin)
8079 else !more than 1 cut pomeron
8080 ninc=npgen(vim,2,20)
8081 npin=npin+ninc
8082 if(npin.gt.npmax)then
8083 iret=1
8084 goto 31
8085 endif
8086 do i=npin-ninc+1,npin
8087 xpomim(i)=1.d0/xpomri/scm
8088 xpomip(i)=xpomr
8089 vvxim(i)=0.d0
8090 bpomim(i)=bbi
8091 if(debug.ge.4)write (moniou,211)i,xpomip(i),xpomim(i)
8092 * ,vvxim(i),bpomim(i)
8093 enddo
8094 endif
8095
8096 else !additional vertices
8097 xpomz0=dsqrt(xpomr*xpomri)
8098 rp0=alfp*dlog(xpomr/xpomri)*.0389d0
8099 xxz0=.5d0*(xxp+xxi)
8100 yyz0=.5d0*(yyp+yyi)
8101 bbzp=.25d0*bbi
8102 bbzt=bbzp
8103 call qgfdf(xxz0,yyz0,xpomz0,vpac,vtac,vvx,vvxp,vvxt
8104 * ,vvxpl,vvxtl,ip,it)
8105
8106 vvxp0=0.d0
8107 sumup=0.d0
8108 do i=1,ia(1)
8109 sumup=sumup+vpac(i)
8110 enddo
8111 vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8112 do i=1,ia(1)
8113 ipp=ia(1)-i+1
8114 bbpi=(xa(ipp,1)+b-xxz0)**2+(xa(ipp,2)-yyz0)**2
8115 sumup=sumup-vpac(ipp)
8116 vpac0(ipp)=min(vpac(ipp)
8117 * ,qgfani(1.d0/xpomz0,bbpi,1.d0-vvxs*exp(-sumup)
8118 * ,1.d0-exp(-vvxp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
8119 vvxp0=vvxp0+vpac0(ipp)
8120 enddo
8121 vvxp0=1.d0-exp(-vvxp0)
8122
8123 sumut=0.d0
8124 vvxt0=0.d0
8125 do i=1,ia(2)
8126 sumut=sumut+vtac(i)
8127 enddo
8128 vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
8129 do i=1,ia(2)
8130 itt=ia(2)-i+1
8131 bbti=(xb(itt,1)-xxz0)**2+(xb(itt,2)-yyz0)**2
8132 sumut=sumut-vtac(itt)
8133 vtac0(itt)=min(vtac(itt)
8134 * ,qgfani(xpomz0*scm,bbti,1.d0-vvxs*exp(-sumut)
8135 * ,1.d0-exp(-vvxt0),1.d0-exp(-sumut),iddt(itt),2,3))
8136 vvxt0=vvxt0+vtac0(itt)
8137 enddo
8138 vvxt0=1.d0-exp(-vvxt0)
8139
8140 viu=qgpini(xpomr/xpomz0,bbzp,0.d0,0.d0,2)
8141 vilu=1.d0-exp(-viu)
8142 vimu=2.d0*min(viu,qgpini(xpomr/xpomz0,bbzp,0.d0,0.d0,8))
8143 vimpu=max(0.d0,(1.d0-exp(-vimu)*(1.d0+vimu)))/2.d0
8144 vid=qgpini(xpomz0/xpomri,bbzt,0.d0,0.d0,2)
8145 vild=1.d0-exp(-vid)
8146 vimd=2.d0*min(vid,qgpini(xpomz0/xpomri,bbzt,0.d0,0.d0,8))
8147 vimpd=max(0.d0,(1.d0-exp(-vimd)*(1.d0+vimd)))/2.d0
8148
8149 vi1pu=qgpini(xpomr/xpomz0,bbzp
8150 * ,1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2,0.d0,16)*exp(-vimu)
8151 vguu=qgpini(xpomr/xpomz0,bbzp,vvxp0,vvxt0,21)*vilu !uu+uc
8152 vgcu=qgpini(xpomr/xpomz0,bbzp,vvxp0,vvxt0,23)
8153 * *(vilu**2+(exp(2.d0*viu-vimu)-1.d0)*exp(-2.d0*viu))/2.d0 !cc+cu
8154 vi1pd=qgpini(xpomz0/xpomri,bbzt
8155 * ,1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2,0.d0,16)*exp(-vimd)
8156 vgud=qgpini(xpomz0/xpomri,bbzt,vvxt0,vvxp0,21)*vild !uu+uc
8157 vgcd=qgpini(xpomz0/xpomri,bbzt,vvxt0,vvxp0,23)
8158 * *(vild**2+(exp(2.d0*vid-vimd)-1.d0)*exp(-2.d0*vid))/2.d0 !cc+cu
8159
8160 gbz0=(vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd+vimpu*vgcd
8161 * +vgcu*vimpd+vi1pu*vgcd+vgcu*vi1pd)*(1.d0-vvxp0)*(1.d0-vvxt0)
8162 * +(vimpu+vi1pu)*vgud*(1.d0-vvxp0)*vvxt0
8163 * +(vimpd+vi1pd)*vguu*(1.d0-vvxt0)*vvxp0
8164
8165 nrej=0
8166 35 xpomz=xpomri*sgap*(xpomr/xpomri/sgap**2)**qgran(b10)
8167 rpt=alfp*dlog(xpomz/xpomri)*4.d0*.0389d0
8168 rpp=alfp*dlog(xpomr/xpomz)*4.d0*.0389d0
8169 rp=rpp*rpt/(rpp+rpt)
8170 z=qgran(b10)
8171 phi=pi*qgran(b10)
8172 b0=dsqrt(-rp*dlog(z))
8173 bbzt=(dsqrt(bbi)*rpt/(rpp+rpt)-b0*cos(phi))**2
8174 * +(b0*sin(phi))**2
8175 bbzp=(dsqrt(bbi)*rpp/(rpp+rpt)+b0*cos(phi))**2
8176 * +(b0*sin(phi))**2
8177 call qgbdef(bbzt,bbzp,xxi,yyi,xxp,yyp,xxz,yyz
8178 * ,int(1.5d0+qgran(b10))) !coordinates for the vertex
8179 call qgfdf(xxz,yyz,xpomz,vpac,vtac
8180 * ,vvx,vvxp,vvxt,vvxpl,vvxtl,ip,it)
8181
8182 vvxp0=0.d0
8183 sumup=0.d0
8184 do i=1,ia(1)
8185 sumup=sumup+vpac(i)
8186 enddo
8187 vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8188 do i=1,ia(1)
8189 ipp=ia(1)-i+1
8190 bbpi=(xa(ipp,1)+b-xxz)**2+(xa(ipp,2)-yyz)**2
8191 sumup=sumup-vpac(ipp)
8192 vpac0(ipp)=min(vpac(ipp)
8193 * ,qgfani(1.d0/xpomz,bbpi,1.d0-vvxs*exp(-sumup)
8194 * ,1.d0-exp(-vvxp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
8195 vvxp0=vvxp0+vpac0(ipp)
8196 enddo
8197 vvxp0=1.d0-exp(-vvxp0)
8198
8199 sumut=0.d0
8200 vvxt0=0.d0
8201 do i=1,ia(2)
8202 sumut=sumut+vtac(i)
8203 enddo
8204 vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
8205 do i=1,ia(2)
8206 itt=ia(2)-i+1
8207 bbti=(xb(itt,1)-xxz)**2+(xb(itt,2)-yyz)**2
8208 sumut=sumut-vtac(itt)
8209 vtac0(itt)=min(vtac(itt)
8210 * ,qgfani(xpomz*scm,bbti,1.d0-vvxs*exp(-sumut)
8211 * ,1.d0-exp(-vvxt0),1.d0-exp(-sumut),iddt(itt),2,3))
8212 vvxt0=vvxt0+vtac0(itt)
8213 enddo
8214 vvxt0=1.d0-exp(-vvxt0)
8215
8216 viu=qgpini(xpomr/xpomz,bbzp,0.d0,0.d0,2)
8217 vilu=1.d0-exp(-viu)
8218 vimu=2.d0*min(viu,qgpini(xpomr/xpomz,bbzp,0.d0,0.d0,8))
8219 vimpu=max(0.d0,(1.d0-exp(-vimu)*(1.d0+vimu)))/2.d0
8220 vid=qgpini(xpomz/xpomri,bbzt,0.d0,0.d0,2)
8221 vild=1.d0-exp(-vid)
8222 vimd=2.d0*min(vid,qgpini(xpomz/xpomri,bbzt,0.d0,0.d0,8))
8223 vimpd=max(0.d0,(1.d0-exp(-vimd)*(1.d0+vimd)))/2.d0
8224
8225 vi1pu=qgpini(xpomr/xpomz,bbzp
8226 * ,1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2,0.d0,16)*exp(-vimu)
8227 vguu=qgpini(xpomr/xpomz,bbzp,vvxp0,vvxt0,21)*vilu !uu+uc
8228 vgcu=qgpini(xpomr/xpomz,bbzp,vvxp0,vvxt0,23)
8229 * *(vilu**2+(exp(2.d0*viu-vimu)-1.d0)*exp(-2.d0*viu))/2.d0 !cc+cu
8230 vi1pd=qgpini(xpomz/xpomri,bbzt
8231 * ,1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2,0.d0,16)*exp(-vimd)
8232 vgud=qgpini(xpomz/xpomri,bbzt,vvxt0,vvxp0,21)*vild !uu+uc
8233 vgcd=qgpini(xpomz/xpomri,bbzt,vvxt0,vvxp0,23)
8234 * *(vild**2+(exp(2.d0*vid-vimd)-1.d0)*exp(-2.d0*vid))/2.d0 !cc+cu
8235
8236 vvcc=vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd+vimpu*vgcd+vgcu*vimpd
8237 * +vi1pu*vgcd+vgcu*vi1pd
8238 vvt=vvcc*(1.d0-vvxp0)*(1.d0-vvxt0)
8239 * +(vimpu+vi1pu)*vgud*(1.d0-vvxp0)*vvxt0
8240 * +(vimpd+vi1pd)*vguu*(1.d0-vvxt0)*vvxp0
8241
8242 gbz=vvt/gbz0/z*rp/rp0 /1.4d0
8243 nrej=nrej+1
8244 if(qgran(b10).gt.gbz.and.nrej.lt.10000)goto 35
8245
8246 aks=vvt*qgran(b10)
8247 if(aks.gt.vvcc*(1.d0-vvxp0)*(1.d0-vvxt0)
8248 * +(vimpu+vi1pu)*vgud*(1.d0-vvxp0)*vvxt0)then
8249 jtu=0
8250 if(qgran(b10).lt.vimpd/(vimpd+vi1pd))then
8251 jtd=2
8252 else
8253 jtd=1
8254 endif
8255 elseif(aks.gt.vvcc*(1.d0-vvxp0)*(1.d0-vvxt0))then
8256 jtd=0
8257 if(qgran(b10).lt.vimpu/(vimpu+vi1pu))then
8258 jtu=2
8259 else
8260 jtu=1
8261 endif
8262 else
8263 aks=vvcc*qgran(b10)
8264 if(aks.lt.vimpu*vimpd)then
8265 jtu=2
8266 jtd=2
8267 elseif(aks.lt.vimpu*vimpd+vimpu*vi1pd)then
8268 jtu=2
8269 jtd=1
8270 elseif(aks.lt.vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd)then
8271 jtu=1
8272 jtd=2
8273 elseif(aks.lt.vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd
8274 * +vimpu*vgcd)then
8275 jtu=2
8276 jtd=0
8277 elseif(aks.lt.vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd
8278 * +vimpu*vgcd+vgcu*vimpd)then
8279 jtu=0
8280 jtd=2
8281 elseif(aks.lt.vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd
8282 * +vimpu*vgcd+vgcu*vimpd+vi1pu*vgcd)then
8283 jtu=1
8284 jtd=0
8285 else
8286 jtu=0
8287 jtd=1
8288 endif
8289 endif
8290
8291 if(jtu.eq.1)then !single cut Pomeron
8292 npin=npin+1
8293 if(npin.gt.npmax)then
8294 iret=1
8295 goto 31
8296 endif
8297 xpomim(npin)=1.d0/xpomz/scm
8298 xpomip(npin)=xpomr
8299 vvxim(npin)=1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2
8300 bpomim(npin)=bbzp
8301 if(debug.ge.4)write (moniou,211)npin,xpomip(npin)
8302 * ,xpomim(npin),vvxim(npin),bpomim(npin)
8303 elseif(jtu.eq.2)then !more than 1 cut Pomeron
8304 ninc=npgen(vimu,2,20)
8305 npin=npin+ninc
8306 if(npin.gt.npmax)then
8307 iret=1
8308 goto 31
8309 endif
8310 do i=npin-ninc+1,npin
8311 xpomim(i)=1.d0/xpomz/scm
8312 xpomip(i)=xpomr
8313 vvxim(i)=0.d0
8314 bpomim(i)=bbzp
8315 if(debug.ge.4)write (moniou,211)i,xpomip(i),xpomim(i)
8316 * ,vvxim(i),bpomim(i)
8317 enddo
8318 endif
8319
8320 if(jtd.eq.1)then !single cut Pomeron
8321 npin=npin+1
8322 if(npin.gt.npmax)then
8323 iret=1
8324 goto 31
8325 endif
8326 xpomim(npin)=1.d0/xpomri/scm
8327 xpomip(npin)=xpomz
8328 vvxim(npin)=1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2
8329 bpomim(npin)=bbzt
8330 if(debug.ge.4)write (moniou,211)npin,xpomip(npin)
8331 * ,xpomim(npin),vvxim(npin),bpomim(npin)
8332 elseif(jtu.eq.2)then !more than 1 cut Pomeron
8333 ninc=npgen(vimd,2,20)
8334 npin=npin+ninc
8335 if(npin.gt.npmax)then
8336 iret=1
8337 goto 31
8338 endif
8339 do i=npin-ninc+1,npin
8340 xpomim(i)=1.d0/xpomri/scm
8341 xpomip(i)=xpomz
8342 vvxim(i)=0.d0
8343 bpomim(i)=bbzt
8344 if(debug.ge.4)write (moniou,211)i,xpomip(i),xpomim(i)
8345 * ,vvxim(i),bpomim(i)
8346 enddo
8347 endif
8348 endif
8349 enddo !end of the zigzag-loop
8350 endif !nzzt.ne.0
8351
8352 call qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt,vvxpl,vvxtl
8353 *,ip,it)
8354 if((jt.eq.2.or.jt.eq.3.or.jt.eq.9)
8355 *.and.qgran(b10).lt.(1.d0-exp(-vpac(ip)))*(1.d0-vvxpl)
8356 */((1.d0-exp(-vpac(ip)))*(1.d0-vvxpl)+2.d0*vvxpl))then
8357 icdps=iddp(ip)
8358 do icdp=1,2
8359 iddp(ip)=icdp
8360 call qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt,vvxpl,vvxtl
8361 * ,ip,it)
8362 wdp(icdp,ip)=(1.d0-exp(-vpac(ip)))*(1.d0-vvxpl)
8363 enddo
8364 iddp(ip)=icdps
8365 endif
8366 call qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt,vvxpl,vvxtl
8367 *,ip,it)
8368 if((jt.eq.2.or.jt.eq.4.or.jt.eq.10)
8369 *.and.qgran(b10).lt.(1.d0-exp(-vtac(it)))*(1.d0-vvxtl)
8370 */((1.d0-exp(-vtac(it)))*(1.d0-vvxtl)+2.d0*vvxtl))then
8371 icdts=iddt(it)
8372 do icdt=1,2
8373 iddt(it)=icdt
8374 call qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt,vvxpl,vvxtl
8375 * ,ip,it)
8376 wdt(icdt,it)=(1.d0-exp(-vtac(it)))*(1.d0-vvxtl)
8377 enddo
8378 iddt(it)=icdts
8379 endif
8380
8381 if(nppr0.eq.0)goto 20
8382
8383
8384 m=0
8385 nppm(1)=nppr0
8386 xpomm(1)=xpomr
8387 wgpm(1)=wgpr0
8388 xxm(1)=xxp
8389 yym(1)=yyp
8390 do i=1,nppr0
8391 ippm(i,1)=ippr0(i)
8392 itypm(i,1)=itypr0(i)
8393 enddo
8394
8395 9 m=m+1 !next level multi-Pomeron vertex
8396 if(m.gt.levmax)then
8397 iret=1
8398 goto 31
8399 endif
8400 ii(m)=0
8401 10 ii(m)=ii(m)+1 !next cut fan in the vertex
8402 if(ii(m).gt.nppm(m))then !all fans at the level considered
8403 m=m-1 !one level down
8404 if(m.eq.0)goto 20 !all proj. fans considered
8405 goto 10
8406 endif
8407 l=ii(m)
8408 ipp=ippm(l,m) !proj. index for the leg
8409 itypom=itypm(l,m) !type of the cut
8410 bpm=(xa(ipp,1)+b-xxm(m))**2+(xa(ipp,2)-yym(m))**2 !b^2 for the leg
8411 if(debug.ge.4)write (moniou,208)ii(m),m,ipp,bpm
8412 if(xpomm(m)*sgap**2.gt.1.d0)stop'xpomm(m)*sgap**2>1!'
8413 if(itypom.eq.4.and.xpomm(m)*sgap**3.gt.1.d0)
8414 *stop'4:xpomm(m)*sgap**3>1!'
8415
8416 if(debug.ge.4)write (moniou,210)m
8417 xpomr0=min(dsqrt(xpomm(m)),1.d0/sgap)
8418 xpomr0=max(xpomr0,xpomm(m)*sgap)
8419 if(itypom.eq.4)xpomr0=min(xpomr0,dsqrt(xpomm(m)/sgap))
8420 rp1=(rq(iddp(ipp),icz)-alfp*dlog(xpomr0))*4.d0*.0389d0
8421 rp2=alfp*dlog(xpomr0/xpomm(m))*4.d0*.0389d0
8422 rp0=rp1*rp2/(rp1+rp2)
8423 bbp=bpm*(rp1/(rp1+rp2))**2
8424 bbi=bpm*(rp2/(rp1+rp2))**2
8425 call qgbdef(bbp,bbi,xa(ipp,1)+b,xa(ipp,2),xxm(m),yym(m)
8426 *,xxp0,yyp0,1)
8427
8428 call qgfdf(xxp0,yyp0,xpomr0,vpac,vtac,vvx,vvxp,vvxt
8429 *,vvxpl,vvxtl,ipp,it)
8430 vvxts=1.d0-(1.d0-vvx)*(1.d0-vvxt)*exp(-vtac(it))
8431 viu=qgpini(xpomr0/xpomm(m),bbi,0.d0,0.d0,2)
8432 vim=2.d0*min(viu,qgpini(xpomr0/xpomm(m),bbi,0.d0,0.d0,8))
8433 if(itypom.eq.-1.or.itypom.eq.4)then !single cut Pomeron at the end
8434 vvxi=1.d0-((1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxt))**2
8435 * *exp(-2.d0*vpac(ipp)-2.d0*vtac(it))
8436 vip=qgpini(xpomr0/xpomm(m),bbi,vvxi,0.d0,16)*exp(-vim)
8437 elseif(itypom.eq.2.or.itypom.eq.7)then !>1 cut Poms at the end
8438 vimp=max(0.d0,1.d0-exp(-vim)*(1.d0+vim))
8439 else !rap-gap
8440 vvxpin=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ipp))
8441 vvxtin=1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8442 viuu=qgpini(xpomr0/xpomm(m),bbi,vvxpin,vvxtin,20)
8443 * *(1.d0-exp(-viu))
8444 viuc=max(0.d0,viuu
8445 * -qgpini(xpomr0/xpomm(m),bbi,vvxpin,vvxtin,21)*(1.d0-exp(-viu)))
8446 vicc=qgpini(xpomr0/xpomm(m),bbi,vvxpin,vvxtin,22)*.5d0
8447 * *((1.d0-exp(-viu))**2+(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))
8448 vicu=max(0.d0,qgpini(xpomr0/xpomm(m),bbi,vvxpin,vvxtin,23)*.5d0
8449 * *((1.d0-exp(-viu))**2+(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))
8450 * -vicc)
8451 endif
8452
8453 if(itypom.le.3)then
8454 sumup=0.d0
8455 vvxp0=0.d0
8456 do i=1,ia(1)
8457 sumup=sumup+vpac(i)
8458 enddo
8459 vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8460 do i=1,ia(1)-ipp+1
8461 ipi=ia(1)-i+1
8462 bbl=(xa(ipi,1)+b-xxp0)**2+(xa(ipi,2)-yyp0)**2
8463 sumup=sumup-vpac(ipi)
8464 vpac0(ipi)=min(vpac(ipi)
8465 * ,qgfani(1.d0/xpomr0,bbl,1.d0-vvxs*exp(-sumup)
8466 * ,1.d0-exp(-vvxp0),1.d0-exp(-sumup),iddp(ipi),icz,3))
8467 if(ipi.gt.ipp)vvxp0=vvxp0+vpac0(ipi)
8468 enddo
8469 vvxp0=1.d0-exp(-vvxp0)
8470 vpacng=min(vpac0(ipp)
8471 * ,qgfani(1.d0/xpomr0,bbp,vvxts,vvxp0,vvxpl,iddp(ipp),icz,4))
8472 vpacpe=min(vpacng
8473 * ,qgfani(1.d0/xpomr0,bbp,vvxts,vvxp0,vvxpl,iddp(ipp),icz,5))
8474 else
8475 vplc=qgfani(1.d0/xpomr0,bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,7)
8476 vplc0=min(vplc
8477 * ,qgfani(1.d0/xpomr0,bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,8))
8478 vplcng=min(vplc0
8479 * ,qgfani(1.d0/xpomr0,bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,11))
8480 vplcpe=min(vplcng
8481 * ,qgfani(1.d0/xpomr0,bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,10))
8482 endif
8483
8484 if(itypom.eq.-1)then !'fan' (single cut Pomeron at the end)
8485 gb0=vip*((max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
8486 * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
8487 * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
8488 * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8489 * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8490 * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
8491 * +((1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
8492 * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl)
8493 * +2.d0*((vpac0(ipp)-vpacpe)*exp(-vpac(ipp))*(1.d0-vvxp)
8494 * *(1.d0-vvxpl)-(vpac(ipp)-vpac0(ipp))*(1.d0-exp(-vpac(ipp))
8495 * *(1.d0-vvxp)*(1.d0-vvxpl)))*exp(-vpac(ipp))*(1.d0-vvxp))
8496 * *(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)*exp(-2.d0*vtac(it))
8497 gb0=gb0*40.d0
8498 elseif(itypom.eq.0)then !'fan' (cut loop at the end - rapgap)
8499 gb0=((max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
8500 * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
8501 * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
8502 * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8503 * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8504 * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
8505 * +((1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
8506 * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl)
8507 * +2.d0*vpacng*exp(-2.d0*vpac(ipp))*(1.d0-vvxp)**2*(1.d0-vvxpl))
8508 * *(vicc*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8509 * -vicu*(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))))
8510 * *(1.d0-vvx)*(1.d0-vvxt)*exp(-vtac(it))
8511 * -2.d0*vicu*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8512 * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8513 * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp)-vtac(it))
8514 * *(1.d0-vvx)*(1.d0-vvxt)
8515 elseif(itypom.eq.1)then !'fan' (uncut end - rapgap)
8516 gb0=((max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
8517 * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
8518 * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
8519 * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8520 * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8521 * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
8522 * +((1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
8523 * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl)
8524 * +2.d0*vpacng*exp(-2.d0*vpac(ipp))*(1.d0-vvxp)**2*(1.d0-vvxpl))
8525 * *(viuc*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8526 * +viuu*(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))))
8527 * *(1.d0-vvx)*(1.d0-vvxt)*exp(-vtac(it))
8528 * +2.d0*viuu*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8529 * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8530 * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp)-vtac(it))
8531 * *(1.d0-vvx)*(1.d0-vvxt)
8532 elseif(itypom.eq.2)then !'fan' (>1 cut Poms at the end)
8533 gb0=vimp*((max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
8534 * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
8535 * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
8536 * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8537 * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8538 * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
8539 * +((1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
8540 * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl)
8541 * +2.d0*(vpac0(ipp)*exp(-vpac(ipp))*(1.d0-vvxp)
8542 * *(1.d0-vvxpl)-(vpac(ipp)-vpac0(ipp))*(1.d0-exp(-vpac(ipp))
8543 * *(1.d0-vvxp)*(1.d0-vvxpl)))*exp(-vpac(ipp))*(1.d0-vvxp))
8544 * *(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)*exp(-2.d0*vtac(it))
8545 elseif(itypom.eq.3)then !'fan' (cut/uncut end - rapgap)
8546 gb0=((max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
8547 * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
8548 * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
8549 * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8550 * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8551 * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
8552 * +((1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
8553 * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl)
8554 * +2.d0*vpacng*exp(-2.d0*vpac(ipp))*(1.d0-vvxp)**2*(1.d0-vvxpl))
8555 * *(vicc-wgpm(m)*viuc)*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8556 * *(1.d0-vvx)*(1.d0-vvxt)*exp(-vtac(it))
8557 elseif(itypom.eq.4)then !'leg' (single cut Pomeron at the end)
8558 gb0=vip*((vplc0-vplcpe)*exp(-vpac(ipp))*(1.d0-vvxp)
8559 * *(1.d0-vvxpl))*exp(-vpac(ipp)-2.d0*vtac(it))*(1.d0-vvxp)
8560 * *(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)
8561 if(gb0.le.0.d0)then
8562 gb0=vip*vplc0*.01d0*exp(-vpac(ipp))*(1.d0-vvxp)
8563 * *(1.d0-vvxpl)*exp(-vpac(ipp)-2.d0*vtac(it))*(1.d0-vvxp)
8564 * *(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)
8565 endif
8566 elseif(itypom.eq.5)then !'leg' (cut/uncut end - rapgap)
8567 gb0=vplcng*exp(-2.d0*vpac(ipp)-vtac(it))
8568 * *(1.d0-vvxp)**2*(1.d0-vvxpl)*(1.d0-vvx)*(1.d0-vvxt)
8569 * *(vicc-wgpm(m)*viuc)*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8570 elseif(itypom.eq.7)then !'leg' (>1 cut Poms at the end)
8571 gb0=vimp*(vplc0*exp(-vpac(ipp))*(1.d0-vvxp)*(1.d0-vvxpl)
8572 * -(vplc-vplc0)*(1.d0-exp(-vpac(ipp))*(1.d0-vvxp)*(1.d0-vvxpl)))
8573 * *exp(-vpac(ipp)-2.d0*vtac(it))*(1.d0-vvxp)
8574 * *(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)
8575 endif
8576 if(gb0.le.0.d0)then !so170712
8577 iret=1
8578 goto 31
8579 endif
8580 nrej=0
8581
8582 11 xpomm(m+1)=(xpomm(m)*sgap**2)**qgran(b10)/sgap
8583 if(itypom.eq.4)xpomm(m+1)=(xpomm(m)*sgap**3)**qgran(b10)/sgap**2
8584 rp1=(rq(iddp(ipp),icz)-alfp*dlog(xpomm(m+1)))*4.d0*.0389d0
8585 rp2=alfp*dlog(xpomm(m+1)/xpomm(m))*4.d0*.0389d0
8586 rp=rp1*rp2/(rp1+rp2)
8587 z=qgran(b10)
8588 phi=pi*qgran(b10)
8589 b0=dsqrt(-rp*dlog(z))
8590 bbp=(dsqrt(bpm)*rp1/(rp1+rp2)+b0*cos(phi))**2+(b0*sin(phi))**2
8591 bbi=(dsqrt(bpm)*rp2/(rp1+rp2)-b0*cos(phi))**2+(b0*sin(phi))**2
8592 call qgbdef(bbp,bbi,xa(ipp,1)+b,xa(ipp,2),xxm(m),yym(m)
8593 *,xxm(m+1),yym(m+1),int(1.5d0+qgran(b10))) !coordinates for the vertex
8594
8595 call qgfdf(xxm(m+1),yym(m+1),xpomm(m+1),vpac,vtac
8596 *,vvx,vvxp,vvxt,vvxpl,vvxtl,ipp,it)
8597 vvxts=1.d0-(1.d0-vvx)*(1.d0-vvxt)*exp(-vtac(it))
8598 viu=qgpini(xpomm(m+1)/xpomm(m),bbi,0.d0,0.d0,2)
8599 vim=2.d0*min(viu,qgpini(xpomm(m+1)/xpomm(m),bbi,0.d0,0.d0,8))
8600 if(itypom.eq.-1.or.itypom.eq.4)then !single cut Pomeron at the end
8601 vvxi=1.d0-((1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxt))**2
8602 * *exp(-2.d0*vpac(ipp)-2.d0*vtac(it))
8603 vip=qgpini(xpomm(m+1)/xpomm(m),bbi,vvxi,0.d0,16)*exp(-vim)
8604 elseif(itypom.eq.2.or.itypom.eq.7)then !>1 cut Poms at the end
8605 vimp=max(0.d0,1.d0-exp(-vim)*(1.d0+vim))
8606 else !rap-gap
8607 vvxpin=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ipp))
8608 vvxtin=1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8609 viuu=qgpini(xpomm(m+1)/xpomm(m),bbi,vvxpin,vvxtin,20)
8610 * *(1.d0-exp(-viu))
8611 viuc=max(0.d0,viuu-qgpini(xpomm(m+1)/xpomm(m),bbi
8612 * ,vvxpin,vvxtin,21)*(1.d0-exp(-viu)))
8613 vicc=qgpini(xpomm(m+1)/xpomm(m),bbi,vvxpin,vvxtin,22)*.5d0
8614 * *((1.d0-exp(-viu))**2+(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))
8615 vicu=max(0.d0,qgpini(xpomm(m+1)/xpomm(m),bbi,vvxpin,vvxtin,23)
8616 * *((1.d0-exp(-viu))**2+(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))
8617 * /2.d0-vicc)
8618 endif
8619
8620 if(itypom.le.3)then
8621 sumup=0.d0
8622 vvxp0=0.d0
8623 do i=1,ia(1)
8624 sumup=sumup+vpac(i)
8625 enddo
8626 vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8627 do i=1,ia(1)-ipp+1
8628 ipi=ia(1)-i+1
8629 bbl=(xa(ipi,1)+b-xxm(m+1))**2+(xa(ipi,2)-yym(m+1))**2
8630 sumup=sumup-vpac(ipi)
8631 vpac0(ipi)=min(vpac(ipi)
8632 * ,qgfani(1.d0/xpomm(m+1),bbl,1.d0-vvxs*exp(-sumup)
8633 * ,1.d0-exp(-vvxp0),1.d0-exp(-sumup),iddp(ipi),icz,3))
8634 if(ipi.gt.ipp)vvxp0=vvxp0+vpac0(ipi)
8635 enddo
8636 vvxp0=1.d0-exp(-vvxp0)
8637
8638 vpacng=min(vpac0(ipp)
8639 * ,qgfani(1.d0/xpomm(m+1),bbp,vvxts,vvxp0,vvxpl,iddp(ipp),icz,4))
8640 vpacpe=min(vpacng
8641 * ,qgfani(1.d0/xpomm(m+1),bbp,vvxts,vvxp0,vvxpl,iddp(ipp),icz,5))
8642 else
8643 vplc=qgfani(1.d0/xpomm(m+1),bbp,vvxts,vvxp,vvxpl,iddp(ipp)
8644 * ,icz,7)
8645 vplc0=min(vplc
8646 * ,qgfani(1.d0/xpomm(m+1),bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,8))
8647 vplcng=min(vplc0
8648 * ,qgfani(1.d0/xpomm(m+1),bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,11))
8649 vplcpe=min(vplcng
8650 * ,qgfani(1.d0/xpomm(m+1),bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,10))
8651 endif
8652
8653 if(itypom.eq.-1)then !'fan' (single cut Pomeron at the end)
8654 gb=vip*((max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
8655 * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
8656 * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
8657 * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8658 * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8659 * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
8660 * +((1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
8661 * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl)
8662 * +2.d0*((vpac0(ipp)-vpacpe)*exp(-vpac(ipp))*(1.d0-vvxp)
8663 * *(1.d0-vvxpl)-(vpac(ipp)-vpac0(ipp))*(1.d0-exp(-vpac(ipp))
8664 * *(1.d0-vvxp)*(1.d0-vvxpl)))*exp(-vpac(ipp))*(1.d0-vvxp))
8665 * *(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)*exp(-2.d0*vtac(it))
8666 elseif(itypom.eq.0)then !'fan' (cut loop at the end - rapgap)
8667 gb=((max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
8668 * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
8669 * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
8670 * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8671 * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8672 * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
8673 * +((1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
8674 * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl)
8675 * +2.d0*vpacng*exp(-2.d0*vpac(ipp))*(1.d0-vvxp)**2*(1.d0-vvxpl))
8676 * *(vicc*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8677 * -vicu*(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))))
8678 * *(1.d0-vvx)*(1.d0-vvxt)*exp(-vtac(it))
8679 * -2.d0*vicu*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8680 * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8681 * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp)-vtac(it))
8682 * *(1.d0-vvx)*(1.d0-vvxt)
8683 elseif(itypom.eq.1)then !'fan' (uncut end - rapgap)
8684 gb=((max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
8685 * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
8686 * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
8687 * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8688 * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8689 * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
8690 * +((1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
8691 * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl)
8692 * +2.d0*vpacng*exp(-2.d0*vpac(ipp))*(1.d0-vvxp)**2*(1.d0-vvxpl))
8693 * *(viuc*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8694 * +viuu*(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))))
8695 * *(1.d0-vvx)*(1.d0-vvxt)*exp(-vtac(it))
8696 * +2.d0*viuu*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8697 * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8698 * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp)-vtac(it))
8699 * *(1.d0-vvx)*(1.d0-vvxt)
8700 elseif(itypom.eq.2)then !'fan' (>1 cut Poms at the end)
8701 gb=vimp*((max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
8702 * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
8703 * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
8704 * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8705 * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8706 * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
8707 * +((1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
8708 * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl)
8709 * +2.d0*(vpac0(ipp)*exp(-vpac(ipp))*(1.d0-vvxp)
8710 * *(1.d0-vvxpl)-(vpac(ipp)-vpac0(ipp))*(1.d0-exp(-vpac(ipp))
8711 * *(1.d0-vvxp)*(1.d0-vvxpl)))*exp(-vpac(ipp))*(1.d0-vvxp))
8712 * *(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)*exp(-2.d0*vtac(it))
8713 elseif(itypom.eq.3)then !'fan' (cut/uncut end - rapgap)
8714 gb=((max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
8715 * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
8716 * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
8717 * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8718 * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8719 * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
8720 * +((1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
8721 * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl)
8722 * +2.d0*vpacng*exp(-2.d0*vpac(ipp))*(1.d0-vvxp)**2*(1.d0-vvxpl))
8723 * *((vicc-wgpm(m)*viuc)*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8724 * -(vicu+wgpm(m)*viuu)*(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)
8725 * *exp(-vtac(it))))*(1.d0-vvx)*(1.d0-vvxt)*exp(-vtac(it))
8726 * -2.d0*(vicu+wgpm(m)*viuu)*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))
8727 * -1.d0-(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8728 * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp)-vtac(it))
8729 * *(1.d0-vvx)*(1.d0-vvxt)
8730 elseif(itypom.eq.4)then !'leg' (single cut Pomeron at the end)
8731 gb=vip*((vplc0-vplcpe)*exp(-vpac(ipp))*(1.d0-vvxp)
8732 * *(1.d0-vvxpl)-(vplc-vplc0)*(1.d0-exp(-vpac(ipp))*(1.d0-vvxp)
8733 * *(1.d0-vvxpl)))*exp(-vpac(ipp)-2.d0*vtac(it))*(1.d0-vvxp)
8734 * *(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)
8735 elseif(itypom.eq.5)then !'leg' (cut/uncut end - rapgap)
8736 gb=vplcng*exp(-2.d0*vpac(ipp)-vtac(it))
8737 * *(1.d0-vvxp)**2*(1.d0-vvxpl)*(1.d0-vvx)*(1.d0-vvxt)
8738 * *((vicc-wgpm(m)*viuc)*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8739 * -(vicu+wgpm(m)*viuu)*(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)
8740 * *exp(-vtac(it))))
8741 elseif(itypom.eq.7)then !'leg' (>1 cut Poms at the end)
8742 gb=vimp*(vplc0*exp(-vpac(ipp))*(1.d0-vvxp)*(1.d0-vvxpl)
8743 * -(vplc-vplc0)*(1.d0-exp(-vpac(ipp))*(1.d0-vvxp)*(1.d0-vvxpl)))
8744 * *exp(-vpac(ipp)-2.d0*vtac(it))*(1.d0-vvxp)
8745 * *(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)
8746 endif
8747 gb=gb/gb0/z*rp/rp0 /10.d0
8748 nrej=nrej+1
8749 if(qgran(b10).gt.gb.and.nrej.le.1000)goto 11
8750
8751 if(itypom.eq.-1.or.itypom.eq.4)then !'single cut Pomeron in the handle
8752 npin=npin+1
8753 if(npin.gt.npmax)then
8754 iret=1
8755 goto 31
8756 endif
8757 xpomim(npin)=1.d0/xpomm(m)/scm
8758 xpomip(npin)=xpomm(m+1)
8759 vvxim(npin)=vvxi
8760 bpomim(npin)=bbi
8761 if(debug.ge.4)write (moniou,211)npin,xpomip(npin),xpomim(npin)
8762 * ,vvxim(npin),bpomim(npin)
8763 elseif(itypom.eq.2.or.itypom.eq.7)then !>1 cut Pomerons in the handle
8764 ninc=npgen(vim,2,20)
8765 npin=npin+ninc
8766 if(npin.gt.npmax)then
8767 iret=1
8768 goto 31
8769 endif
8770 do i=npin-ninc+1,npin
8771 xpomim(i)=1.d0/xpomm(m)/scm
8772 xpomip(i)=xpomm(m+1)
8773 vvxim(i)=0.d0
8774 bpomim(i)=bbi
8775 if(debug.ge.4)write (moniou,211)i,xpomip(i),xpomim(i)
8776 * ,vvxim(i),bpomim(i)
8777 enddo
8778 endif
8779
8780 if(itypom.eq.-1)then !single cut Pomeron in the 'handle'
8781 vv1=(max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
8782 * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
8783 * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
8784 * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8785 * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8786 * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
8787 vv2=(1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
8788 * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl
8789 vv3=2.d0*((vpac0(ipp)-vpacpe)*exp(-vpac(ipp))*(1.d0-vvxp)
8790 * *(1.d0-vvxpl)-(vpac(ipp)-vpac0(ipp))*(1.d0-exp(-vpac(ipp))
8791 * *(1.d0-vvxp)*(1.d0-vvxpl)))*exp(-vpac(ipp))*(1.d0-vvxp)
8792 if(xpomm(m+1)*sgap**2.gt..9d0.or.vv3.lt.0.d0)vv3=0.d0
8793 aks=(vv1+vv2+vv3)*qgran(b10)
8794 if(aks.lt.vv1)then
8795 jt=1 !>1 cut fans
8796 elseif(aks.lt.vv1+vv2)then
8797 jt=2 !diffr. cut
8798 else
8799 jt=3 !1 cut fan
8800 endif
8801 elseif(itypom.eq.0)then !cut 'loop' in the 'handle' (rap-gap)
8802 vv1=(max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
8803 * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
8804 * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
8805 * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8806 * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8807 * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp)-vtac(it))
8808 * *(1.d0-vvxt)*(1.d0-vvxtl)*(vicc+vicu)
8809 * /(vicc*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8810 * -vicu*(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))))
8811 vv2=(1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
8812 * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl
8813 vv3=2.d0*vpacng*exp(-2.d0*vpac(ipp))*(1.d0-vvxp)**2*(1.d0-vvxpl)
8814 aks=(vv1+vv2+vv3)*qgran(b10)
8815 if(aks.lt.vv1)then
8816 jt=1 !>1 cut fans
8817 elseif(aks.lt.vv1+vv2)then
8818 jt=2 !diffr. cut
8819 else
8820 jt=3 !1 cut fan
8821 endif
8822 elseif(itypom.eq.1)then !uncut 'handle' (rap-gap)
8823 vv1=(max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
8824 * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
8825 * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
8826 * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8827 * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8828 * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
8829 vv2=(1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
8830 * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl
8831 vv3=2.d0*vpacng*exp(-2.d0*vpac(ipp))*(1.d0-vvxp)**2*(1.d0-vvxpl)
8832 vv4=2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0-(vpac(ipp)
8833 * -vpac0(ipp)))*(1.d0-vvxp0)+(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))
8834 * *exp(-vpac(ipp))*viuu/(viuu*(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)
8835 * *exp(-vtac(it)))+viuc*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it)))
8836 if(xpomm(m+1)*sgap**2.gt..9d0.or.vv4.lt.0.d0)vv4=0.d0
8837 aks=(vv1+vv2+vv3+vv4)*qgran(b10)
8838 if(aks.lt.vv1)then
8839 jt=1 !>1 cut fans
8840 elseif(aks.lt.vv1+vv2)then
8841 jt=2 !diffr. cut
8842 elseif(aks.lt.vv1+vv2+vv3)then
8843 jt=3 !1 cut fan
8844 else
8845 jt=4 !>1 cut 'handle' fans
8846 endif
8847 elseif(itypom.eq.2)then !>1 cut Pomerons in the 'handle'
8848 vv1=(max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
8849 * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
8850 * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
8851 * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8852 * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8853 * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
8854 vv2=(1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
8855 * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl
8856 vv3=2.d0*(vpac0(ipp)*exp(-vpac(ipp))*(1.d0-vvxp)
8857 * *(1.d0-vvxpl)-(vpac(ipp)-vpac0(ipp))*(1.d0-exp(-vpac(ipp))
8858 * *(1.d0-vvxp)*(1.d0-vvxpl)))*exp(-vpac(ipp))*(1.d0-vvxp)
8859 aks=(vv1+vv2+vv3)*qgran(b10)
8860 if(aks.lt.vv1)then
8861 jt=1 !>1 cut fans
8862 elseif(aks.lt.vv1+vv2)then
8863 jt=2 !diffr. cut
8864 else
8865 jt=3 !1 cut fan
8866 endif
8867
8868 elseif(itypom.eq.3)then !rap-gap in the 'handle'
8869 vv1=(max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
8870 * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
8871 * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
8872 * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8873 * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8874 * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))
8875 * *exp(-vpac(ipp)-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
8876 * *(vicc+vicu+wgpm(m)*(viuu-viuc))
8877 * /((vicc-wgpm(m)*viuc)*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8878 * -(vicu+wgpm(m)*viuu)*(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)
8879 * *exp(-vtac(it))))
8880 vv2=(1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
8881 * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl
8882 vv3=2.d0*vpacng*exp(-2.d0*vpac(ipp))*(1.d0-vvxp)**2
8883 * *(1.d0-vvxpl)
8884 aks=(vv1+vv2+vv3)*qgran(b10)
8885 if(aks.lt.vv1)then
8886 jt=1 !>1 cut fans
8887 elseif(aks.lt.vv1+vv2)then
8888 jt=2 !diffr. cut
8889 else
8890 jt=3 !1 cut fan
8891 endif
8892 else
8893 jt=5 !cut leg
8894 endif
8895
8896 nppm(m+1)=0
8897 wgpm(m+1)=0.d0
8898 if(jt.eq.1)then !>1 cut fans
8899 ntry=0
8900 12 ntry=ntry+1
8901 nphm=0
8902 if(ipp.eq.ia(1).or.ntry.gt.100)then
8903 nppm(m+1)=npgen(2.d0*vpac(ipp),2,20)
8904 do i=1,nppm(m+1)
8905 if(qgran(b10).le.vpac0(ipp)/vpac(ipp)
8906 * .or.xpomm(m+1)*sgap**2.gt..9d0)then
8907 itypm(i,m+1)=0
8908 else
8909 itypm(i,m+1)=1
8910 nphm=nphm+1
8911 endif
8912 ippm(i,m+1)=ipp
8913 enddo
8914 wh=(vpac(ipp)/vpac0(ipp)-1.d0)/nppm(m+1)
8915 else
8916 nppm(m+1)=npgen(2.d0*vpac(ipp),1,20)
8917 do i=1,nppm(m+1)
8918 if(qgran(b10).le.vpac0(ipp)/vpac(ipp)
8919 * .or.xpomm(m+1)*sgap**2.gt..9d0)then
8920 itypm(i,m+1)=0
8921 else
8922 itypm(i,m+1)=1
8923 nphm=nphm+1
8924 endif
8925 ippm(i,m+1)=ipp
8926 enddo
8927 wh=(vpac(ipp)/vpac0(ipp)-1.d0)/nppm(m+1)
8928 do ipi=ipp+1,ia(1)
8929 ninc=npgen(2.d0*vpac(ipi),0,20)
8930 if(ninc.ne.0)then
8931 nppm(m+1)=nppm(m+1)+ninc
8932 nh0=nphm
8933 if(nppm(m+1).gt.legmax)then
8934 iret=1
8935 goto 31
8936 endif
8937 do i=nppm(m+1)-ninc+1,nppm(m+1)
8938 if(qgran(b10).le.vpac0(ipi)/vpac(ipi)
8939 * .or.xpomm(m+1)*sgap**2.gt..9d0)then
8940 itypm(i,m+1)=0
8941 else
8942 itypm(i,m+1)=1
8943 nphm=nphm+1
8944 endif
8945 ippm(i,m+1)=ipi
8946 enddo
8947 if(ninc.gt.nphm-nh0)wh=(vpac(ipi)/vpac0(ipi)-1.d0)/ninc
8948 endif
8949 enddo
8950 if(nppm(m+1).eq.1)goto 12
8951 endif
8952
8953 if(nphm+1.ge.nppm(m+1))then
8954 if(itypom.eq.-1.or.itypom.eq.1.or.itypom.eq.2)then
8955 gbt=1.d0-exp(vpac(ipp)+(1.d0-nphm)*dlog(2.d0))
8956 * /(1.d0-vvxp)/(1.d0-vvxpl)
8957 elseif(itypom.eq.0)then
8958 gbt=1.d0-(vicc+vicu)*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8959 * /(vicc*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8960 * -vicu*(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))))
8961 * *exp(vpac(ipp)+(1.d0-nphm)*dlog(2.d0))
8962 * /(1.d0-vvxp)/(1.d0-vvxpl)
8963 elseif(itypom.eq.3)then
8964 gbt=1.d0-(vicc+vicu+wgpm(m)*(viuu-viuc))
8965 * *(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8966 * /((vicc-wgpm(m)*viuc)*(1.d0-vvxt)*(1.d0-vvxtl)
8967 * *exp(-vtac(it))-(vicu+wgpm(m)*viuu)
8968 * *(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))))
8969 * *exp(vpac(ipp)+(1.d0-nphm)*dlog(2.d0))
8970 * /(1.d0-vvxp)/(1.d0-vvxpl)
8971 else
8972 stop'unknown itypom'
8973 endif
8974 if(nphm.eq.nppm(m+1).and.qgran(b10).gt.gbt
8975 * .or.nphm+1.eq.nppm(m+1).and.qgran(b10).gt.1.d0+wh*gbt)then
8976 ntry=0
8977 goto 12
8978 endif
8979 endif
8980
8981 elseif(jt.eq.4)then !>1 cut 'handle' fans
8982 ntry=0
8983 14 ntry=ntry+1
8984 if(ipp.eq.ia(1).or.ntry.gt.100)then
8985 nppm(m+1)=npgen(vpac(ipp)-vpac0(ipp),2,20)
8986 do i=1,nppm(m+1)
8987 itypm(i,m+1)=1
8988 ippm(i,m+1)=ipp
8989 enddo
8990 else
8991 nppm(m+1)=npgen(vpac(ipp)-vpac0(ipp),1,20)
8992 do i=1,nppm(m+1)
8993 itypm(i,m+1)=1
8994 ippm(i,m+1)=ipp
8995 enddo
8996 do ipi=ipp+1,ia(1)
8997 ninc=npgen(vpac(ipi)-vpac0(ipi),0,20)
8998 if(ninc.ne.0)then
8999 nppm(m+1)=nppm(m+1)+ninc
9000 if(nppm(m+1).gt.legmax)then
9001 iret=1
9002 goto 31
9003 endif
9004 do i=nppm(m+1)-ninc+1,nppm(m+1)
9005 itypm(i,m+1)=1
9006 ippm(i,m+1)=ipi
9007 enddo
9008 endif
9009 enddo
9010 if(nppm(m+1).eq.1)goto 14
9011 endif
9012
9013 elseif(jt.eq.3)then !1 cut fan
9014 nppm(m+1)=1
9015 ippm(1,m+1)=ipp
9016 if(itypom.eq.-1)then !single cut Pomeron in the 'handle'
9017 factor=exp(-vpac(ipp))*(1.d0-vvxp)*(1.d0-vvxpl)
9018 wng=(vpacng-vpacpe)*factor/((vpac0(ipp)-vpacpe)*factor
9019 * -(vpac(ipp)-vpac0(ipp))*(1.d0-factor))
9020 if(qgran(b10).le.wng.or.wng.lt.0.d0
9021 * .or.xpomm(m+1)*sgap**2.gt..9d0)then
9022 itypm(1,m+1)=2 !>1 cut Pomerons in the 'handle'
9023 else
9024 itypm(1,m+1)=3 !rap-gap in the 'handle'
9025 wgpm(m+1)=(1.d0-factor)/factor
9026 endif
9027 elseif(itypom.eq.2)then !>1 cut Pomerons in the 'handle'
9028 factor=exp(-vpac(ipp))*(1.d0-vvxp)*(1.d0-vvxpl)
9029 wng=vpacng*factor/(vpac0(ipp)*factor
9030 * -(vpac(ipp)-vpac0(ipp))*(1.d0-factor))
9031 if(qgran(b10).le.wng.or.wng.lt.0.d0
9032 * .or.xpomm(m+1)*sgap**2.gt..9d0)then
9033 if(qgran(b10).le.vpacpe/vpacng
9034 * .or.xpomm(m+1)*sgap**2.gt..9d0)then
9035 itypm(1,m+1)=-1 !single cut Pomeron in the 'handle'
9036 else
9037 itypm(1,m+1)=2 !>1 cut Pomerons in the 'handle'
9038 endif
9039 else
9040 itypm(1,m+1)=3 !rap-gap in the 'handle'
9041 wgpm(m+1)=(1.d0-factor)/factor
9042 endif
9043 else !rap-gap in the 'handle'
9044 if(qgran(b10).le.vpacpe/vpacng
9045 * .or.xpomm(m+1)*sgap**2.gt..9d0)then
9046 itypm(1,m+1)=-1 !single cut Pomeron in the 'handle'
9047 else
9048 itypm(1,m+1)=2 !>1 cut Pomerons in the 'handle'
9049 endif
9050 endif
9051
9052 if(itypm(1,m+1).eq.-1)then !single cut Pomeron in the 'handle'
9053 vplcp=min(vpacpe
9054 * ,qgfani(1.d0/xpomm(m+1),bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,9))
9055 if(qgran(b10).le.vplcp/vpacpe
9056 * .or.xpomm(m+1)*sgap**2.gt..9d0)itypm(1,m+1)=6 !single cut Pomeron
9057 endif
9058
9059 elseif(jt.eq.5)then !cut 'leg'
9060 nppm(m+1)=1
9061 ippm(1,m+1)=ipp
9062 if(itypom.eq.4)then !single cut Pomeron at the end
9063 if(xpomm(m+1)*sgap**2.ge.1.d0)stop'=4:xpomm(m+1)*sgap**2>1'
9064 factor=exp(-vpac(ipp))*(1.d0-vvxp)*(1.d0-vvxpl)
9065 wng=(vplcng-vplcpe)*factor/((vplc0-vplcpe)*factor
9066 * -(vplc-vplc0)*(1.d0-factor))
9067 if(qgran(b10).le.wng.or.wng.lt.0.d0)then
9068 itypm(1,m+1)=7 !>1 cut Pomerons at the end
9069 else
9070 itypm(1,m+1)=5 !rap-gap at the end
9071 wgpm(m+1)=(1.d0-factor)/factor
9072 endif
9073 elseif(itypom.eq.5)then !rap-gap at the end (cut or uncut loop)
9074 if(qgran(b10).le.vplcpe/vplcng
9075 * .or.xpomm(m+1)*sgap**2.gt..9d0)then
9076 itypm(1,m+1)=4 !single cut Pomeron at the end
9077 else
9078 itypm(1,m+1)=7 !>1 cut Pomerons at the end
9079 endif
9080 elseif(itypom.eq.7)then !>1 cut Pomerons at the end
9081 factor=exp(-vpac(ipp))*(1.d0-vvxp)*(1.d0-vvxpl)
9082 wng=vplcng*factor/(vplc0*factor-(vplc-vplc0)*(1.d0-factor))
9083 if(qgran(b10).le.wng.or.wng.lt.0.d0
9084 * .or.xpomm(m+1)*sgap**2.gt..9d0)then
9085 if(qgran(b10).le.vplcpe/vplcng
9086 * .or.xpomm(m+1)*sgap**2.gt..9d0)then
9087 itypm(1,m+1)=4 !single cut Pomeron at the end
9088 else
9089 itypm(1,m+1)=7 !>1 cut Pomerons at the end
9090 endif
9091 else
9092 itypm(1,m+1)=5 !rap-gap at the end
9093 wgpm(m+1)=(1.d0-factor)/factor
9094 endif
9095 endif
9096
9097 if(itypm(1,m+1).eq.4)then !single cut Pomeron at the end
9098 vplcp=min(vplcpe
9099 * ,qgfani(1.d0/xpomm(m+1),bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,9))
9100 if(qgran(b10).le.vplcp/vplcpe
9101 * .or.xpomm(m+1)*sgap**3.gt..9d0)itypm(1,m+1)=6 !single cut Pomeron
9102 endif
9103 endif
9104
9105 if(nppm(m+1).eq.1.and.itypm(1,m+1).eq.6)then !record single cut Pomeron
9106 nppr=nppr+1
9107 if(nppr.gt.legmax)then
9108 iret=1
9109 goto 31
9110 endif
9111 xpompi(nppr)=xpomm(m+1)
9112 vvxpi(nppr)=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*(1.d0-vvxt)
9113 * *(1.d0-vvxtl)*exp(-vtac(it))
9114 ipompi(nppr)=ipp
9115 bpompi(nppr)=bbp
9116 nppm(m+1)=0
9117 if(debug.ge.4)write (moniou,209)nppr,ipp,bbp,xpompi(nppr)
9118 * ,vvxpi(nppr)
9119
9120 elseif(nppm(m+1).gt.1)then
9121 i=0
9122 15 i=i+1
9123 ityp=itypm(i,m+1)
9124 if(ityp.eq.0)then
9125 ipi=ippm(i,m+1)
9126 bbi=(xa(ipi,1)+b-xxm(m+1))**2+(xa(ipi,2)-yym(m+1))**2
9127 vvxp=0.d0
9128 vvxpl=0.d0
9129 vvxp0=0.d0
9130 if(ia(1).gt.1)then
9131 do l=1,ia(1)
9132 if(l.lt.ipi)then
9133 vvxpl=vvxpl+vpac(l)
9134 elseif(l.gt.ipi)then
9135 vvxp=vvxp+vpac(l)
9136 vvxp0=vvxp0+vpac0(l)
9137 endif
9138 enddo
9139 endif
9140 vvxp=1.d0-exp(-vvxp)
9141 vvxpl=1.d0-exp(-vvxpl)
9142 vvxp0=1.d0-exp(-vvxp0)
9143
9144 vpacng=min(vpac0(ipi)
9145 * ,qgfani(1.d0/xpomm(m+1),bbi,vvxts,vvxp0,vvxpl,iddp(ipi),icz,4))
9146 vpacpe=min(vpacng
9147 * ,qgfani(1.d0/xpomm(m+1),bbi,vvxts,vvxp0,vvxpl,iddp(ipi),icz,5))
9148 vplcp=min(vpacpe
9149 * ,qgfani(1.d0/xpomm(m+1),bbi,vvxts,vvxp,vvxpl,iddp(ipi),icz,9))
9150
9151 aks=qgran(b10)*vpac0(ipi)
9152 if(aks.le.vplcp.or.xpomm(m+1)*sgap**2.gt..9d0)then
9153 itypm(i,m+1)=6 !single cut Pomeron
9154 elseif(aks.lt.vpacpe)then
9155 itypm(i,m+1)=-1 !single cut Pomeron in the 'handle'
9156 elseif(aks.lt.vpacng)then
9157 itypm(i,m+1)=2 !>1 cut Pomerons in the 'handle'
9158 endif
9159
9160 if(itypm(i,m+1).eq.6)then !record single cut Pomeron
9161 nppr=nppr+1
9162 if(nppr.gt.legmax)then
9163 iret=1
9164 goto 31
9165 endif
9166 xpompi(nppr)=xpomm(m+1)
9167 vvxpi(nppr)=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*(1.d0-vvxt)
9168 * *(1.d0-vvxtl)*exp(-vtac(it))
9169 ipompi(nppr)=ipi
9170 bpompi(nppr)=bbi
9171 if(debug.ge.4)write (moniou,209)nppr,ipi,bbi,xpompi(nppr)
9172 * ,vvxpi(nppr)
9173 nppm(m+1)=nppm(m+1)-1
9174 if(nppm(m+1).ge.i)then
9175 do l=i,nppm(m+1)
9176 ippm(l,m+1)=ippm(l+1,m+1)
9177 itypm(l,m+1)=itypm(l+1,m+1)
9178 enddo
9179 endif
9180 i=i-1
9181 endif
9182 endif
9183 if(i.lt.nppm(m+1))goto 15
9184 endif
9185
9186 if(jt.eq.2.and.qgran(b10).lt.(1.d0-exp(-vpac(ipp)))*(1.d0-vvxpl)
9187 */((1.d0-exp(-vpac(ipp)))*(1.d0-vvxpl)+2.d0*vvxpl))then
9188 if(debug.ge.4)write (moniou,212)
9189 icdps=iddp(ipp)
9190 do icdp=1,2
9191 iddp(ipp)=icdp
9192 call qgfdf(xxm(m+1),yym(m+1),xpomm(m+1),vpac,vtac
9193 * ,vvx,vvxp,vvxt,vvxpl,vvxtl,ipp,it)
9194 wdp(icdp,ipp)=(1.d0-exp(-vpac(ipp)))*(1.d0-vvxpl)
9195 enddo
9196 iddp(ipp)=icdps
9197 endif
9198
9199 if(nppm(m+1).ne.0)then
9200 goto 9
9201 else
9202 goto 10
9203 endif
9204
9205 20 continue
9206 if(debug.ge.3)write (moniou,214)nppr
9207 if(nptg0.eq.0)goto 31
9208
9209 c target 'fans'
9210 m=0
9211 nppm(1)=nptg0
9212 xpomm(1)=xpomr
9213 wgpm(1)=wgtg0
9214 xxm(1)=xxp
9215 yym(1)=yyp
9216 do i=1,nptg0
9217 ippm(i,1)=iptg0(i)
9218 itypm(i,1)=itytg0(i)
9219 enddo
9220
9221 21 m=m+1 !next level multi-Pomeron vertex
9222 if(m.gt.levmax)then
9223 iret=1
9224 goto 31
9225 endif
9226 ii(m)=0
9227 22 ii(m)=ii(m)+1 !next cut fan in the vertex
9228 if(ii(m).gt.nppm(m))then !all fans at the level considered
9229 m=m-1 !one level down
9230 if(m.eq.0)goto 31 !all targ. fans considered
9231 goto 22
9232 endif
9233 l=ii(m)
9234 itt=ippm(l,m) !targ. index for the leg
9235 itypom=itypm(l,m) !type of the cut
9236 btm=(xb(itt,1)-xxm(m))**2+(xb(itt,2)-yym(m))**2 !b^2 for the leg
9237 if(debug.ge.4)write (moniou,216)ii(m),m,itt,btm
9238 if(xpomm(m)*scm.lt.sgap**2)stop'xpomm(m)*scm<sgap**2!'
9239
9240 if(debug.ge.4)write (moniou,210)m
9241 xpomr0=min(dsqrt(xpomm(m)/scm),xpomm(m)/sgap)
9242 xpomr0=max(xpomr0,sgap/scm)
9243 if(itypom.eq.4)xpomr0=max(xpomr0,dsqrt(xpomm(m)*sgap/scm))
9244 rp1=(rq(iddt(itt),2)+alfp*dlog(xpomr0*scm))*4.d0*.0389d0
9245 rp2=alfp*dlog(xpomm(m)/xpomr0)*4.d0*.0389d0
9246 rp0=rp1*rp2/(rp1+rp2)
9247 bbt=btm*(rp1/(rp1+rp2))**2
9248 bbi=btm*(rp2/(rp1+rp2))**2
9249 call qgbdef(bbt,bbi,xb(itt,1),xb(itt,2),xxm(m),yym(m)
9250 *,xxp0,yyp0,1)
9251
9252 call qgfdf(xxp0,yyp0,xpomr0,vpac,vtac
9253 *,vvx,vvxp,vvxt,vvxpl,vvxtl,ip,itt)
9254 vvxps=1.d0-(1.d0-vvx)*(1.d0-vvxp)*exp(-vpac(ip))
9255 viu=qgpini(xpomm(m)/xpomr0,bbi,0.d0,0.d0,2)
9256 vim=2.d0*min(viu,qgpini(xpomm(m)/xpomr0,bbi,0.d0,0.d0,8))
9257 if(itypom.eq.-1.or.itypom.eq.4)then !single cut Pomeron at the end
9258 vvxi=1.d0-((1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxt))**2
9259 * *exp(-2.d0*vpac(ip)-2.d0*vtac(itt))
9260 vip=qgpini(xpomm(m)/xpomr0,bbi,vvxi,0.d0,16)*exp(-vim)
9261 elseif(itypom.eq.2.or.itypom.eq.7)then !>1 cut Pomerons at the end
9262 vimp=max(0.d0,1.d0-exp(-vim)*(1.d0+vim))
9263 else !rap-gap at the end
9264 vvxpin=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9265 vvxtin=1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(itt))
9266 viuu=qgpini(xpomm(m)/xpomr0,bbi,vvxtin,vvxpin,20)
9267 * *(1.d0-exp(-viu))
9268 viuc=max(0.d0,viuu-qgpini(xpomm(m)/xpomr0,bbi
9269 * ,vvxtin,vvxpin,21)*(1.d0-exp(-viu)))
9270 vicc=qgpini(xpomm(m)/xpomr0,bbi,vvxtin,vvxpin,22)*.5d0
9271 * *((1.d0-exp(-viu))**2+(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))
9272 vicu=max(0.d0,qgpini(xpomm(m)/xpomr0,bbi,vvxtin,vvxpin,23)*.5d0
9273 * *((1.d0-exp(-viu))**2+(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))
9274 * -vicc)
9275 endif
9276
9277 if(itypom.le.3)then !cut 'fan'
9278 sumut=0.d0
9279 vvxt0=0.d0
9280 do i=1,ia(2)
9281 sumut=sumut+vtac(i)
9282 enddo
9283 vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9284 do i=1,ia(2)-itt+1
9285 iti=ia(2)-i+1
9286 bbl=(xb(iti,1)-xxp0)**2+(xb(iti,2)-yyp0)**2
9287 sumut=sumut-vtac(iti)
9288 vtac0(iti)=min(vtac(iti)
9289 * ,qgfani(xpomr0*scm,bbl,1.d0-vvxs*exp(-sumut)
9290 * ,1.d0-exp(-vvxt0),1.d0-exp(-sumut),iddt(iti),2,3))
9291 if(iti.gt.itt)vvxt0=vvxt0+vtac0(iti)
9292 enddo
9293 vvxt0=1.d0-exp(-vvxt0)
9294 vtacng=min(vtac0(itt)
9295 * ,qgfani(xpomr0*scm,bbt,vvxps,vvxt0,vvxtl,iddt(itt),2,4))
9296 vtacpe=min(vtacng
9297 * ,qgfani(xpomr0*scm,bbt,vvxps,vvxt0,vvxtl,iddt(itt),2,5))
9298 else !cut 'leg'
9299 vtlc=qgfani(xpomr0*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,7)
9300 vtlc0=min(vtlc
9301 * ,qgfani(xpomr0*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,8))
9302 vtlcng=min(vtlc0
9303 * ,qgfani(xpomr0*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,11))
9304 vtlcpe=min(vtlcng
9305 * ,qgfani(xpomr0*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,10))
9306 endif
9307
9308 if(itypom.eq.-1)then !'fan' (single cut Pomeron at the end)
9309 gb0=vip*((max(0.d0,1.d0-exp(-2.d0*vtac(itt))
9310 * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
9311 * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
9312 * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9313 * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9314 * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
9315 * +((1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
9316 * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl)
9317 * +2.d0*((vtac0(itt)-vtacpe)*exp(-vtac(itt))*(1.d0-vvxt)
9318 * *(1.d0-vvxtl)-(vtac(itt)-vtac0(itt))*(1.d0-exp(-vtac(itt))
9319 * *(1.d0-vvxt)*(1.d0-vvxtl)))*exp(-vtac(itt))*(1.d0-vvxt))
9320 * *(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)*exp(-2.d0*vpac(ip))
9321 gb0=gb0*40.d0
9322 elseif(itypom.eq.0)then !'fan' (cut loop at the end - rapgap)
9323 gb0=((max(0.d0,1.d0-exp(-2.d0*vtac(itt))
9324 * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
9325 * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
9326 * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9327 * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9328 * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
9329 * +((1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
9330 * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl)
9331 * +2.d0*vtacng*exp(-2.d0*vtac(itt))*(1.d0-vvxt)**2*(1.d0-vvxtl))
9332 * *(vicc*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9333 * -vicu*(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))))
9334 * *(1.d0-vvx)*(1.d0-vvxp)*exp(-vpac(ip))
9335 * -2.d0*vicu*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9336 * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9337 * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt)-vpac(ip))
9338 * *(1.d0-vvx)*(1.d0-vvxp)
9339 elseif(itypom.eq.1)then !'fan' (uncut end - rapgap)
9340 gb0=((max(0.d0,1.d0-exp(-2.d0*vtac(itt))
9341 * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
9342 * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
9343 * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9344 * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9345 * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
9346 * +((1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
9347 * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl)
9348 * +2.d0*vtacng*exp(-2.d0*vtac(itt))*(1.d0-vvxt)**2*(1.d0-vvxtl))
9349 * *(viuc*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9350 * +viuu*(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))))
9351 * *(1.d0-vvx)*(1.d0-vvxp)*exp(-vpac(ip))
9352 * +2.d0*viuu*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9353 * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9354 * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt)-vpac(ip))
9355 * *(1.d0-vvx)*(1.d0-vvxp)
9356 elseif(itypom.eq.2)then !'fan' (>1 cut Poms at the end)
9357 gb0=vimp*((max(0.d0,1.d0-exp(-2.d0*vtac(itt))
9358 * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
9359 * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
9360 * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9361 * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9362 * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
9363 * +((1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
9364 * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl)
9365 * +2.d0*(vtac0(itt)*exp(-vtac(itt))*(1.d0-vvxt)
9366 * *(1.d0-vvxtl)-(vtac(itt)-vtac0(itt))*(1.d0-exp(-vtac(itt))
9367 * *(1.d0-vvxt)*(1.d0-vvxtl)))*exp(-vtac(itt))*(1.d0-vvxt))
9368 * *(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)*exp(-2.d0*vpac(ip))
9369 elseif(itypom.eq.3)then !'fan' (cut/uncut end - rapgap)
9370 gb0=((max(0.d0,1.d0-exp(-2.d0*vtac(itt))
9371 * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
9372 * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
9373 * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9374 * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9375 * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
9376 * +((1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
9377 * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl)
9378 * +2.d0*vtacng*exp(-2.d0*vtac(itt))*(1.d0-vvxt)**2*(1.d0-vvxtl))
9379 * *(vicc-wgpm(m)*viuc)*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9380 * *(1.d0-vvx)*(1.d0-vvxp)*exp(-vpac(ip))
9381 elseif(itypom.eq.4)then !'leg' (single cut Pomeron at the end)
9382 gb0=vip*((vtlc0-vtlcpe)*exp(-vtac(itt))*(1.d0-vvxt)
9383 * *(1.d0-vvxtl))*exp(-vtac(itt)-2.d0*vpac(ip))*(1.d0-vvxt)
9384 * *(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)
9385 if(gb0.eq.0.d0)then
9386 gb0=vip*vtlc0*exp(-vtac(itt))*(1.d0-vvxt)
9387 * *(1.d0-vvxtl)*exp(-vtac(itt)-2.d0*vpac(ip))*(1.d0-vvxt)
9388 * *(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl) *.01d0
9389 endif
9390 elseif(itypom.eq.5)then !'leg' (cut/uncut end - rapgap)
9391 gb0=vtlcng*exp(-2.d0*vtac(itt)-vpac(ip))
9392 * *(1.d0-vvxt)**2*(1.d0-vvxtl)*(1.d0-vvx)*(1.d0-vvxp)
9393 * *(vicc-wgpm(m)*viuc)*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9394 elseif(itypom.eq.7)then !'leg' (>1 cut Poms at the end)
9395 gb0=vimp*(vtlc0*exp(-vtac(itt))*(1.d0-vvxt)*(1.d0-vvxtl)
9396 * -(vtlc-vtlc0)*(1.d0-exp(-vtac(itt))*(1.d0-vvxt)*(1.d0-vvxtl)))
9397 * *exp(-vtac(itt)-2.d0*vpac(ip))*(1.d0-vvxt)
9398 * *(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)
9399 endif
9400 if(gb0.le.0.d0)then !so170712
9401 iret=1
9402 goto 31
9403 endif
9404 nrej=0
9405
9406 23 xpomm(m+1)=xpomm(m)/sgap/(xpomm(m)*scm/sgap**2)**qgran(b10)
9407 if(itypom.eq.4)xpomm(m+1)=xpomm(m)/sgap
9408 */(xpomm(m)*scm/sgap**3)**qgran(b10)
9409 rp1=(rq(iddt(itt),2)+alfp*dlog(xpomm(m+1)*scm))*4.d0*.0389d0
9410 rp2=alfp*dlog(xpomm(m)/xpomm(m+1))*4.d0*.0389d0
9411 rp=rp1*rp2/(rp1+rp2)
9412 z=qgran(b10)
9413 phi=pi*qgran(b10)
9414 b0=dsqrt(-rp*dlog(z))
9415 bbt=(dsqrt(btm)*rp1/(rp1+rp2)+b0*cos(phi))**2+(b0*sin(phi))**2
9416 bbi=(dsqrt(btm)*rp2/(rp1+rp2)-b0*cos(phi))**2+(b0*sin(phi))**2
9417 call qgbdef(bbt,bbi,xb(itt,1),xb(itt,2),xxm(m),yym(m)
9418 *,xxm(m+1),yym(m+1),int(1.5d0+qgran(b10))) !coordinates for the vertex
9419
9420 call qgfdf(xxm(m+1),yym(m+1),xpomm(m+1),vpac,vtac
9421 *,vvx,vvxp,vvxt,vvxpl,vvxtl,ip,itt)
9422 vvxps=1.d0-(1.d0-vvx)*(1.d0-vvxp)*exp(-vpac(ip))
9423 viu=qgpini(xpomm(m)/xpomm(m+1),bbi,0.d0,0.d0,2)
9424 vim=2.d0*min(viu,qgpini(xpomm(m)/xpomm(m+1),bbi,0.d0,0.d0,8))
9425 if(itypom.eq.-1.or.itypom.eq.4)then !single cut Pomeron at the end
9426 vvxi=1.d0-((1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxt))**2
9427 * *exp(-2.d0*vpac(ip)-2.d0*vtac(itt))
9428 vip=qgpini(xpomm(m)/xpomm(m+1),bbi,vvxi,0.d0,16)*exp(-vim)
9429 elseif(itypom.eq.2.or.itypom.eq.7)then !>1 cut Pomerons at the end
9430 vimp=max(0.d0,1.d0-exp(-vim)*(1.d0+vim))
9431 else !rap-gap at the end
9432 vvxpin=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9433 vvxtin=1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(itt))
9434 viuu=qgpini(xpomm(m)/xpomm(m+1),bbi,vvxtin,vvxpin,20)
9435 * *(1.d0-exp(-viu))
9436 viuc=max(0.d0,viuu-qgpini(xpomm(m)/xpomm(m+1),bbi
9437 * ,vvxtin,vvxpin,21)*(1.d0-exp(-viu)))
9438 vicc=qgpini(xpomm(m)/xpomm(m+1),bbi,vvxtin,vvxpin,22)*.5d0
9439 * *((1.d0-exp(-viu))**2+(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))
9440 vicu=max(0.d0,qgpini(xpomm(m)/xpomm(m+1),bbi,vvxtin,vvxpin,23)
9441 * *((1.d0-exp(-viu))**2+(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))
9442 * /2.d0-vicc)
9443 endif
9444
9445 if(itypom.le.3)then !cut 'fan'
9446 sumut=0.d0
9447 vvxt0=0.d0
9448 do i=1,ia(2)
9449 sumut=sumut+vtac(i)
9450 enddo
9451 vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9452 do i=1,ia(2)-itt+1
9453 iti=ia(2)-i+1
9454 bbl=(xb(iti,1)-xxm(m+1))**2+(xb(iti,2)-yym(m+1))**2
9455 sumut=sumut-vtac(iti)
9456 vtac0(iti)=min(vtac(iti)
9457 * ,qgfani(xpomm(m+1)*scm,bbl,1.d0-vvxs*exp(-sumut)
9458 * ,1.d0-exp(-vvxt0),1.d0-exp(-sumut),iddt(iti),2,3))
9459 if(iti.gt.itt)vvxt0=vvxt0+vtac0(iti)
9460 enddo
9461 vvxt0=1.d0-exp(-vvxt0)
9462
9463 vtacng=min(vtac0(itt)
9464 * ,qgfani(xpomm(m+1)*scm,bbt,vvxps,vvxt0,vvxtl,iddt(itt),2,4))
9465 vtacpe=min(vtacng
9466 * ,qgfani(xpomm(m+1)*scm,bbt,vvxps,vvxt0,vvxtl,iddt(itt),2,5))
9467 else !cut 'leg'
9468 vtlc=qgfani(xpomm(m+1)*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,7)
9469 vtlc0=min(vtlc
9470 * ,qgfani(xpomm(m+1)*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,8))
9471 vtlcng=min(vtlc0
9472 * ,qgfani(xpomm(m+1)*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,11))
9473 vtlcpe=min(vtlcng
9474 * ,qgfani(xpomm(m+1)*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,10))
9475 endif
9476
9477 if(itypom.eq.-1)then !'fan' (single cut Pomeron at the end)
9478 gb=vip*((max(0.d0,1.d0-exp(-2.d0*vtac(itt))
9479 * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
9480 * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
9481 * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9482 * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9483 * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
9484 * +((1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
9485 * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl)
9486 * +2.d0*((vtac0(itt)-vtacpe)*exp(-vtac(itt))*(1.d0-vvxt)
9487 * *(1.d0-vvxtl)-(vtac(itt)-vtac0(itt))*(1.d0-exp(-vtac(itt))
9488 * *(1.d0-vvxt)*(1.d0-vvxtl)))*exp(-vtac(itt))*(1.d0-vvxt))
9489 * *(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)*exp(-2.d0*vpac(ip))
9490 elseif(itypom.eq.0)then !'fan' (cut loop at the end - rapgap)
9491 gb=((max(0.d0,1.d0-exp(-2.d0*vtac(itt))
9492 * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
9493 * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
9494 * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9495 * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9496 * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
9497 * +((1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
9498 * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl)
9499 * +2.d0*vtacng*exp(-2.d0*vtac(itt))*(1.d0-vvxt)**2*(1.d0-vvxtl))
9500 * *(vicc*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9501 * -vicu*(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))))
9502 * *(1.d0-vvx)*(1.d0-vvxp)*exp(-vpac(ip))
9503 * -2.d0*vicu*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9504 * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9505 * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt)-vpac(ip))
9506 * *(1.d0-vvx)*(1.d0-vvxp)
9507 elseif(itypom.eq.1)then !'fan' (uncut end - rapgap)
9508 gb=((max(0.d0,1.d0-exp(-2.d0*vtac(itt))
9509 * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
9510 * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
9511 * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9512 * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9513 * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
9514 * +((1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
9515 * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl)
9516 * +2.d0*vtacng*exp(-2.d0*vtac(itt))*(1.d0-vvxt)**2*(1.d0-vvxtl))
9517 * *(viuc*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9518 * +viuu*(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))))
9519 * *(1.d0-vvx)*(1.d0-vvxp)*exp(-vpac(ip))
9520 * +2.d0*viuu*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9521 * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9522 * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt)-vpac(ip))
9523 * *(1.d0-vvx)*(1.d0-vvxp)
9524 elseif(itypom.eq.2)then !'fan' (>1 cut Poms at the end)
9525 gb=vimp*((max(0.d0,1.d0-exp(-2.d0*vtac(itt))
9526 * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
9527 * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
9528 * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9529 * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9530 * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
9531 * +((1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
9532 * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl)
9533 * +2.d0*(vtac0(itt)*exp(-vtac(itt))*(1.d0-vvxt)
9534 * *(1.d0-vvxtl)-(vtac(itt)-vtac0(itt))*(1.d0-exp(-vtac(itt))
9535 * *(1.d0-vvxt)*(1.d0-vvxtl)))*exp(-vtac(itt))*(1.d0-vvxt))
9536 * *(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)*exp(-2.d0*vpac(ip))
9537 elseif(itypom.eq.3)then !'fan' (cut/uncut end - rapgap)
9538 gb=((max(0.d0,1.d0-exp(-2.d0*vtac(itt))
9539 * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
9540 * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
9541 * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9542 * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9543 * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
9544 * +((1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
9545 * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl)
9546 * +2.d0*vtacng*exp(-2.d0*vtac(itt))*(1.d0-vvxt)**2*(1.d0-vvxtl))
9547 * *((vicc-wgpm(m)*viuc)*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9548 * -(vicu+wgpm(m)*viuu)*(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)
9549 * *exp(-vpac(ip))))*(1.d0-vvx)*(1.d0-vvxp)*exp(-vpac(ip))
9550 * -2.d0*(vicu+wgpm(m)*viuu)*(max(0.d0,exp(vtac(itt)-vtac0(itt))
9551 * -1.d0-(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9552 * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt)-vpac(ip))
9553 * *(1.d0-vvx)*(1.d0-vvxp)
9554 elseif(itypom.eq.4)then !'leg' (single cut Pomeron at the end)
9555 gb=vip*((vtlc0-vtlcpe)*exp(-vtac(itt))*(1.d0-vvxt)
9556 * *(1.d0-vvxtl)-(vtlc-vtlc0)*(1.d0-exp(-vtac(itt))*(1.d0-vvxt)
9557 * *(1.d0-vvxtl)))*exp(-vtac(itt)-2.d0*vpac(ip))*(1.d0-vvxt)
9558 * *(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)
9559 elseif(itypom.eq.5)then !'leg' (cut/uncut end - rapgap)
9560 gb=vtlcng*exp(-2.d0*vtac(itt)-vpac(ip))
9561 * *(1.d0-vvxt)**2*(1.d0-vvxtl)*(1.d0-vvx)*(1.d0-vvxp)
9562 * *((vicc-wgpm(m)*viuc)*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9563 * -(vicu+wgpm(m)*viuu)*(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)
9564 * *exp(-vpac(ip))))
9565 elseif(itypom.eq.7)then !'leg' (>1 cut Poms at the end)
9566 gb=vimp*(vtlc0*exp(-vtac(itt))*(1.d0-vvxt)*(1.d0-vvxtl)
9567 * -(vtlc-vtlc0)*(1.d0-exp(-vtac(itt))*(1.d0-vvxt)*(1.d0-vvxtl)))
9568 * *exp(-vtac(itt)-2.d0*vpac(ip))*(1.d0-vvxt)
9569 * *(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)
9570 endif
9571 nrej=nrej+1
9572 gb=gb/gb0/z*rp/rp0 /10.d0
9573 if(qgran(b10).gt.gb.and.nrej.le.1000)goto 23
9574
9575 if(itypom.eq.-1.or.itypom.eq.4)then !'single cut Pomeron in the handle
9576 npin=npin+1
9577 if(npin.gt.npmax)then
9578 iret=1
9579 goto 31
9580 endif
9581 xpomim(npin)=1.d0/xpomm(m+1)/scm
9582 xpomip(npin)=xpomm(m)
9583 vvxim(npin)=vvxi
9584 bpomim(npin)=bbi
9585 if(debug.ge.4)write (moniou,211)npin,xpomip(npin),xpomim(npin)
9586 * ,vvxim(npin),bpomim(npin)
9587 elseif(itypom.eq.2.or.itypom.eq.7)then !>1 cut Pomerons in the handle
9588 ninc=npgen(vim,2,20)
9589 npin=npin+ninc
9590 if(npin.gt.npmax)then
9591 iret=1
9592 goto 31
9593 endif
9594 do i=npin-ninc+1,npin
9595 xpomim(i)=1.d0/xpomm(m+1)/scm
9596 xpomip(i)=xpomm(m)
9597 vvxim(i)=0.d0
9598 bpomim(i)=bbi
9599 if(debug.ge.4)write (moniou,211)i,xpomip(i),xpomim(i)
9600 * ,vvxim(i),bpomim(i)
9601 enddo
9602 endif
9603
9604 if(itypom.eq.-1)then !single cut Pomeron in the 'handle'
9605 vv1=(max(0.d0,1.d0-exp(-2.d0*vtac(itt))
9606 * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
9607 * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
9608 * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9609 * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9610 * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
9611 vv2=(1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
9612 * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl
9613 vv3=2.d0*((vtac0(itt)-vtacpe)*exp(-vtac(itt))*(1.d0-vvxt)
9614 * *(1.d0-vvxtl)-(vtac(itt)-vtac0(itt))*(1.d0-exp(-vtac(itt))
9615 * *(1.d0-vvxt)*(1.d0-vvxtl)))*exp(-vtac(itt))*(1.d0-vvxt)
9616 if(xpomm(m+1)*scm.lt.1.1d0*sgap**2.or.vv3.lt.0.d0)vv3=0.d0
9617 aks=(vv1+vv2+vv3)*qgran(b10)
9618 if(aks.lt.vv1)then
9619 jt=1 !>1 cut fans
9620 elseif(aks.lt.vv1+vv2)then
9621 jt=2 !diffr. cut
9622 else
9623 jt=3 !1 cut fan
9624 endif
9625 elseif(itypom.eq.0)then !cut 'loop' in the 'handle'
9626 vv1=(max(0.d0,1.d0-exp(-2.d0*vtac(itt))
9627 * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
9628 * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
9629 * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9630 * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9631 * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt)-vpac(ip))
9632 * *(1.d0-vvxp)*(1.d0-vvxpl)*(vicc+vicu)
9633 * /(vicc*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9634 * -vicu*(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))))
9635 vv2=(1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
9636 * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl
9637 vv3=2.d0*vtacng*exp(-2.d0*vtac(itt))*(1.d0-vvxt)**2*(1.d0-vvxtl)
9638 aks=(vv1+vv2+vv3)*qgran(b10)
9639 if(aks.lt.vv1)then
9640 jt=1 !>1 cut fans
9641 elseif(aks.lt.vv1+vv2)then
9642 jt=2 !diffr. cut
9643 else
9644 jt=3 !1 cut fan
9645 endif
9646 elseif(itypom.eq.1)then !uncut 'handle' (rap-gap)
9647 vv1=(max(0.d0,1.d0-exp(-2.d0*vtac(itt))
9648 * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
9649 * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
9650 * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9651 * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9652 * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
9653 vv2=(1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
9654 * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl
9655 vv3=2.d0*vtacng*exp(-2.d0*vtac(itt))*(1.d0-vvxt)**2*(1.d0-vvxtl)
9656 vv4=2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0-(vtac(itt)
9657 * -vtac0(itt)))*(1.d0-vvxt0)+(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))
9658 * *exp(-vtac(itt))*viuu/(viuu*(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)
9659 * *exp(-vpac(ip)))+viuc*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip)))
9660 if(xpomm(m+1)*scm.lt.1.1d0*sgap**2.or.vv4.lt.0.d0)vv4=0.d0
9661 aks=(vv1+vv2+vv3+vv4)*qgran(b10)
9662 if(aks.lt.vv1)then
9663 jt=1 !>1 cut fans
9664 elseif(aks.lt.vv1+vv2)then
9665 jt=2 !diffr. cut
9666 elseif(aks.lt.vv1+vv2+vv3)then
9667 jt=3 !1 cut fan
9668 else
9669 jt=4 !>1 cut 'handle' fans
9670 endif
9671 elseif(itypom.eq.2)then !>1 cut Pomerons in the 'handle'
9672 vv1=(max(0.d0,1.d0-exp(-2.d0*vtac(itt))
9673 * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
9674 * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
9675 * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9676 * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9677 * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
9678 vv2=(1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
9679 * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl
9680 vv3=2.d0*(vtac0(itt)*exp(-vtac(itt))*(1.d0-vvxt)
9681 * *(1.d0-vvxtl)-(vtac(itt)-vtac0(itt))*(1.d0-exp(-vtac(itt))
9682 * *(1.d0-vvxt)*(1.d0-vvxtl)))*exp(-vtac(itt))*(1.d0-vvxt)
9683 aks=(vv1+vv2+vv3)*qgran(b10)
9684 if(aks.lt.vv1)then
9685 jt=1 !>1 cut fans
9686 elseif(aks.lt.vv1+vv2)then
9687 jt=2 !diffr. cut
9688 else
9689 jt=3 !1 cut fan
9690 endif
9691 elseif(itypom.eq.3)then !rap-gap in the 'handle'
9692 vv1=(max(0.d0,1.d0-exp(-2.d0*vtac(itt))*(1.d0+2.d0*vtac(itt)))
9693 * +2.d0*vtac(itt)*exp(-2.d0*vtac(itt))*(1.d0-(1.d0-vvxt)**2))
9694 * *(1.d0-vvxtl)-2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9695 * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)+(vtac(itt)-vtac0(itt))
9696 * *(vvxt-vvxt0))*exp(-vtac(itt)-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
9697 * *(vicc+vicu+wgpm(m)*(viuu-viuc))
9698 * /((vicc-wgpm(m)*viuc)*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9699 * -(vicu+wgpm(m)*viuu)*(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)
9700 * *exp(-vpac(ip))))
9701 vv2=(1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
9702 * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl
9703 vv3=2.d0*vtacng*exp(-2.d0*vtac(itt))*(1.d0-vvxt)**2
9704 * *(1.d0-vvxtl)
9705 aks=(vv1+vv2+vv3)*qgran(b10)
9706 if(aks.lt.vv1)then
9707 jt=1 !>1 cut fans
9708 elseif(aks.lt.vv1+vv2)then
9709 jt=2 !diffr. cut
9710 else
9711 jt=3 !1 cut fan
9712 endif
9713 else
9714 jt=5 !cut leg
9715 endif
9716
9717 nppm(m+1)=0
9718 wgpm(m+1)=0.d0
9719 if(jt.eq.1)then !>1 cut fans
9720 ntry=0
9721 24 ntry=ntry+1
9722 nphm=0
9723 if(itt.eq.ia(2).or.ntry.gt.100)then
9724 nppm(m+1)=npgen(2.d0*vtac(itt),2,20)
9725 do i=1,nppm(m+1)
9726 if(qgran(b10).le.vtac0(itt)/vtac(itt)
9727 * .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
9728 itypm(i,m+1)=0
9729 else
9730 nphm=nphm+1
9731 itypm(i,m+1)=1
9732 endif
9733 ippm(i,m+1)=itt
9734 enddo
9735 wh=(vtac(itt)/vtac0(itt)-1.d0)/nppm(m+1)
9736 else
9737 nppm(m+1)=npgen(2.d0*vtac(itt),1,20)
9738 do i=1,nppm(m+1)
9739 if(qgran(b10).le.vtac0(itt)/vtac(itt)
9740 * .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
9741 itypm(i,m+1)=0
9742 else
9743 nphm=nphm+1
9744 itypm(i,m+1)=1
9745 endif
9746 ippm(i,m+1)=itt
9747 enddo
9748 wh=(vtac(itt)/vtac0(itt)-1.d0)/nppm(m+1)
9749 do iti=itt+1,ia(2)
9750 ninc=npgen(2.d0*vtac(iti),0,20)
9751 if(ninc.ne.0)then
9752 nppm(m+1)=nppm(m+1)+ninc
9753 nh0=nphm
9754 if(nppm(m+1).gt.legmax)then
9755 iret=1
9756 goto 31
9757 endif
9758 do i=nppm(m+1)-ninc+1,nppm(m+1)
9759 if(qgran(b10).le.vtac0(iti)/vtac(iti)
9760 * .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
9761 itypm(i,m+1)=0
9762 else
9763 nphm=nphm+1
9764 itypm(i,m+1)=1
9765 endif
9766 ippm(i,m+1)=iti
9767 enddo
9768 if(ninc.gt.nphm-nh0)wh=(vtac(iti)/vtac0(iti)-1.d0)/ninc
9769 endif
9770 enddo
9771 if(nppm(m+1).eq.1)goto 24
9772 endif
9773
9774 if(nphm+1.ge.nppm(m+1))then
9775 if(itypom.eq.-1.or.itypom.eq.1.or.itypom.eq.2)then
9776 gbt=1.d0-exp(vtac(itt)+(1.d0-nphm)*dlog(2.d0))
9777 * /(1.d0-vvxt)/(1.d0-vvxtl)
9778 elseif(itypom.eq.0)then
9779 gbt=1.d0-(vicc+vicu)*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9780 * /(vicc*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9781 * -vicu*(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))))
9782 * *exp(vtac(itt)+(1.d0-nphm)*dlog(2.d0))
9783 * /(1.d0-vvxt)/(1.d0-vvxtl)
9784 elseif(itypom.eq.3)then
9785 gbt=1.d0-(vicc+vicu+wgpm(m)*(viuu-viuc))
9786 * *(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9787 * /((vicc-wgpm(m)*viuc)*(1.d0-vvxp)*(1.d0-vvxpl)
9788 * *exp(-vpac(ip))-(vicu+wgpm(m)*viuu)
9789 * *(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))))
9790 * *exp(vtac(itt)+(1.d0-nphm)*dlog(2.d0))
9791 * /(1.d0-vvxt)/(1.d0-vvxtl)
9792 else
9793 stop'unknown itypom'
9794 endif
9795 if(nphm.eq.nppm(m+1).and.qgran(b10).gt.gbt
9796 * .or.nphm+1.eq.nppm(m+1).and.qgran(b10).gt.1.d0+wh*gbt)then
9797 ntry=0
9798 goto 24
9799 endif
9800 endif
9801
9802 elseif(jt.eq.4)then !>1 cut 'handle' fans
9803 ntry=0
9804 25 ntry=ntry+1
9805 if(itt.eq.ia(2).or.ntry.gt.100)then
9806 nppm(m+1)=npgen(vtac(itt)-vtac0(itt),2,20)
9807 do i=1,nppm(m+1)
9808 itypm(i,m+1)=1
9809 ippm(i,m+1)=itt
9810 enddo
9811 else
9812 nppm(m+1)=npgen(vtac(itt)-vtac0(itt),1,20)
9813 do i=1,nppm(m+1)
9814 itypm(i,m+1)=1
9815 ippm(i,m+1)=itt
9816 enddo
9817 do iti=itt+1,ia(2)
9818 ninc=npgen(vtac(iti)-vtac0(iti),0,20)
9819 if(ninc.ne.0)then
9820 nppm(m+1)=nppm(m+1)+ninc
9821 if(nppm(m+1).gt.legmax)then
9822 iret=1
9823 goto 31
9824 endif
9825 do i=nppm(m+1)-ninc+1,nppm(m+1)
9826 itypm(i,m+1)=1
9827 ippm(i,m+1)=iti
9828 enddo
9829 endif
9830 enddo
9831 if(nppm(m+1).eq.1)goto 25
9832 endif
9833
9834 elseif(jt.eq.3)then !1 cut fan
9835 nppm(m+1)=1
9836 ippm(1,m+1)=itt
9837 if(itypom.eq.-1)then !single cut Pomeron in the 'handle'
9838 factor=exp(-vtac(itt))*(1.d0-vvxt)*(1.d0-vvxtl)
9839 wng=(vtacng-vtacpe)*factor/((vtac0(itt)-vtacpe)*factor
9840 * -(vtac(itt)-vtac0(itt))*(1.d0-factor))
9841 if(qgran(b10).le.wng.or.wng.lt.0.d0
9842 * .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
9843 itypm(1,m+1)=2 !>1 cut Pomerons in the 'handle'
9844 else
9845 itypm(1,m+1)=3 !rap-gap in the 'handle'
9846 wgpm(m+1)=(1.d0-factor)/factor
9847 endif
9848 elseif(itypom.eq.2)then !>1 cut Pomerons in the 'handle'
9849 factor=exp(-vtac(itt))*(1.d0-vvxt)*(1.d0-vvxtl)
9850 wng=vtacng*factor/(vtac0(itt)*factor
9851 * -(vtac(itt)-vtac0(itt))*(1.d0-factor))
9852 if(qgran(b10).le.wng.or.wng.lt.0.d0
9853 * .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
9854 if(qgran(b10).le.vtacpe/vtacng
9855 * .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
9856 itypm(1,m+1)=-1 !single cut Pomeron in the 'handle'
9857 else
9858 itypm(1,m+1)=2 !>1 cut Pomerons in the 'handle'
9859 endif
9860 else
9861 itypm(1,m+1)=3 !rap-gap in the 'handle'
9862 wgpm(m+1)=(1.d0-factor)/factor
9863 endif
9864 else !rap-gap in the 'handle'
9865 if(qgran(b10).le.vtacpe/vtacng
9866 * .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
9867 itypm(1,m+1)=-1 !single cut Pomeron in the 'handle'
9868 else
9869 itypm(1,m+1)=2 !>1 cut Pomerons in the 'handle'
9870 endif
9871 endif
9872
9873 if(itypm(1,m+1).eq.-1)then !single cut Pomeron in the 'handle'
9874 vtlcp=min(vtacpe
9875 * ,qgfani(xpomm(m+1)*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,9))
9876 if(qgran(b10).le.vtlcp/vtacpe
9877 * .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)itypm(1,m+1)=6 !single cut Pomeron
9878 endif
9879
9880 elseif(jt.eq.5)then !cut 'leg'
9881 nppm(m+1)=1
9882 ippm(1,m+1)=itt
9883 if(itypom.eq.4)then !single cut Pomeron at the end
9884 if(xpomm(m+1)*scm.le.sgap**2)stop'=4:xpomm(m+1)*scm<sgap**2'
9885 factor=exp(-vtac(itt))*(1.d0-vvxt)*(1.d0-vvxtl)
9886 wng=(vtlcng-vtlcpe)*factor/((vtlc0-vtlcpe)*factor
9887 * -(vtlc-vtlc0)*(1.d0-factor))
9888 if(qgran(b10).le.wng.or.wng.lt.0.d0)then
9889 itypm(1,m+1)=7 !>1 cut Pomerons at the end
9890 else
9891 itypm(1,m+1)=5 !rap-gap at the end
9892 wgpm(m+1)=(1.d0-factor)/factor
9893 endif
9894 elseif(itypom.eq.5)then !rap-gap at the end (cut or uncut loop)
9895 if(qgran(b10).le.vtlcpe/vtlcng
9896 * .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
9897 itypm(1,m+1)=4 !single cut Pomeron at the end
9898 else
9899 itypm(1,m+1)=7 !>1 cut Pomerons at the end
9900 endif
9901 elseif(itypom.eq.7)then !>1 cut Pomerons at the end
9902 factor=exp(-vtac(itt))*(1.d0-vvxt)*(1.d0-vvxtl)
9903 wng=vtlcng*factor/(vtlc0*factor-(vtlc-vtlc0)*(1.d0-factor))
9904 if(qgran(b10).le.wng.or.wng.lt.0.d0
9905 * .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
9906 if(qgran(b10).le.vtlcpe/vtlcng
9907 * .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
9908 itypm(1,m+1)=4 !single cut Pomeron at the end
9909 else
9910 itypm(1,m+1)=7 !>1 cut Pomerons at the end
9911 endif
9912 else
9913 itypm(1,m+1)=5 !rap-gap at the end
9914 wgpm(m+1)=(1.d0-factor)/factor
9915 endif
9916 endif
9917
9918 if(itypm(1,m+1).eq.4)then !single cut Pomeron at the end
9919 vtlcp=min(vtlcpe
9920 * ,qgfani(xpomm(m+1)*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,9))
9921 if(qgran(b10).le.vtlcp/vtlcpe
9922 * .or.xpomm(m+1)*scm.lt.1.1d0*sgap**3)itypm(1,m+1)=6 !single cut Pomeron
9923 endif
9924 endif
9925
9926 if(nppm(m+1).eq.1.and.itypm(1,m+1).eq.6)then !record single cut Pomeron
9927 nptg=nptg+1
9928 if(nptg.gt.legmax)then
9929 iret=1
9930 goto 31
9931 endif
9932 xpomti(nptg)=xpomm(m+1)
9933 vvxti(nptg)=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*(1.d0-vvxt)
9934 * *(1.d0-vvxtl)*exp(-vpac(ip))
9935 ipomti(nptg)=itt
9936 bpomti(nptg)=bbt
9937 nppm(m+1)=0
9938 if(debug.ge.4)write (moniou,217)nptg,itt,bbt,xpomti(nptg)
9939 * ,vvxti(nptg)
9940
9941 elseif(nppm(m+1).gt.1)then
9942 i=0
9943 26 i=i+1
9944 ityp=itypm(i,m+1)
9945 if(ityp.eq.0)then
9946 iti=ippm(i,m+1)
9947 bbi=(xb(iti,1)-xxm(m+1))**2+(xb(iti,2)-yym(m+1))**2
9948 vvxt=0.d0
9949 vvxtl=0.d0
9950 vvxt0=0.d0
9951 if(ia(2).gt.1)then
9952 do l=1,ia(2)
9953 if(l.lt.iti)then
9954 vvxtl=vvxtl+vtac(l)
9955 elseif(l.gt.iti)then
9956 vvxt=vvxt+vtac(l)
9957 vvxt0=vvxt0+vtac0(l)
9958 endif
9959 enddo
9960 endif
9961 vvxt=1.d0-exp(-vvxt)
9962 vvxtl=1.d0-exp(-vvxtl)
9963 vvxt0=1.d0-exp(-vvxt0)
9964
9965 vtacng=min(vtac0(iti)
9966 * ,qgfani(xpomm(m+1)*scm,bbi,vvxps,vvxt0,vvxtl,iddt(iti),2,4))
9967 vtacpe=min(vtacng
9968 * ,qgfani(xpomm(m+1)*scm,bbi,vvxps,vvxt0,vvxtl,iddt(iti),2,5))
9969 vtlcp=min(vtacpe
9970 * ,qgfani(xpomm(m+1)*scm,bbi,vvxps,vvxt,vvxtl,iddt(iti),2,9))
9971
9972 aks=qgran(b10)*vtac0(iti)
9973 if(aks.le.vtlcp.or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
9974 itypm(i,m+1)=6 !single cut Pomeron
9975 elseif(aks.lt.vtacpe)then
9976 itypm(i,m+1)=-1 !single cut Pomeron in the 'handle'
9977 elseif(aks.lt.vtacng)then
9978 itypm(i,m+1)=2 !>1 cut Pomerons in the 'handle'
9979 endif
9980
9981 if(itypm(i,m+1).eq.6)then !record single cut Pomeron
9982 nptg=nptg+1
9983 if(nptg.gt.legmax)then
9984 iret=1
9985 goto 31
9986 endif
9987 xpomti(nptg)=xpomm(m+1)
9988 vvxti(nptg)=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*(1.d0-vvxt)
9989 * *(1.d0-vvxtl)*exp(-vpac(ip))
9990 ipomti(nptg)=iti
9991 bpomti(nptg)=bbi
9992 if(debug.ge.4)write (moniou,217)nptg,iti,bbi,xpomti(nptg)
9993 * ,vvxti(nptg)
9994 nppm(m+1)=nppm(m+1)-1
9995 if(nppm(m+1).ge.i)then
9996 do l=i,nppm(m+1)
9997 ippm(l,m+1)=ippm(l+1,m+1)
9998 itypm(l,m+1)=itypm(l+1,m+1)
9999 enddo
10000 endif
10001 i=i-1
10002 endif
10003 endif
10004 if(i.lt.nppm(m+1))goto 26
10005 endif
10006
10007 if(jt.eq.2.and.qgran(b10).lt.(1.d0-exp(-vtac(itt)))*(1.d0-vvxtl)
10008 */((1.d0-exp(-vtac(itt)))*(1.d0-vvxtl)+2.d0*vvxtl))then
10009 if(debug.ge.4)write (moniou,212)
10010 icdts=iddt(itt)
10011 do icdt=1,2
10012 iddt(itt)=icdt
10013 call qgfdf(xxm(m+1),yym(m+1),xpomm(m+1),vpac,vtac
10014 * ,vvx,vvxp,vvxt,vvxpl,vvxtl,ip,itt)
10015 wdt(icdt,itt)=(1.d0-exp(-vtac(itt)))*(1.d0-vvxtl)
10016 enddo
10017 iddt(itt)=icdts
10018 endif
10019
10020 if(nppm(m+1).ne.0)then
10021 goto 21
10022 else
10023 goto 22
10024 endif
10025 31 continue
10026 if(debug.ge.2)write (moniou,219)nppr,nptg,npin,iret
10027
10028 201 format(2x,'qg3pdf - configuration for multi-Pomeron'
10029 *,'/diffractive contributions'
10030 */4x,i2,'-th proj. nucleon',2x,i2,'-th targ. nucleon')
10031 202 format(2x,'qg3pdf: problem with initial normalization'
10032 *,' -> rejection')
10033 203 format(2x,'qg3pdf: normalization of rejection function - ',e10.3)
10034 204 format(2x,'qg3pdf: xpomr=',e10.3,2x,'bbpr=',e10.3,2x,'bbtg=',e10.3
10035 *,2x,'gb=',e10.3)
10036 205 format(2x,'qg3pdf: xpomr=',e10.3,2x,'bbpr=',e10.3,2x,'bbtg=',e10.3
10037 *,2x,'xxp=',e10.3,2x,'yyp=',e10.3)
10038 206 format(2x,'qg3pdf: main vertex, nppr0=',i3,2x,'nptg0=',i3)
10039 208 format(2x,'qg3pdf: check',i3,'-th cut fan at ',i2,'-th level,'
10040 *,' proj. index - ',i3,2x,'b^2=',e10.3)
10041 209 format(2x,'qg3pdf: ',i3,'-th proj. leg, proj. index - ',i3
10042 *,2x,'b^2=',e10.3,2x,'xpomr=',e10.3,2x,'vvx=',e10.3)
10043 210 format(2x,'qg3pdf: new vertex at ',i3,'-th level')
10044 211 format(2x,'qg3pdf: ',i3,'-th interm. Pomeron'
10045 */4x,'xpomip=',e10.3,2x,'xpomim=',e10.3
10046 *,2x,'vvxim=',e10.3,2x,'bpomim=',e10.3)
10047 212 format(2x,'qg3pdf: diffractive cut')
10048 214 format(2x,'qg3pdf: total number of proj. legs - ',i3)
10049 216 format(2x,'qg3pdf: check',i3,'-th cut fan at ',i2,'-th level,'
10050 *,' targ. index - ',i3,2x,'b^2=',e10.3)
10051 217 format(2x,'qg3pdf: ',i3,'-th targ. leg, targ. index - ',i3
10052 *,2x,'b^2=',e10.3,2x,'xpomr=',e10.3,2x,'vvx=',e10.3)
10053 219 format(2x,'qg3pdf - end',2x,'number of proj. legs:',i3
10054 *,2x,'number of targ. legs:',i3
10055 */4x,'number of interm. Pomerons:',i3,'return flag:',i2)
10056 return
10057 end
10058
10059
10060 subroutine qgloolc(sy,xp,bb,icdp,icz,iqq,fan1,fan0)
10061
10062
10063
10064
10065
10066
10067
10068
10069
10070
10071 implicit double precision (a-h,o-z)
10072 integer debug
10073 common /qgarr6/ pi,bm,amws
10074 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
10075 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
10076 common /qgarr18/ alm,qt0,qtf,betp,dgqq
10077 common /qgarr26/ factk,fqscal
10078 common /qgarr43/ moniou
10079 common /qgdebug/ debug
10080 common /arr3/ x1(7),a1(7)
10081
10082 fan0=0.d0
10083 fan1=0.d0
10084 if(sy.le.sgap*max(1.d0,xp*sgap))goto 1
10085
10086 do ix1=1,7
10087 do mx1=1,2
10088 xpomr=min(xp,1.d0/sgap)/(sy/sgap/max(1.d0,xp*sgap))
10089 * **(.5d0+x1(ix1)*(mx1-1.5d0))
10090 rp=(rq(icdp,icz)-alfp*log(xpomr))*4.d0*.0389d0
10091 rp1=alfp*log(xpomr*sy/xp)*4.d0*.0389d0
10092 rp2=rp*rp1/(rp+rp1)
10093 do ix2=1,7
10094 do mx2=1,2
10095 z=.5d0+x1(ix2)*(mx2-1.5d0)
10096 bb0=-rp2*log(z)
10097 do ix3=1,7
10098 do mx3=1,2
10099 phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
10100 bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
10101 * +bb0*sin(phi)**2
10102 bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
10103 * +bb0*sin(phi)**2
10104
10105 v1icn=qgpini(xpomr*sy/xp,bb1,0.d0,0.d0,8)
10106 if(iqq.eq.1)then
10107 vpl=qglegc(xp/xpomr,xp,bb2,0.d0,icdp,icz,1)
10108 v1ic0=qgpini(xpomr*sy/xp,bb1,0.d0,0.d0,7)
10109 v1ic1=min(v1ic0,qgpini(xpomr*sy/xp,bb1,0.d0,0.d0,6))
10110 v1ic=min(v1ic1,qgpini(xpomr*sy/xp,bb1,0.d0,0.d0,5))
10111 elseif(iqq.eq.2)then
10112 vpl=qglegc(xp/xpomr,xp,bb2,0.d0,icdp,icz,0)
10113 v1ic0=qgpini(xpomr*sy/xp,bb1,0.d0,0.d0,15)
10114 v1ic1=min(v1ic0,qgpini(xpomr*sy/xp,bb1,0.d0,0.d0,14))
10115 v1ic=min(v1ic1,qgpini(xpomr*sy/xp,bb1,0.d0,0.d0,13))
10116 elseif(iqq.eq.3)then
10117 vpl=qglegc(xp/xpomr,xp,bb2,0.d0,icdp,icz,2)
10118 v1ic0=qgpini(xpomr*sy/xp,bb1,0.d0,0.d0,7)
10119 v1ic1=min(v1ic0,qgpini(xpomr*sy/xp,bb1,0.d0,0.d0,6))
10120 v1ic=min(v1ic1,qgpini(xpomr*sy/xp,bb1,0.d0,0.d0,5))
10121 else
10122 vpl=0.d0
10123 v1ic0=0.d0
10124 v1ic1=0.d0
10125 v1ic=0.d0
10126 stop 'Should no happen in qgloolc !'
10127 endif
10128 fan1=fan1+a1(ix1)*a1(ix2)*a1(ix3)/z*rp2
10129 * *vpl*(v1ic*exp(-2.d0*v1icn)-v1ic1)
10130 fan0=fan0+a1(ix1)*a1(ix2)*a1(ix3)/z*rp2*vpl*(v1ic1-v1ic0)
10131 enddo
10132 enddo
10133 enddo
10134 enddo
10135 enddo
10136 enddo
10137 fan0=fan0/8.d0*pi*r3p/.0389d0/g3p**3
10138 **dlog(sy/sgap/max(1.d0,xp*sgap))
10139 fan1=fan1/8.d0*pi*r3p/.0389d0/g3p**3
10140 **dlog(sy/sgap/max(1.d0,xp*sgap))
10141 1 continue
10142 if(iqq.eq.1)then
10143 dleg=qglegc(sy,xp,bb,0.d0,icdp,icz,1)
10144 elseif(iqq.eq.2)then
10145 dleg=qglegc(sy,xp,bb,0.d0,icdp,icz,0)
10146 elseif(iqq.eq.3)then
10147 dleg=qglegc(sy,xp,bb,0.d0,icdp,icz,2)
10148 else
10149 dleg=0.d0
10150 stop 'Should no happen in qgloolc !'
10151 endif
10152 fan0=fan0+dleg
10153 fan1=fan1+dleg
10154 return
10155 end
10156
10157
10158 double precision function qglscr(sy,xp,bb,vvx,icdp,icz,iqq)
10159
10160
10161
10162 implicit double precision (a-h,o-z)
10163 integer debug
10164 common /qgarr6/ pi,bm,amws
10165 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
10166 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
10167 common /qgarr18/ alm,qt0,qtf,betp,dgqq
10168 common /qgarr26/ factk,fqscal
10169 common /qgarr43/ moniou
10170 common /qgdebug/ debug
10171 common /arr3/ x1(7),a1(7)
10172
10173 qglscr=0.d0
10174 if(sy.le.sgap*max(1.d0,xp*sgap))goto 1
10175
10176 do ix1=1,7
10177 do mx1=1,2
10178 xpomr1=min(xp,1.d0/sgap)/(sy/sgap/max(1.d0,xp*sgap))
10179 * **(.5d0+x1(ix1)*(mx1-1.5d0))
10180 rp=(rq(icdp,icz)-alfp*log(xpomr1))*4.d0*.0389d0
10181 rp1=alfp*log(xpomr1*sy/xp)*4.d0*.0389d0
10182 rp2=rp*rp1/(rp+rp1)
10183 do ix2=1,7
10184 do mx2=1,2
10185 z=.5d0+x1(ix2)*(mx2-1.5d0)
10186 bb0=-rp2*log(z)
10187 do ix3=1,7
10188 do mx3=1,2
10189 phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
10190 bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
10191 * +bb0*sin(phi)**2
10192 bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
10193 * +bb0*sin(phi)**2
10194
10195 vicn=qgpini(xpomr1*sy/xp,bb1,0.d0,0.d0,8)
10196 vpf=qgfani(1.d0/xpomr1,bb2,vvx,0.d0,0.d0,icdp,icz,1)
10197 if(iqq.eq.1)then
10198 vpl=qglegc(xp/xpomr1,xp,bb2,vvx,icdp,icz,9)
10199 vi=qgpini(xpomr1*sy/xp,bb1,0.d0,0.d0,5)
10200 elseif(iqq.eq.2)then
10201 vpl=qglegc(xp/xpomr1,xp,bb2,vvx,icdp,icz,10)
10202 vi=qgpini(xpomr1*sy/xp,bb1,0.d0,0.d0,13)
10203 elseif(iqq.eq.3)then
10204 vpl=qglegc(xp/xpomr1,xp,bb2,vvx,icdp,icz,11)
10205 vi=qgpini(xpomr1*sy/xp,bb1,0.d0,0.d0,5)
10206 else
10207 vpl=0.d0
10208 vi=0.d0
10209 stop 'Should no happen in qglscr !'
10210 endif
10211
10212 dpx=vpl*vi*exp(-2.d0*vicn)
10213 * *((1.d0-vvx)**2*exp(-2.d0*vpf)-1.d0)
10214 qglscr=qglscr+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
10215 enddo
10216 enddo
10217 enddo
10218 enddo
10219 enddo
10220 enddo
10221 qglscr=qglscr/8.d0*pi*r3p/.0389d0/g3p**3
10222 **dlog(sy/sgap/max(1.d0,xp*sgap))
10223 1 continue
10224 if(iqq.eq.1)then
10225 qglscr=qglscr+qglegc(sy,xp,bb,0.d0,icdp,icz,3)
10226 elseif(iqq.eq.2)then
10227 qglscr=qglscr+qglegc(sy,xp,bb,0.d0,icdp,icz,5)
10228 elseif(iqq.eq.3)then
10229 qglscr=qglscr+qglegc(sy,xp,bb,0.d0,icdp,icz,7)
10230 endif
10231 return
10232 end
10233
10234
10235 double precision function qglh(sy,xp,bb,vvx,icdp,icz,iqq)
10236
10237 implicit double precision (a-h,o-z)
10238 integer debug
10239 common /qgarr6/ pi,bm,amws
10240 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
10241 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
10242 common /qgarr18/ alm,qt0,qtf,betp,dgqq
10243 common /qgarr19/ ahl(3)
10244 common /qgarr26/ factk,fqscal
10245 common /qgarr43/ moniou
10246 common /qgdebug/ debug
10247 common /arr3/ x1(7),a1(7)
10248
10249 qglh=0.d0
10250 if(sy.le.max(1.d0,xp*sgap))goto 1
10251
10252 do ix1=1,7
10253 do mx1=1,2
10254 xpomr1=min(xp,1.d0/sgap)/(sy/max(1.d0,xp*sgap))
10255 * **(.5d0+x1(ix1)*(mx1-1.5d0))
10256 rp=(rq(icdp,icz)-alfp*log(xpomr1))*4.d0*.0389d0
10257 rp1=alfp*log(xpomr1*sy/xp)*4.d0*.0389d0
10258 rp2=rp*rp1/(rp+rp1)
10259 do ix2=1,7
10260 do mx2=1,2
10261 z=.5d0+x1(ix2)*(mx2-1.5d0)
10262 bb0=-rp2*log(z)
10263 do ix3=1,7
10264 do mx3=1,2
10265 phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
10266 bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
10267 * +bb0*sin(phi)**2
10268 bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
10269 * +bb0*sin(phi)**2
10270
10271 vi=qgppdi(xp/xpomr1/sy,iqq)
10272 vpf=qgfani(1.d0/xpomr1,bb2,vvx,0.d0,0.d0,icdp,icz,1)
10273 vpl=qglegc(xp/xpomr1,xp,bb2,vvx,icdp,icz,10)
10274
10275 dpx=vpl*vi*((1.d0-vvx)**2*exp(-2.d0*vpf)-1.d0)
10276 * *(xpomr1/xp)**dels*exp(bb2/rp)*rp
10277 qglh=qglh+a1(ix1)*a1(ix2)*a1(ix3)*dpx
10278 enddo
10279 enddo
10280 enddo
10281 enddo
10282 enddo
10283 enddo
10284 qglh=qglh/8.d0*pi*r3p/.0389d0/g3p**2*dlog(sy/max(1.d0,xp*sgap))
10285 */fp(icz)/cd(icdp,icz)/qgppdi(1.d0/sy,iqq)
10286
10287 1 qglh=qglh+1.d0
10288 return
10289 end
10290
10291
10292 double precision function qgcutp(sy,xp,xm,bb,vvx
10293 *,icdp,icdt,icz,iqq)
10294
10295
10296
10297
10298
10299
10300
10301
10302
10303
10304
10305
10306
10307 implicit double precision (a-h,o-z)
10308 integer debug
10309 common /qgarr6/ pi,bm,amws
10310 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
10311 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
10312 common /qgarr18/ alm,qt0,qtf,betp,dgqq
10313 common /qgarr19/ ahl(3)
10314 common /qgarr25/ ahv(3)
10315 common /qgarr26/ factk,fqscal
10316 common /qgarr43/ moniou
10317 common /qgdebug/ debug
10318 common /arr3/ x1(7),a1(7)
10319
10320 qgcutp=0.d0
10321 if(sy.le.max(1.d0,xp*sgap)*max(1.d0,xm*sgap))goto 2
10322
10323 do ix1=1,7
10324 do mx1=1,2
10325 xpomr1=xp/max(1.d0,xp*sgap)/(sy/max(1.d0,xp*sgap)
10326 * /max(1.d0,xm*sgap))**(.5+x1(ix1)*(mx1-1.5))
10327 rp1=(rq(icdp,icz)-alfp*log(xpomr1))*4.d0*.0389d0
10328 rp2=(rq(icdt,2)+alfp*log(xpomr1*sy/xp/xm))*4.d0*.0389d0
10329 rp=rp1*rp2/(rp1+rp2)
10330 do ib1=1,7
10331 do mb1=1,2
10332 z=.5d0+x1(ib1)*(mb1-1.5d0)
10333 bb0=-rp*dlog(z)
10334 do ib2=1,7
10335 do mb2=1,2
10336 phi=pi*(.5d0+x1(ib2)*(mb2-1.5d0))
10337 bb1=(dsqrt(bb)*rp1/(rp1+rp2)+dsqrt(bb0)*cos(phi))**2
10338 * +bb0*sin(phi)**2
10339 bb2=(dsqrt(bb)*rp2/(rp1+rp2)-dsqrt(bb0)*cos(phi))**2
10340 * +bb0*sin(phi)**2
10341
10342 vpf0=qgfani(1.d0/xpomr1,bb1,vvx,0.d0,0.d0,icdp,icz,1)
10343 vtf0=qgfani(xpomr1*sy/xp/xm,bb2,vvx,0.d0,0.d0,icdt,2,1)
10344 n=1
10345 1 n=n+1
10346 vpf=qgfani(1.d0/xpomr1,bb1,1.d0-(1.d0-vvx)*exp(-vtf0)
10347 * ,0.d0,0.d0,icdp,icz,1)
10348 vtf=qgfani(xpomr1*sy/xp/xm,bb2,1.d0-(1.d0-vvx)*exp(-vpf0)
10349 * ,0.d0,0.d0,icdt,2,1)
10350 if(abs(1.d0-vpf/vpf0)+abs(1.d0-vtf/vtf0).gt.1.d-2.and.n.le.50)
10351 * then
10352 vpf0=vpf
10353 vtf0=vtf
10354 goto 1
10355 endif
10356
10357 if(iqq.eq.1)then
10358 vplt=qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,1)
10359 vtlt=qglegc(xpomr1*sy/xp,xm,bb2,0.d0,icdt,2,1)
10360 vpltloop0=min(vplt,qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,4))
10361 vpltloop=min(vpltloop0,qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,3))
10362 vtltloop0=min(vtlt,qglegc(xpomr1*sy/xp,xm,bb2,0.d0,icdt,2,4))
10363 vtltloop=min(vtltloop0,qglegc(xpomr1*sy/xp,xm,bb2,0.d0
10364 * ,icdt,2,3))
10365 vpltscr=min(vpltloop,qglegc(xp/xpomr1,xp,bb1
10366 * ,1.d0-(1.d0-vvx)*exp(-vtf),icdp,icz,9))
10367 vtltscr=min(vtltloop,qglegc(xpomr1*sy/xp,xm,bb2
10368 * ,1.d0-(1.d0-vvx)*exp(-vpf),icdt,2,9))
10369
10370 dpx=(vpltscr*vtltloop+vtltscr*vpltloop)
10371 * *((1.d0-vvx)**2*exp(-2.d0*vpf-2.d0*vtf)-1.d0)
10372 * +vplt*(vtltloop-vtltloop0)+vtlt*(vpltloop-vpltloop0)
10373 elseif(iqq.eq.2)then
10374 vpls=qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,0)
10375 vtls=qglegc(xpomr1*sy/xp,xm,bb2,0.d0,icdt,2,0)
10376 vplsloop0=min(vpls,qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,6))
10377 vplsloop=min(vplsloop0,qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,5))
10378 vtlsloop0=min(vtls,qglegc(xpomr1*sy/xp,xm,bb2,0.d0,icdt,2,6))
10379 vtlsloop=min(vtlsloop0,qglegc(xpomr1*sy/xp,xm,bb2,0.d0
10380 * ,icdt,2,5))
10381 vplsscr=min(vplsloop,qglegc(xp/xpomr1,xp,bb1
10382 * ,1.d0-(1.d0-vvx)*exp(-vtf),icdp,icz,10))
10383 vtlsscr=min(vtlsloop,qglegc(xpomr1*sy/xp,xm,bb2
10384 * ,1.d0-(1.d0-vvx)*exp(-vpf),icdt,2,10))
10385
10386 dpx=(vplsscr*vtlsloop+vtlsscr*vplsloop)
10387 * *((1.d0-vvx)**2*exp(-2.d0*vpf-2.d0*vtf)-1.d0)
10388 * +vpls*(vtlsloop-vtlsloop0)+vtls*(vplsloop-vplsloop0)
10389 elseif(iqq.eq.3)then
10390 vplq=qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,2)
10391 vtlt=qglegc(xpomr1*sy/xp,xm,bb2,0.d0,icdt,2,1)
10392 vplqloop0=min(vplq,qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,8))
10393 vplqloop=min(vplqloop0
10394 * ,qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,7))
10395 vtltloop0=min(vtlt,qglegc(xpomr1*sy/xp,xm,bb2,0.d0,icdt,2,4))
10396 vtltloop=min(vtltloop0,qglegc(xpomr1*sy/xp,xm,bb2,0.d0
10397 * ,icdt,2,3))
10398 vplqscr=min(vplqloop,qglegc(xp/xpomr1,xp,bb1
10399 * ,1.d0-(1.d0-vvx)*exp(-vtf),icdp,icz,11))
10400 vtltscr=min(vtltloop,qglegc(xpomr1*sy/xp,xm,bb2
10401 * ,1.d0-(1.d0-vvx)*exp(-vpf),icdt,2,9))
10402
10403 dpx=(vplqscr*vtltloop+vtltscr*vplqloop)
10404 * *((1.d0-vvx)**2*exp(-2.d0*vpf-2.d0*vtf)-1.d0)
10405 * +vplq*(vtltloop-vtltloop0)+vtlt*(vplqloop-vplqloop0)
10406 elseif(iqq.eq.4)then
10407 vplq=qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,2)
10408 vtlq=qglegc(xpomr1*sy/xp,xm,bb2,0.d0,icdt,2,2)
10409 vplqloop0=min(vplq,qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,8))
10410 vplqloop=min(vplqloop0
10411 * ,qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,7))
10412 vtlqloop0=min(vtlq,qglegc(xpomr1*sy/xp,xm,bb2,0.d0,icdt,2,8))
10413 vtlqloop=min(vtlqloop0,qglegc(xpomr1*sy/xp,xm,bb2,0.d0
10414 * ,icdt,2,7))
10415 vplqscr=min(vplqloop,qglegc(xp/xpomr1,xp,bb1
10416 * ,1.d0-(1.d0-vvx)*exp(-vtf),icdp,icz,11))
10417 vtlqscr=min(vtlqloop,qglegc(xpomr1*sy/xp,xm,bb2
10418 * ,1.d0-(1.d0-vvx)*exp(-vpf),icdt,2,11))
10419
10420 dpx=(vplqscr*vtlqloop+vtlqscr*vplqloop)
10421 * *((1.d0-vvx)**2*exp(-2.d0*vpf-2.d0*vtf)-1.d0)
10422 * +vplq*(vtlqloop-vtlqloop0)+vtlq*(vplqloop-vplqloop0)
10423 else
10424 dpx=0.d0
10425 endif
10426 qgcutp=qgcutp+a1(ib1)*a1(ib2)*a1(ix1)/z*rp*dpx
10427 enddo
10428 enddo
10429 enddo
10430 enddo
10431 enddo
10432 enddo
10433 qgcutp=qgcutp/16.d0*(r3p*pi/.0389d0)/g3p**3
10434 **dlog(sy/max(1.d0,xp*sgap)/max(1.d0,xm*sgap))
10435
10436 2 continue
10437 rp=(rq(icdp,icz)+rq(icdt,2)+alfp*log(sy/xp/xm))
10438 vs=sy**dels*fp(icz)*fp(2)*sigs/rp
10439 **exp(-bb/rp/4.d0/.0389d0)*cd(icdp,icz)*cd(icdt,2)
10440 vgg=qgpsh(sy,xp,xm,bb,icdp,icdt,icz,0)
10441 vqq=qgpomc(sy,xp,xm,bb,0.d0,icdp,icdt,icz,5)
10442 vqg=qgpsh(sy,xp,xm,bb,icdp,icdt,icz,1)
10443 */dsqrt(xp)*(1.d0-xp)**(ahv(icz)-ahl(icz))
10444 vgq=qgpsh(sy,xp,xm,bb,icdp,icdt,icz,2)
10445 */dsqrt(xm)*(1.d0-xm)**(ahv(2)-ahl(2))
10446 if(iqq.eq.1)then
10447 qgcutp=qgcutp+vs+vgg+vqg+vgq+vqq
10448 elseif(iqq.eq.2)then
10449 qgcutp=qgcutp+vs
10450 elseif(iqq.eq.3)then
10451 qgcutp=qgcutp+vs+vgg+vgq+vqq
10452 elseif(iqq.eq.4)then
10453 qgcutp=qgcutp+vs+vgg+vqq
10454 endif
10455 return
10456 end
10457
10458
10459 double precision function qgpsh(sy,xpp,xpm,bb,icdp,icdt,icz,iqq)
10460
10461
10462
10463
10464
10465
10466
10467
10468
10469 implicit double precision (a-h,o-z)
10470 integer debug
10471 common /qgarr6/ pi,bm,amws
10472 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
10473 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
10474 common /qgarr18/ alm,qt0,qtf,betp,dgqq
10475 common /qgarr26/ factk,fqscal
10476 common /qgarr43/ moniou
10477 common /arr3/ x1(7),a1(7)
10478 common /qgdebug/ debug
10479
10480 if(debug.ge.3)write (moniou,201)sy,xpp,xpm,b,vvx0,icdp,icdt
10481 *,icz,iqq
10482 qgpsh=0.d0
10483 s2min=4.d0*fqscal*qt0 !energy threshold for hard interaction
10484 if(s2min/sy.ge.1.d0)then
10485 if(debug.ge.4)write (moniou,202)qgpsh
10486 return
10487 endif
10488
10489 if(iqq.ne.2)then
10490 icv=icz
10491 icq=2
10492 xp=xpp
10493 xm=xpm
10494 icdv=icdp
10495 icdq=icdt
10496 else
10497 icv=2
10498 icq=icz
10499 xp=xpm
10500 xm=xpp
10501 icdq=icdp
10502 icdv=icdt
10503 endif
10504
10505 xmin=(s2min/sy)**(delh-dels)
10506 do i=1,7
10507 do m=1,2
10508 z1=(.5d0*(1.d0+xmin-(2*m-3)*x1(i)*(1.d0-xmin)))
10509 * **(1.d0/(delh-dels))
10510 ww=z1*sy
10511 sjqq=qgjit(qt0,qt0,ww,2,2)
10512 sjqg=qgjit(qt0,qt0,ww,1,2)
10513 sjgg=qgjit(qt0,qt0,ww,1,1)
10514
10515 if(iqq.eq.0)then !gg-Pomeron
10516 st2=0.d0
10517 do j=1,7
10518 do k=1,2
10519 xx=.5d0*(1.d0+x1(j)*(2*k-3))
10520 xph=z1**xx
10521 xmh=z1/xph
10522
10523 glu1=qgppdi(xph,0)
10524 sea1=qgppdi(xph,1)
10525 glu2=qgppdi(xmh,0)
10526 sea2=qgppdi(xmh,1)
10527 st2=st2+a1(j)*(glu1*glu2*sjgg+(glu1*sea2+glu2*sea1)*sjqg
10528 * +sea1*sea2*sjqq)
10529 enddo
10530 enddo
10531 rh=rq(icdp,icz)+rq(icdt,2)-alfp*dlog(xpp*xpm*z1)
10532 qgpsh=qgpsh-a1(i)*dlog(z1)/z1**delh*st2
10533 * *exp(-bb/rh/4.d0/.0389d0)/rh
10534
10535 else !qg-Pomeron
10536 xmh=z1
10537 glu=qgppdi(xmh,0)
10538 sea=qgppdi(xmh,1)
10539 rh=rq(icdp,icz)+rq(icdt,2)-alfp*dlog(xm*xmh)
10540
10541 fst=(glu*sjqg+sea*sjqq)
10542 * *(qggrv(xp,qt0,icv,1)+qggrv(xp,qt0,icv,2))/dsqrt(xp)
10543 * *exp(-bb/rh/4.d0/.0389d0)/rh
10544 qgpsh=qgpsh+a1(i)/z1**delh*fst
10545 endif
10546 enddo
10547 enddo
10548 qgpsh=qgpsh*(1.d0-xmin)/(delh-dels)
10549 if(iqq.eq.0)then
10550 qgpsh=qgpsh*rr**2*fp(icz)*fp(2)*factk/2.d0*pi
10551 * *cd(icdp,icz)*cd(icdt,2)
10552 else
10553 qgpsh=qgpsh*rr*fp(icq)*factk/4.d0
10554 * *cd(icdp,icz)*cd(icdt,2)
10555 endif
10556 if(debug.ge.4)write (moniou,202)qgpsh
10557
10558 201 format(2x,'qgpsh - unintegrated semihard Pomeron eikonal:'
10559 */4x,'sy=',e10.3,2x,'xpp=',e10.3,2x,'xpm=',e10.3,2x,'b=',e10.3
10560 */4x,'vvx0=',e10.3,2x,'icdp=',i1,2x,'icdt=',i1,2x,'icz=',i1
10561 *,2x,'iqq=',i1)
10562 202 format(2x,'qgpsh=',e10.3)
10563 return
10564 end
10565
10566
10567 double precision function qglegc(sy,xp,bb,vvx,icdp,icz,iqq)
10568
10569
10570
10571
10572
10573
10574
10575
10576
10577
10578
10579
10580
10581
10582
10583
10584
10585
10586
10587
10588
10589
10590
10591 implicit double precision (a-h,o-z)
10592 integer debug
10593 dimension wk(3),wj(3),wi(3),wz(3)
10594 common /qgarr6/ pi,bm,amws
10595 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
10596 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
10597 common /qgarr18/ alm,qt0,qtf,betp,dgqq
10598 common /qgarr19/ ahl(3)
10599 common /qgarr20/ spmax
10600 common /qgarr25/ ahv(3)
10601 common /qgarr26/ factk,fqscal
10602 common /qgarr35/ qlegc0(51,10,11,6,8),qlegc(51,10,11,11,30)
10603 common /qgarr43/ moniou
10604 common /qgdebug/ debug
10605
10606 if(debug.ge.3)write (moniou,201)sy,xp,bb,vvx,icdp,icz,iqq
10607
10608 qglegc=0.d0
10609 clegm=0.d0
10610 rp=(rq(icdp,icz)+alfp*log(max(1.d0,sy/xp)))*4.d0*.0389d0
10611 z=exp(-bb/rp)
10612 if(iqq.eq.0.or.iqq.le.11.and.sy.le.sgap*max(1.d0,xp*sgap)
10613 * .or.iqq.gt.11.and.sy.le.max(1.d0,xp*sgap))then
10614 if(iqq.le.11)then
10615 qglegc=sy**dels*fp(icz)*sigs*g3p/rp*4.d0*.0389d0*z*cd(icdp,icz)
10616 else
10617 qglegc=qgppdi(1.d0/sy,iqq-12)
10618 endif
10619 if(debug.ge.4)write (moniou,202)qglegc
10620 return
10621 endif
10622
10623 if(z.gt..2d0)then
10624 zz=5.d0*z+6.d0
10625 else
10626 zz=(-bb/rp-dlog(0.2d0))/2.d0+7.d0
10627 endif
10628 jz=min(9,int(zz))
10629 jz=max(1,jz)
10630 if(zz.lt.1.d0)then
10631 wz(2)=zz-jz
10632 wz(1)=1.d0-wz(2)
10633 izmax=2
10634 else
10635 if(jz.eq.6)jz=5
10636 wz(2)=zz-jz
10637 wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
10638 wz(1)=1.d0-wz(2)+wz(3)
10639 wz(2)=wz(2)-2.d0*wz(3)
10640 izmax=3
10641 endif
10642
10643 if(iqq.le.11)then
10644 yl=max(0.d0,dlog(sy/xp/sgap**2)/dlog(spmax/sgap**2))*50.d0+1.d0
10645 else
10646 yl=max(0.d0,dlog(sy/xp/sgap)/dlog(spmax/sgap))*50.d0+1.d0
10647 endif
10648 k=max(1,int(yl))
10649 k=min(k,49)
10650 wk(2)=yl-k
10651 wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
10652 wk(1)=1.d0-wk(2)+wk(3)
10653 wk(2)=wk(2)-2.d0*wk(3)
10654 iymax=3
10655
10656 if(xp.lt..2d0)then
10657 if(iqq.le.11)then
10658 xl=6.d0-5.d0*log(5.d0*xp)/log(5.d0*xp*sgap/sy)
10659 elseif(sy.gt.1.01d0*xp*sgap)then
10660 xl=6.d0-5.d0*log(5.d0*xp)/log(xp*sgap/sy)
10661 else
10662 xl=1.d0
10663 endif
10664 else
10665 xl=5.d0*xp+5.d0
10666 endif
10667 i=min(8,int(xl))
10668 i=max(1,i)
10669 if(i.eq.5)i=4
10670 wi(2)=xl-i
10671 wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
10672 wi(1)=1.d0-wi(2)+wi(3)
10673 wi(2)=wi(2)-2.d0*wi(3)
10674 ixmax=3
10675
10676 if(iqq.lt.9)then
10677 do k1=1,iymax
10678 k2=k+k1-1
10679 do i1=1,ixmax
10680 i2=i+i1-1
10681 do l1=1,izmax
10682 l2=jz+l1-1
10683 qglegc=qglegc+qlegc0(k2,i2,l2,icdp+2*(icz-1),iqq)
10684 * *wk(k1)*wi(i1)*wz(l1)
10685 enddo
10686 enddo
10687 enddo
10688 if(zz.lt.1.d0)then
10689 do k1=1,iymax
10690 k2=k+k1-1
10691 do i1=1,ixmax
10692 i2=i+i1-1
10693 clegm=clegm+qlegc0(k2,i2,1,icdp+2*(icz-1),iqq)*wk(k1)*wi(i1)
10694 enddo
10695 enddo
10696 qglegc=min(qglegc,clegm)
10697 endif
10698 else
10699 vl=max(1.d0,vvx*10.d0+1.d0)
10700 if(vl.lt.2.d0)then
10701 j=1
10702 wj(2)=vl-j
10703 wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
10704 wj(1)=1.d0-wj(2)+wj(3)
10705 wj(2)=wj(2)-2.d0*wj(3)
10706 ivmax=3
10707 else
10708 j=min(int(vl),10)
10709 wj(2)=vl-j
10710 wj(1)=1.d0-wj(2)
10711 ivmax=2
10712 endif
10713
10714 do l1=1,izmax
10715 l2=jz+l1-1
10716 do j1=1,ivmax
10717 j2=j+j1-1
10718 do i1=1,ixmax
10719 i2=i+i1-1
10720 do k1=1,iymax
10721 k2=k+k1-1
10722 qglegc=qglegc+qlegc(k2,i2,j2,l2,icdp+2*(icz-1)+6*(iqq-9))
10723 * *wk(k1)*wi(i1)*wz(l1)*wj(j1)
10724 enddo
10725 enddo
10726 enddo
10727 enddo
10728 if(zz.lt.1.d0)then
10729 do j1=1,ivmax
10730 j2=j+j1-1
10731 do i1=1,ixmax
10732 i2=i+i1-1
10733 do k1=1,iymax
10734 k2=k+k1-1
10735 clegm=clegm+qlegc(k2,i2,j2,1,icdp+2*(icz-1)+6*(iqq-9))
10736 * *wk(k1)*wi(i1)*wj(j1)
10737 enddo
10738 enddo
10739 enddo
10740 qglegc=min(qglegc,clegm)
10741 endif
10742 endif
10743 if(iqq.le.11)then
10744 qglegc=exp(qglegc)*qgls(sy,xp,bb,icdp,icz)
10745 else
10746 qglegc=exp(qglegc)*qgppdi(1.d0/sy,iqq-12)
10747 endif
10748 if(debug.ge.4)write (moniou,202)qglegc
10749
10750 201 format(2x,'qglegc - interpolation of Pomeron leg eikonal:'
10751 */4x,'sy=',e10.3,2x,'xp=',e10.3,2x,'b^2=',e10.3,2x,'vvx=',e10.3
10752 *,2x,'icdp=',i1,2x,'icz=',i1,2x,'iqq=',i1)
10753 202 format(2x,'qglegc=',e10.3)
10754 return
10755 end
10756
10757
10758 double precision function qgpomc(sy,xp,xm,bb,vvx
10759 *,icdp,icdt,icz,iqq)
10760
10761
10762
10763
10764
10765
10766
10767
10768
10769
10770
10771
10772
10773
10774 implicit double precision (a-h,o-z)
10775 integer debug
10776 dimension wk(3),wi(3),wj(3),wz(3),wm(3)
10777 common /qgarr6/ pi,bm,amws
10778 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
10779 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
10780 common /qgarr18/ alm,qt0,qtf,betp,dgqq
10781 common /qgarr19/ ahl(3)
10782 common /qgarr20/ spmax
10783 common /qgarr25/ ahv(3)
10784 common /qgarr26/ factk,fqscal
10785 common /qgarr38/ qpomc(11,100,11,11,48)
10786 common /qgarr43/ moniou
10787 common /qgdebug/ debug
10788
10789 if(debug.ge.3)write (moniou,201)sy,xp,xm,bb,vvx
10790 *,icdp,icdt,icz,iqq
10791
10792 qgpomc=0.d0
10793 pomm=0.d0
10794 if(iqq.eq.5)then !qq contribution
10795 s2min=4.d0*fqscal*qt0
10796 if(sy.gt.1.001d0*s2min.and.xp.lt..99d0.and.xm.lt..99d0)then
10797 sj=qgjit(qt0,qt0,sy,2,2)
10798 qgpomc=sj*factk*(qggrv(xp,qt0,icz,1)+qggrv(xp,qt0,icz,2))
10799 * *(qggrv(xm,qt0,2,1)+qggrv(xm,qt0,2,2))/xp/xm
10800 * *(1.d0-xp)**(ahv(icz)-ahl(icz))*(1.d0-xm)**(ahv(2)-ahl(2))
10801 * *exp(-bb/(4.d0*.0389d0*(rq(icdp,icz)+rq(icdt,2))))
10802 * /(8.d0*pi*(rq(icdp,icz)+rq(icdt,2)))*cd(icdp,icz)*cd(icdt,2)
10803 endif
10804 if(debug.ge.4)write (moniou,202)qgpomc
10805 return
10806 endif
10807
10808 rp=(rq(icdp,icz)+rq(icdt,2)+alfp*log(sy/xp/xm))*4.d0*.0389d0
10809 z=exp(-bb/rp)
10810 if(sy.le.max(1.d0,xp*sgap)*max(1.d0,xm*sgap)*1.01d0)then
10811 qgpomc=sy**dels*fp(icz)*fp(2)*sigs*z/rp
10812 * *4.d0*.0389d0*cd(icdp,icz)*cd(icdt,2)
10813 return
10814 endif
10815
10816 if(z.gt..2d0)then
10817 zz=5.d0*z+6.d0
10818 else
10819 zz=(-bb/rp-dlog(0.2d0))/2.d0+7.d0
10820 endif
10821 jz=min(9,int(zz))
10822 jz=max(1,jz)
10823 if(zz.lt.1.d0)then
10824 wz(2)=zz-jz
10825 wz(1)=1.d0-wz(2)
10826 izmax=2
10827 else
10828 if(jz.eq.6)jz=5
10829 wz(2)=zz-jz
10830 wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
10831 wz(1)=1.d0-wz(2)+wz(3)
10832 wz(2)=wz(2)-2.d0*wz(3)
10833 izmax=3
10834 endif
10835
10836 yl=max(0.d0,dlog(sy/xp/xm/sgap**2)
10837 */dlog(spmax/sgap**2))*10.d0+1.d0
10838 k=max(1,int(yl))
10839 k=min(k,9)
10840 wk(2)=yl-k
10841 wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
10842 wk(1)=1.d0-wk(2)+wk(3)
10843 wk(2)=wk(2)-2.d0*wk(3)
10844 iymax=3
10845
10846 if(xp.lt..2d0)then
10847 xl1=6.d0-5.d0*log(5.d0*xp)/log(5.d0*sgap*xp*xm/sy)
10848 else
10849 xl1=5.d0*xp+5.d0
10850 endif
10851 i=min(8,int(xl1))
10852 i=max(1,i)
10853 if(i.eq.5)i=4
10854 wi(2)=xl1-i
10855 wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
10856 wi(1)=1.d0-wi(2)+wi(3)
10857 wi(2)=wi(2)-2.d0*wi(3)
10858 ix1max=3
10859
10860 if(sgap/sy*xm.gt..99d0)then
10861 j=1
10862 wj(1)=1.d0
10863 ix2max=1
10864 else
10865 if(xm.lt..2d0)then
10866 xl2=6.d0-5.d0*log(5.d0*xm)/log(sgap/sy*xm)
10867 else
10868 xl2=5.d0*xm+5.d0
10869 endif
10870 j=min(8,int(xl2))
10871 j=max(1,j)
10872 if(j.eq.5)j=4
10873 wj(2)=xl2-j
10874 wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
10875 wj(1)=1.d0-wj(2)+wj(3)
10876 wj(2)=wj(2)-2.d0*wj(3)
10877 ix2max=3
10878 endif
10879
10880 ml=icdp+2*(icdt-1)+4*(icz-1)+12*(iqq-1)
10881 if(vvx.eq.0.d0)then !hadron-proton collision
10882 do l1=1,izmax
10883 l2=jz+l1-1
10884 do j1=1,ix2max
10885 j2=j+j1-2
10886 do i1=1,ix1max
10887 i2=i+i1-1
10888 do k1=1,iymax
10889 k2=k+k1-1
10890 qgpomc=qgpomc+qpomc(k2,i2+10*j2,l2,1,ml)
10891 * *wk(k1)*wi(i1)*wj(j1)*wz(l1)
10892 enddo
10893 enddo
10894 enddo
10895 enddo
10896 if(zz.lt.1.d0)then
10897 do j1=1,ix2max
10898 j2=j+j1-2
10899 do i1=1,ix1max
10900 i2=i+i1-1
10901 do k1=1,iymax
10902 k2=k+k1-1
10903 pomm=pomm+qpomc(k2,i2+10*j2,1,1,ml)*wk(k1)*wi(i1)*wj(j1)
10904 enddo
10905 enddo
10906 enddo
10907 qgpomc=min(qgpomc,pomm)
10908 endif
10909
10910 else !hA (AA) collision
10911 vl=max(1.d0,vvx*10.d0+1.d0)
10912 if(vl.lt.2.d0)then
10913 m=1
10914 wm(2)=vl-m
10915 wm(3)=wm(2)*(wm(2)-1.d0)*.5d0
10916 wm(1)=1.d0-wm(2)+wm(3)
10917 wm(2)=wm(2)-2.d0*wm(3)
10918 ivmax=3
10919 else
10920 m=min(int(vl),10)
10921 wm(2)=vl-m
10922 wm(1)=1.d0-wm(2)
10923 ivmax=2
10924 endif
10925
10926 do m1=1,ivmax
10927 m2=m+m1-1
10928 do l1=1,izmax
10929 l2=jz+l1-1
10930 do j1=1,ix2max
10931 j2=j+j1-2
10932 do i1=1,ix1max
10933 i2=i+i1-1
10934 do k1=1,iymax
10935 k2=k+k1-1
10936 qgpomc=qgpomc+qpomc(k2,i2+10*j2,l2,m2,ml)
10937 * *wk(k1)*wi(i1)*wj(j1)*wz(l1)*wm(m1)
10938 enddo
10939 enddo
10940 enddo
10941 enddo
10942 enddo
10943 if(zz.lt.1.d0)then
10944 do m1=1,ivmax
10945 m2=m+m1-1
10946 do j1=1,ix2max
10947 j2=j+j1-2
10948 do i1=1,ix1max
10949 i2=i+i1-1
10950 do k1=1,iymax
10951 k2=k+k1-1
10952 pomm=pomm+qpomc(k2,i2+10*j2,1,m2,ml)
10953 * *wk(k1)*wi(i1)*wj(j1)*wm(m1)
10954 enddo
10955 enddo
10956 enddo
10957 enddo
10958 qgpomc=min(qgpomc,pomm)
10959 endif
10960 endif
10961 qgpomc=exp(qgpomc)*z
10962 if(debug.ge.4)write (moniou,202)qgpomc
10963
10964 201 format(2x,'qgpomc - unintegrated cut Pomeron eikonal:'
10965 */4x,'sy=',e10.3,2x,'xp=',e10.3,2x,'xm=',e10.3,2x,'b^2=',e10.3
10966 */4x,'vvx=',e10.3,2x,'icdp=',i1,2x,'icdt=',i1,2x,'icz=',i1
10967 *,2x,'iqq=',i1)
10968 202 format(2x,'qgpomc=',e10.3)
10969 return
10970 end
10971
10972
10973 subroutine qgsha(nbpom,ncola,ncolb,iret)
10974
10975
10976
10977
10978
10979
10980 implicit double precision (a-h,o-z)
10981 integer debug
10982 parameter(iapmax=208,npbmax=1000,npnmax=900,npmax=900
10983 *,legmax=900,njmax=50000)
10984 dimension wppr0(iapmax),wmtg0(iapmax),wppr1(iapmax),wmtg1(iapmax)
10985 *,wppr2(iapmax),wmtg2(iapmax),izp(iapmax),izt(iapmax)
10986 *,ila(iapmax),ilb(iapmax),lva(iapmax),lvb(iapmax)
10987 *,lqa0(iapmax),lqb0(iapmax),ncola(iapmax),ncolb(iapmax)
10988 *,ncola0(iapmax),ncolb0(iapmax)
10989 *,xpomp0(npnmax,iapmax),xpomt0(npnmax,iapmax)
10990 *,xpopin0(npmax,npbmax),xpomin0(npmax,npbmax)
10991 common /qgarr1/ ia(2),icz,icp
10992 common /qgarr2/ scm,wp0,wm0
10993 common /qgarr6/ pi,bm,amws
10994 common /qgarr7/ xa(iapmax,3),xb(iapmax,3),b
10995 common /qgarr9/ iwp(iapmax),iwt(iapmax),lqa(iapmax),lqb(iapmax)
10996 *,iprcn(iapmax),itgcn(iapmax),ias(npbmax),ibs(npbmax),nqs(npbmax)
10997 *,npompr(npbmax),npomtg(npbmax),npomin(npbmax),nnpr(npmax,npbmax)
10998 *,nntg(npmax,npbmax),ilpr(legmax,npbmax),iltg(legmax,npbmax)
10999 *,lnpr(legmax,npbmax),lntg(legmax,npbmax)
11000 *,nbpi(npnmax,iapmax),nbti(npnmax,iapmax),idnpi(npnmax,iapmax)
11001 *,idnti(npnmax,iapmax),nppi(npnmax,iapmax),npti(npnmax,iapmax)
11002 *,nlpi(npnmax,iapmax),nlti(npnmax,iapmax)
11003 common /qgarr11/ b10
11004 common /qgarr12/ nsp
11005 common /qgarr13/ nsf,iaf(iapmax)
11006 common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
11007 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
11008 common /qgarr18/ alm,qt0,qtf,betp,dgqq
11009 common /qgarr23/ bbpom(npbmax),vvxpom(npbmax)
11010 *,bpompr(npnmax,iapmax),bpomtg(npnmax,iapmax)
11011 *,vvxpr(npnmax,iapmax),vvxtg(npnmax,iapmax)
11012 *,xpompr(npnmax,iapmax),xpomtg(npnmax,iapmax)
11013 *,xpopin(npmax,npbmax),xpomin(npmax,npbmax),vvxin(npmax,npbmax)
11014 *,bpomin(npmax,npbmax)
11015 common /qgarr26/ factk,fqscal
11016 common /qgarr37/ eqj(4,njmax),iqj(njmax),ncj(2,njmax),nj
11017 common /qgarr40/ xppr(npnmax,iapmax),xmtg(npnmax,iapmax)
11018 common /qgarr43/ moniou
11019 common /qgdebug/ debug
11020 external qgran
11021
11022 if(debug.ge.1)write (moniou,201)nbpom !so161205
11023 nsp0=nsp
11024
11025 do j=1,ia(1)
11026 if(lqa(j).ne.0)then
11027 do i=1,lqa(j)
11028 if(idnpi(i,j).ne.0)xpomp0(i,j)=xpompr(i,j)
11029 enddo
11030 endif
11031 enddo
11032 do j=1,ia(2)
11033 if(lqb(j).ne.0)then
11034 do i=1,lqb(j)
11035 if(idnti(i,j).ne.0)xpomt0(i,j)=xpomtg(i,j)
11036 enddo
11037 endif
11038 enddo
11039 if(nbpom.ne.0)then
11040 do nb=1,nbpom !loop over collisions
11041 if(npomin(nb).ne.0)then
11042 do np=1,npomin(nb) !loop over interm. Pomerons in the collision
11043 xpopin0(np,nb)=xpopin(np,nb)
11044 xpomin0(np,nb)=xpomin(np,nb)
11045 enddo
11046 endif
11047 enddo
11048 endif
11049 iret=0
11050 nret=0
11051
11052 1 nsp=nsp0
11053 nj=0
11054
11055 if(iret.ne.0)then !rejection during energy-sharing
11056 nret=nret+1
11057 if(nret.gt.100)return !too many rejections -> redo configuration
11058 endif
11059
11060 do j=1,ia(1)
11061 if(lqa(j).ne.0)then
11062 do i=1,lqa(j)
11063 if(idnpi(i,j).ne.0)xpompr(i,j)=xpomp0(i,j)
11064 enddo
11065 endif
11066 enddo
11067 do j=1,ia(2)
11068 if(lqb(j).ne.0)then
11069 do i=1,lqb(j)
11070 if(idnti(i,j).ne.0)xpomtg(i,j)=xpomt0(i,j)
11071 enddo
11072 endif
11073 enddo
11074 if(nbpom.ne.0)then
11075 do nb=1,nbpom !loop over collisions
11076 if(npomin(nb).ne.0)then
11077 do np=1,npomin(nb) !loop over interm. Pomerons in the collision
11078 xpopin(np,nb)=xpopin0(np,nb)
11079 xpomin(np,nb)=xpomin0(np,nb)
11080 enddo
11081 endif
11082 enddo
11083 endif
11084
11085
11086
11087 if(ia(1).ne.1)then
11088 do i=1,ia(1)
11089 izp(i)=int(2.5d0+qgran(b10)) !i-th projectile nucleon type
11090 enddo
11091 else
11092 izp(1)=icp !projectile hadron type
11093 endif
11094 if(ia(2).ne.1)then
11095 do i=1,ia(2)
11096 izt(i)=int(2.5d0+qgran(b10)) !i-th target nucleon type
11097 enddo
11098 else
11099 izt(1)=2 !target proton
11100 endif
11101
11102 do i=1,ia(1)
11103 lqa0(i)=lqa(i)
11104 lva(i)=0
11105 ncola0(i)=ncola(i)
11106 enddo
11107 do i=1,ia(2)
11108 lqb0(i)=lqb(i)
11109 lvb(i)=0
11110 ncolb0(i)=ncolb(i)
11111 enddo
11112
11113
11114
11115 if(nbpom.ne.0)then
11116 if(debug.ge.1)write (moniou,202)
11117 call qgprox(0) !initial x-configuration
11118 gbl0=qgweix(nbpom) !log-weight for the initial x-configuration
11119 nrej=0
11120 nchange=0
11121 gbnorm=.1d0
11122 gbhmax=-1000.d0
11123
11124 2 continue
11125 call qgprox(1) !proposed x-configuration
11126 gbl=qgweix(nbpom) !log-weight for the proposed x-configuration
11127 gbh=gbl-gbl0-gbnorm !log of acceptance probability
11128 gbhmax=max(gbhmax,gbh)
11129
11130 if(debug.ge.5)write (moniou,203)gbh,nrej,nchange
11131 if(gbh.lt.-50.d0.or.qgran(b10).gt.exp(gbh))then
11132 nrej=nrej+1
11133 if(nrej.gt.100)then !too many rejections
11134 nrej=0
11135 nchange=nchange+1
11136 gbnorm=gbnorm+gbhmax+.5d0 !new normalization of acceptance
11137 gbhmax=-1000.d0
11138 if(debug.ge.4)write (moniou,204)nchange
11139 endif
11140 goto 2 !rejection
11141 endif
11142 endif
11143
11144
11145
11146 if(debug.ge.1)write (moniou,205)
11147 do i=1,ia(1) !loop over proj. nucleons
11148 wppr0(i)=wp0
11149 wppr1(i)=0.d0
11150 wppr2(i)=0.d0
11151 if(lqa(i).ne.0)then
11152 do l=1,lqa(i) !loop over constituent partons
11153 wppr0(i)=wppr0(i)-wp0*xppr(l,i) !subtract Pomeron LC momentum
11154 if(wppr0(i).lt.0.d0)then
11155 wppr0(i)=0.d0
11156 endif
11157 enddo
11158 endif
11159 enddo
11160 do i=1,ia(2) !loop over targ. nucleons
11161 wmtg0(i)=wm0
11162 wmtg1(i)=0.d0
11163 wmtg2(i)=0.d0
11164 if(lqb(i).ne.0)then
11165 do l=1,lqb(i) !loop over constituent partons
11166 wmtg0(i)=wmtg0(i)-wm0*xmtg(l,i) !subtract Pomeron LC momentum
11167 if(wmtg0(i).lt.-1.d-15)stop'w^-<0!!!'
11168 wmtg0(i)=max(0.d0,wmtg0(i))
11169 enddo
11170 endif
11171 enddo
11172
11173
11174
11175 if(debug.ge.1)write (moniou,206)
11176 if(nbpom.ne.0)then
11177 do nb=1,nbpom !loop over collisions
11178 ip=ias(nb) !proj. index
11179 it=ibs(nb) !targ. index
11180 if(nqs(nb).ne.0)then
11181 do np=1,nqs(nb) !loop over single Pomerons in the collision
11182 lnp=nnpr(np,nb) !proj. constituent parton index
11183 lnt=nntg(np,nb) !targ. constituent parton index
11184 wppr1(ip)=wppr1(ip)+xppr(lnp,ip)*wp0 !count Pomeron LC momentum
11185 wmtg1(it)=wmtg1(it)+xmtg(lnt,it)*wm0 !count Pomeron LC momentum
11186 enddo
11187 endif
11188 if(npomin(nb).ne.0)then
11189 do np=1,npomin(nb) !loop over interm. Pomerons in the collision
11190 xpp=xpopin(np,nb)
11191 xpm=xpomin(np,nb)
11192 if(xpp*xpm*scm.gt.1.d0)then
11193 wppr2(ip)=wppr2(ip)+xpp*wp0 !count Pomeron LC momentum
11194 wmtg2(it)=wmtg2(it)+xpm*wm0 !count Pomeron LC momentum
11195 else
11196 xpopin(np,nb)=0.d0
11197 xpomin(np,nb)=0.d0
11198 endif
11199 enddo
11200 endif
11201 if(npompr(nb).ne.0)then
11202 do np=1,npompr(nb) !loop over proj. leg Pomerons in the collision
11203 ipp=ilpr(np,nb) !proj. index
11204 lnp=lnpr(np,nb) !proj. constituent parton index
11205 xpp=xppr(lnp,ipp)
11206 xpm=xpompr(lnp,ipp)
11207 if(xpp*xpm*scm.gt.1.d0)then
11208 wppr1(ipp)=wppr1(ipp)+xpp*wp0 !count Pomeron LC momentum
11209 wmtg2(it)=wmtg2(it)+xpm*wm0 !count Pomeron LC momentum
11210 else
11211 xppr(lnp,ipp)=0.d0
11212 xpompr(lnp,ipp)=0.d0
11213 endif
11214 enddo
11215 endif
11216 if(npomtg(nb).ne.0)then
11217 do np=1,npomtg(nb) !loop over targ. leg Pomerons in the collision
11218 itt=iltg(np,nb) !targ. index
11219 lnt=lntg(np,nb) !targ. constituent parton index
11220 xpp=xpomtg(lnt,itt)
11221 xpm=xmtg(lnt,itt)
11222 if(xpp*xpm*scm.gt.1.d0)then
11223 wppr2(ip)=wppr2(ip)+xpp*wp0 !count Pomeron LC momentum
11224 wmtg1(itt)=wmtg1(itt)+xpm*wm0 !count Pomeron LC momentum
11225 else
11226 xmtg(lnt,itt)=0.d0
11227 xpomtg(lnt,itt)=0.d0
11228 endif
11229 enddo
11230 endif
11231 enddo
11232 endif
11233
11234 do ip=1,ia(1)
11235 if(wppr1(ip)+wppr2(ip).ne.0.d0)then
11236 if(lqa(ip).ne.0)then
11237 do i=1,lqa(ip)
11238 xppr(i,ip)=xppr(i,ip)*(wp0-wppr0(ip)) !renorm. for const. partons
11239 * /(wppr1(ip)+wppr2(ip))
11240 enddo
11241
11242 do nb=1,nbpom
11243 if(ias(nb).eq.ip.and.npomtg(nb)+npomin(nb).ne.0)then
11244 if(npomin(nb).ne.0)then
11245 do np=1,npomin(nb)
11246 xpopin(np,nb)=xpopin(np,nb)*(wp0-wppr0(ip))
11247 * /(wppr1(ip)+wppr2(ip))
11248 enddo
11249 endif
11250 if(npomtg(nb).ne.0)then
11251 do np=1,npomtg(nb)
11252 itt=iltg(np,nb)
11253 lnt=lntg(np,nb)
11254 xpomtg(lnt,itt)=xpomtg(lnt,itt)*(wp0-wppr0(ip))
11255 * /(wppr1(ip)+wppr2(ip))
11256 enddo
11257 endif
11258 endif
11259 enddo
11260
11261 elseif(wppr2(ip).gt.wp0)then
11262 wpt=wp0/sgap/2.d0*4.d0**qgran(b10)
11263 do nb=1,nbpom
11264 if(ias(nb).eq.ip.and.npomtg(nb)+npomin(nb).ne.0)then
11265 if(npomin(nb).ne.0)then
11266 do np=1,npomin(nb)
11267 xpopin(np,nb)=xpopin(np,nb)*wpt/wppr2(ip)
11268 enddo
11269 endif
11270 if(npomtg(nb).ne.0)then
11271 do np=1,npomtg(nb)
11272 itt=iltg(np,nb)
11273 lnt=lntg(np,nb)
11274 xpomtg(lnt,itt)=xpomtg(lnt,itt)*wpt/wppr2(ip)
11275 enddo
11276 endif
11277 endif
11278 enddo
11279 wppr0(ip)=wp0-wpt
11280 else
11281 wppr0(ip)=wp0-wppr2(ip)
11282 endif
11283 endif
11284 enddo
11285
11286 do it=1,ia(2)
11287 if(wmtg1(it)+wmtg2(it).ne.0.d0)then
11288 if(lqb(it).ne.0)then
11289 do i=1,lqb(it)
11290 xmtg(i,it)=xmtg(i,it)*(wm0-wmtg0(it))/(wmtg1(it)+wmtg2(it))
11291 enddo
11292
11293 do nb=1,nbpom
11294 if(ibs(nb).eq.it.and.npompr(nb)+npomin(nb).ne.0)then
11295 if(npomin(nb).ne.0)then
11296 do np=1,npomin(nb)
11297 xpomin(np,nb)=xpomin(np,nb)*(wm0-wmtg0(it))
11298 * /(wmtg1(it)+wmtg2(it))
11299 enddo
11300 endif
11301 if(npompr(nb).ne.0)then
11302 do np=1,npompr(nb)
11303 ipp=ilpr(np,nb)
11304 lnp=lnpr(np,nb)
11305 xpompr(lnp,ipp)=xpompr(lnp,ipp)*(wm0-wmtg0(it))
11306 * /(wmtg1(it)+wmtg2(it))
11307 enddo
11308 endif
11309 endif
11310 enddo
11311
11312 elseif(wmtg2(it).gt.wm0)then
11313 wmt=wm0/sgap/2.d0*4.d0**qgran(b10)
11314 do nb=1,nbpom
11315 if(ibs(nb).eq.it.and.npompr(nb)+npomin(nb).ne.0)then
11316 if(npomin(nb).ne.0)then
11317 do np=1,npomin(nb)
11318 xpomin(np,nb)=xpomin(np,nb)*wmt/wmtg2(it)
11319 enddo
11320 endif
11321 if(npompr(nb).ne.0)then
11322 do np=1,npompr(nb)
11323 ipp=ilpr(np,nb)
11324 lnp=lnpr(np,nb)
11325 xpompr(lnp,ipp)=xpompr(lnp,ipp)*wmt/wmtg2(it)
11326 enddo
11327 endif
11328 endif
11329 enddo
11330 wmtg0(it)=wm0-wmt
11331 else
11332 wmtg0(it)=wm0-wmtg2(it)
11333 endif
11334 endif
11335 enddo
11336
11337
11338
11339 if(debug.ge.1)write (moniou,207)
11340 do ip=1,ia(1) !loop over proj. nucleons
11341 if(iwp(ip).eq.2)then !diffraction dissociation
11342 it=iprcn(ip)
11343 if(debug.ge.2)write (moniou,208)ip,it
11344 if(iwt(it).eq.2)then
11345 call qgdifr(wppr0(ip),wmtg0(it),izp(ip),izt(it),-2,-2,iret)
11346 elseif(iwt(it).eq.-1)then
11347 call qgdifr(wppr0(ip),wmtg0(it),izp(ip),izt(it),-2,0,iret)
11348 elseif(iwt(it).gt.0)then
11349 call qgdifr(wppr0(ip),wmtg0(it),izp(ip),izt(it),-2,-1,iret)
11350 else
11351 stop'wrong connection for diffraction'
11352 endif
11353 if(iret.eq.1)goto 1
11354 endif
11355 enddo
11356
11357 do it=1,ia(2) !loop over targ. nucleons
11358 if(iwt(it).eq.2)then !diffraction dissociation
11359 ip=itgcn(it)
11360 if(debug.ge.2)write (moniou,209)it,ip
11361 if(iwp(ip).eq.-1)then
11362 call qgdifr(wppr0(ip),wmtg0(it),izp(ip),izt(it),0,-2,iret)
11363 elseif(iwp(ip).gt.0.and.iwp(ip).ne.2)then
11364 call qgdifr(wppr0(ip),wmtg0(it),izp(ip),izt(it),-1,-2,iret)
11365 endif
11366 if(iret.eq.1)goto 1
11367 endif
11368 enddo
11369
11370
11371
11372 s2min=4.d0*fqscal*qt0 !threshold energy for a hard process
11373 if(nbpom.ne.0)then
11374 if(debug.ge.1)write (moniou,210)
11375 do npb=1,nbpom !loop over collisions
11376 ip=ias(npb) !proj. index
11377 it=ibs(npb) !targ. index
11378 icdp=iddp(ip) !proj. diffr. eigenstate
11379 icdt=iddt(it) !targ. diffr. eigenstate
11380 bbp=bbpom(npb) !b^2 between proj. and targ.
11381 vvx=vvxpom(npb) !nuclear screening factor
11382 if(debug.ge.1)write (moniou,211)npb,ip,it,bbp,vvx,nqs(npb)
11383 * ,npomin(npb),npompr(npb),npomtg(npb)
11384
11385 if(npomin(npb).ne.0)then
11386 do n=1,npomin(npb) !loop over interm. Pomerons
11387 wpi=xpopin(n,npb)*wp0 !LC+ for the Pomeron
11388 wmi=xpomin(n,npb)*wm0 !LC- for the Pomeron
11389 if(debug.ge.2)write (moniou,212)n,wpi,wmi
11390 if(wpi*wmi.ne.0.d0)then
11391 ic11=0
11392 ic12=0
11393 ic21=0
11394 ic22=0
11395 call qgstr(wpi,wmi,wppr0(ip),wmtg0(it)
11396 * ,ic11,ic12,ic22,ic21,0,0) !string hadronization
11397 endif
11398 enddo
11399 endif
11400
11401 if(nqs(npb).ne.0)then
11402 do n=1,nqs(npb) !loop over single Pomerons
11403 lnp=nnpr(n,npb) !index for proj. constituent
11404 lnt=nntg(n,npb) !index for targ. constituent
11405 lqa0(ip)=lqa0(ip)-1
11406 lqb0(it)=lqb0(it)-1
11407 xpi=xppr(lnp,ip)
11408 xmi=xmtg(lnt,it)
11409 wpi=wp0*xpi !LC+ for the Pomeron
11410 wmi=wm0*xmi !LC- for the Pomeron
11411 sy=wpi*wmi
11412 wtot=qgpomc(sy,xpi,xmi,bbp,vvx,icdp,icdt,icz,1) !total
11413 wsoft=qgpomc(sy,xpi,xmi,bbp,vvx,icdp,icdt,icz,2)!soft interaction
11414 wqg=qgpomc(sy,xpi,xmi,bbp,vvx,icdp,icdt,icz,3) !qg-hard interaction
11415 wgq=qgpomc(sy,xpi,xmi,bbp,vvx,icdp,icdt,icz,4) !gq-hard interaction
11416 wqq=qgpomc(sy,xpi,xmi,bbp,vvx,icdp,icdt,icz,5) !qq-hard interaction
11417 aks=qgran(b10)*wtot
11418 if(debug.ge.2)write (moniou,213)n,wpi,wmi
11419
11420 if(aks.lt.wsoft.or.sy.lt.2.d0*s2min)then !soft string hadronization
11421 if(lqa0(ip).eq.0.and.lva(ip).eq.0)then
11422 call qgixxd(izp(ip),ic11,ic12,icz)
11423 else
11424 ic11=0
11425 ic12=0
11426 endif
11427 if(lqb0(it).eq.0.and.lvb(it).eq.0)then
11428 call qgixxd(izt(it),ic21,ic22,2)
11429 else
11430 ic21=0
11431 ic22=0
11432 endif
11433 call qgstr(wpi,wmi,wppr0(ip),wmtg0(it),ic11,ic12,ic22,ic21
11434 * ,1,1)
11435 else !QCD evolution and hadronization for semi-hard Pomeron
11436 if(lva(ip).eq.0.and.lvb(it).eq.0.and.aks.lt.wsoft+wqq)then
11437 iqq=3
11438 lva(ip)=1
11439 lvb(it)=1
11440 elseif(lva(ip).eq.0.and.aks.gt.wqg)then
11441 iqq=1
11442 lva(ip)=1
11443 elseif(lvb(it).eq.0.and.aks.gt.wgq)then
11444 iqq=2
11445 lvb(it)=1
11446 else
11447 iqq=0
11448 endif
11449
11450 call qghot(wpi,wmi,dsqrt(bbp),vvx,nva,nvb,izp(ip),izt(it)
11451 * ,icdp,icdt,icz,iqq,0) !QCD evolution + jet hadronization
11452 if(iqq.eq.1.or.iqq.eq.3)ila(ip)=nva
11453 if(iqq.eq.2.or.iqq.eq.3)ilb(it)=nvb
11454 endif
11455 enddo
11456 endif
11457
11458 if(npompr(npb).ne.0)then
11459 do l=1,npompr(npb) !loop over proj. leg Pomerons
11460 ipp=ilpr(l,npb) !proj. index
11461 lnp=lnpr(l,npb) !index for proj. constituent
11462 bbpr=bpompr(lnp,ipp) !b^2 for the Pomeron
11463 vvxp=vvxpr(lnp,ipp) !screening factor
11464 lqa0(ipp)=lqa0(ipp)-1
11465 xpi=xppr(lnp,ipp)
11466 xmi=xpompr(lnp,ipp)
11467 wpi=wp0*xpi !LC+ for the Pomeron
11468 wmi=wm0*xmi !LC- for the Pomeron
11469 sy=wpi*wmi
11470 if(sy.ne.0.d0)then
11471 wtot=qglegc(sy,xpi,bbpr,vvxp,iddp(ipp),icz,9) !total
11472 wsoft=qglegc(sy,xpi,bbpr,vvxp,iddp(ipp),icz,10) !soft interaction
11473 wqg=qglegc(sy,xpi,bbpr,vvxp,iddp(ipp),icz,11) !qg-hard interaction
11474 else
11475 wsoft=1.d0
11476 wtot=1.d0
11477 wqg=0.d0
11478 endif
11479 aks=qgran(b10)*wtot
11480 if(debug.ge.2)write (moniou,214)l,wpi,wmi
11481
11482 if(aks.le.wsoft.or.sy.lt.2.d0*s2min)then !soft string hadronization
11483 if(lqa0(ipp).eq.0.and.lva(ipp).eq.0.and.sy.ne.0.d0)then
11484 call qgixxd(izp(ipp),ic11,ic12,icz)
11485 else
11486 ic11=0
11487 ic12=0
11488 endif
11489 ic21=0
11490 ic22=0
11491 call qgstr(wpi,wmi,wppr0(ipp),wmtg0(it),ic11,ic12,ic22,ic21
11492 * ,1,0)
11493
11494 else !QCD evolution and hadronization for semi-hard Pomeron
11495 if(lva(ipp).eq.0.and.aks.gt.wqg)then
11496 iqq=1
11497 lva(ipp)=1
11498 else
11499 iqq=0
11500 endif
11501
11502 call qghot(wpi,wmi,dsqrt(bbpr),vvxp,nva,nvb,izp(ipp),izt(it)
11503 * ,iddp(ipp),icdt,icz,iqq,1) !QCD evolution + jet hadronization
11504 if(iqq.eq.1)ila(ipp)=nva
11505 endif
11506 call qglead(wppr0(ipp),wmtg0(it),lqa(ipp)+1-iwp(ipp)
11507 * ,lqb(it)+1-iwt(it),lqa0(ipp)+ncola0(ipp),lqb0(it)+ncolb0(it)
11508 * ,lva(ipp),lvb(it),izp(ipp),izt(it),ila(ipp),ilb(it),iret) !remnants
11509 if(iret.ne.0)goto 1
11510 enddo
11511 endif
11512
11513 if(npomtg(npb).ne.0)then
11514 do l=1,npomtg(npb) !loop over targ. leg Pomerons
11515 itt=iltg(l,npb) !targ. index
11516 lnt=lntg(l,npb) !index for targ. constituent
11517 bbtg=bpomtg(lnt,itt) !b^2 for the Pomeron
11518 vvxt=vvxtg(lnt,itt) !screening factor
11519 lqb0(itt)=lqb0(itt)-1
11520 xmi=xmtg(lnt,itt)
11521 wmi=wm0*xmi !LC- for the Pomeron
11522 wpi=wp0*xpomtg(lnt,itt) !LC+ for the Pomeron
11523 sy=wpi*wmi
11524 if(sy.ne.0.d0)then
11525 wtot=qglegc(sy,xmi,bbtg,vvxt,iddt(itt),2,9) !tot
11526 wsoft=qglegc(sy,xmi,bbtg,vvxt,iddt(itt),2,10)!soft interaction
11527 wqg=qglegc(sy,xmi,bbtg,vvxt,iddt(itt),2,11) !qg-hard interaction
11528 else
11529 wtot=1.d0
11530 wsoft=1.d0
11531 wqg=0.d0
11532 endif
11533 aks=qgran(b10)*wtot
11534 if(debug.ge.2)write (moniou,215)l,wpi,wmi
11535
11536 if(aks.le.wsoft.or.sy.lt.2.d0*s2min)then !soft string hadronization
11537 ic11=0
11538 ic12=0
11539 if(lqb0(itt).eq.0.and.lvb(itt).eq.0.and.sy.ne.0.d0)then
11540 call qgixxd(izt(itt),ic21,ic22,2)
11541 else
11542 ic21=0
11543 ic22=0
11544 endif
11545 call qgstr(wpi,wmi,wppr0(ip),wmtg0(itt),ic11,ic12,ic22,ic21
11546 * ,0,1)
11547
11548 else !QCD evolution and hadronization for semi-hard Pomeron
11549 if(lvb(itt).eq.0.and.aks.gt.wqg)then
11550 iqq=2
11551 lvb(itt)=1
11552 else
11553 iqq=0
11554 endif
11555
11556 call qghot(wpi,wmi,dsqrt(bbtg),vvxt,nva,nvb,izp(ip),izt(itt)
11557 * ,icdp,iddt(itt),icz,iqq,2) !QCD evolution + jet hadronization
11558 if(iqq.eq.2)ilb(itt)=nvb
11559 endif
11560 call qglead(wppr0(ip),wmtg0(itt),lqa(ip)+1-iwp(ip),lqb(itt)
11561 * +1-iwt(itt),lqa0(ip)+ncola0(ip),lqb0(itt)+ncolb0(itt)
11562 * ,lva(ip),lvb(itt),izp(ip),izt(itt),ila(ip),ilb(itt),iret) !remnants
11563 if(iret.ne.0)goto 1
11564 enddo
11565 endif
11566 ncola0(ip)=ncola0(ip)-1
11567 ncolb0(it)=ncolb0(it)-1
11568 call qglead(wppr0(ip),wmtg0(it),lqa(ip)+1-iwp(ip),lqb(it)
11569 * +1-iwt(it),lqa0(ip)+ncola0(ip),lqb0(it)+ncolb0(it)
11570 * ,lva(ip),lvb(it),izp(ip),izt(it),ila(ip),ilb(it),iret) !remnants
11571 if(iret.ne.0)goto 1
11572 enddo !end of collision loop
11573 endif
11574
11575 if(nj.ne.0)then !arrangement of parton color connections
11576 if(debug.ge.1)write (moniou,216)nj
11577 call qgjarr(jfl)
11578 if(jfl.eq.0)then
11579 iret=1
11580 goto 1
11581 endif
11582 if(debug.ge.1)write (moniou,217)
11583 call qgxjet !jet hadronization
11584 endif
11585 if(debug.ge.1)write (moniou,218)
11586
11587 201 format(2x,'qgsha - inelastic interaction, N of Pomeron blocks:'
11588 *,i4)
11589 202 format(2x,'qgsha: energy-momentum sharing between Pomerons')
11590 203 format(2x,'qgsha: log of acceptance probability - ',e10.3
11591 */4x,'N of rejections - ',i4,2x,'N of renorm. - ',i3)
11592 204 format(2x,'qgsha: new normalization of acceptance,'
11593 *,' N of renorm. - ',i3)
11594 205 format(2x,'qgsha: leading remnant LC momenta')
11595 206 format(2x,'qgsha: momentum conservation '
11596 *,'(correction for 3p-vertexes)')
11597 207 format(2x,'qgsha: treatment of low mass diffraction')
11598 208 format(2x,'qgsha: diffraction of ',i3,'-th proj. nucleon,'
11599 *,' recoil of ',i3,'-th targ. nucleon')
11600 209 format(2x,'qgsha: diffraction of ',i3,'-th targ. nucleon,'
11601 *,' recoil of ',i3,'-th proj. nucleon')
11602 210 format(2x,'qgsha: particle production for all cut Pomerons')
11603 211 format(2x,'qgsha: ',i4,'-th collision, proj. index - ',i3,2x
11604 *,'targ. index - ',i3
11605 */4x,'b^2=',e10.3,2x,'vvx=',e10.3,2x,'N of single Pomerons - ',i3
11606 *,2x,' N of interm. Pomerons - ',i3
11607 */4x,'N of proj. legs - ',i3,2x,'N of targ. legs - ',i3)
11608 212 format(2x,'qgsha: particle production for '
11609 *,i3,'-th interm. Pomeron'
11610 */4x,'light cone momenta for the Pomeron:',2e10.3)
11611 213 format(2x,'qgsha: particle production for '
11612 *,i3,'-th single Pomeron'
11613 */4x,'light cone momenta for the Pomeron:',2e10.3)
11614 214 format(2x,'qgsha: particle production for '
11615 *,i3,'-th proj. leg Pomeron'
11616 */4x,'light cone momenta for the Pomeron:',2e10.3)
11617 215 format(2x,'qgsha: particle production for '
11618 *,i3,'-th targ. leg Pomeron'
11619 */4x,'light cone momenta for the Pomeron:',2e10.3)
11620 216 format(2x,'qgsha: arrangement of color connections for '
11621 *,i5,' final partons')
11622 217 format(2x,'qgsha: jet hadronization')
11623 218 format(2x,'qgsha - end')
11624 return
11625 end
11626
11627
11628 subroutine qgprox(imode)
11629
11630
11631
11632
11633
11634 implicit double precision (a-h,o-z)
11635 integer debug
11636 parameter(iapmax=208,npbmax=1000,npnmax=900,npmax=900,legmax=900)
11637 common /qgarr1/ ia(2),icz,icp
11638 common /qgarr2/ scm,wp0,wm0
11639 common /qgarr6/ pi,bm,amws
11640 common /qgarr9/ iwp(iapmax),iwt(iapmax),lqa(iapmax),lqb(iapmax)
11641 *,iprcn(iapmax),itgcn(iapmax),ias(npbmax),ibs(npbmax),nqs(npbmax)
11642 *,npompr(npbmax),npomtg(npbmax),npomin(npbmax),nnpr(npmax,npbmax)
11643 *,nntg(npmax,npbmax),ilpr(legmax,npbmax),iltg(legmax,npbmax)
11644 *,lnpr(legmax,npbmax),lntg(legmax,npbmax)
11645 *,nbpi(npnmax,iapmax),nbti(npnmax,iapmax),idnpi(npnmax,iapmax)
11646 *,idnti(npnmax,iapmax),nppi(npnmax,iapmax),npti(npnmax,iapmax)
11647 *,nlpi(npnmax,iapmax),nlti(npnmax,iapmax)
11648 common /qgarr11/ b10
11649 common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
11650 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
11651 common /qgarr19/ ahl(3)
11652 common /qgarr23/ bbpom(npbmax),vvxpom(npbmax)
11653 *,bpompr(npnmax,iapmax),bpomtg(npnmax,iapmax)
11654 *,vvxpr(npnmax,iapmax),vvxtg(npnmax,iapmax)
11655 *,xpompr(npnmax,iapmax),xpomtg(npnmax,iapmax)
11656 *,xpopin(npmax,npbmax),xpomin(npmax,npbmax),vvxin(npmax,npbmax)
11657 *,bpomin(npmax,npbmax)
11658 common /qgarr40/ xppr(npnmax,iapmax),xmtg(npnmax,iapmax)
11659 common /qgarr43/ moniou
11660 common /qgdebug/ debug
11661 external qgran
11662
11663 if(debug.ge.3)write (moniou,201)imode
11664
11665 delf=dels
11666 if(imode.eq.0)then !0-configuration (for normalization)
11667 do ip=1,ia(1) !loop over proj. nucleons
11668 if(lqa(ip).ne.0)then
11669 do n=1,lqa(ip) !loop over proj. constituents
11670 if(idnpi(n,ip).eq.0)then
11671 xppr(n,ip)=1.d0/wp0 !LC+ for single Pomeron
11672 else
11673 xppr(n,ip)=1.d0/xpompr(n,ip)/scm !LC+ for leg Pomeron
11674 endif
11675 enddo
11676 endif
11677 enddo
11678 do it=1,ia(2) !loop over targ. nucleons
11679 if(lqb(it).ne.0)then
11680 do n=1,lqb(it) !loop over targ. constituents
11681 if(idnti(n,it).eq.0)then
11682 xmtg(n,it)=1.d0/wm0 !LC- for single Pomeron
11683 else
11684 xmtg(n,it)=1.d0/xpomtg(n,it)/scm !LC- for leg Pomeron
11685 endif
11686 enddo
11687 endif
11688 enddo
11689
11690 else !proposed configuration
11691 do ip=1,ia(1) !loop over proj. nucleons
11692 if(lqa(ip).ne.0)then
11693 xpt=1.d0
11694 do n=1,lqa(ip) !loop over proj. constituents
11695 nrej=0
11696 alfl=ahl(icz)+(lqa(ip)-n)*(1.d0+delf)
11697
11698 gb0=(1.d0-.11d0**(1.d0/(1.d0+delf)))**alfl
11699 * *exp(alfl*(1.d0+delf)*.11d0)*2.d0
11700 1 continue
11701
11702
11703 if(delf.ge.0.d0.and.alfl.ge.0.d0
11704 * .or.delf.lt.0.d0.and.alfl.le.0.d0)then
11705 up=1.d0-qgran(b10)**(1.d0/(1.d0+delf))
11706 if(1.d0-up.lt.1.d-20)goto 1
11707 tp=1.d0-up**(1.d0/(1.d0+alfl))
11708 gb=(tp/(1.d0-up))**delf
11709 elseif(delf.lt.0.d0.and.alfl.gt.0.d0)then
11710 up=-log(1.d0-qgran(b10)*(1.d0-exp(-alfl*(1.d0+delf))))
11711 * /alfl/(1.d0+delf)
11712 tp=up**(1.d0/(1.d0+delf))
11713 gb=(1.d0-tp)**alfl*exp(alfl*(1.d0+delf)*up)/gb0
11714 else
11715 tp=1.d0-qgran(b10)**(1.d0/(1.d0+alfl))
11716 gb=tp**delf
11717 endif
11718 if(qgran(b10).gt.gb)then
11719 nrej=nrej+1
11720 goto 1
11721 endif
11722 xppr(n,ip)=tp*xpt !proposed LC+ for the constituent
11723 xpt=xpt-xppr(n,ip) !LC+ of the remnant
11724 enddo
11725 endif
11726 enddo
11727
11728 do it=1,ia(2) !loop over targ. nucleons
11729 if(lqb(it).ne.0)then
11730 xmt=1.d0
11731 do n=1,lqb(it) !loop over targ. constituents
11732 nrej=0
11733 alfl=ahl(2)+(lqb(it)-n)*(1.d0+delf)
11734
11735 gb0=(1.d0-.11d0**(1.d0/(1.d0+delf)))**alfl
11736 * *exp(alfl*(1.d0+delf)*.11d0)*2.d0
11737 2 continue
11738 if(delf.ge.0.d0.and.alfl.ge.0.d0
11739 * .or.delf.lt.0.d0.and.alfl.le.0.d0)then
11740 up=1.d0-qgran(b10)**(1.d0/(1.d0+delf))
11741 if(1.d0-up.lt.1.d-20)goto 2
11742 tp=1.d0-up**(1.d0/(1.d0+alfl))
11743 gb=(tp/(1.d0-up))**delf
11744 elseif(delf.lt.0.d0.and.alfl.gt.0.d0)then
11745 up=-log(1.d0-qgran(b10)*(1.d0-exp(-alfl*(1.d0+delf))))
11746 * /alfl/(1.d0+delf)
11747 tp=up**(1.d0/(1.d0+delf))
11748 gb=(1.d0-tp)**alfl*exp(alfl*(1.d0+delf)*up)/gb0
11749 else
11750 tp=1.d0-qgran(b10)**(1.d0/(1.d0+alfl))
11751 gb=tp**delf
11752 endif
11753 if(qgran(b10).gt.gb)then
11754 nrej=nrej+1
11755 goto 2
11756 endif
11757 if(qgran(b10).gt.gb)goto 2
11758 xmtg(n,it)=tp*xmt !proposed LC- for the constituent
11759 xmt=xmt-xmtg(n,it) !LC- of the remnant
11760 enddo
11761 endif
11762 enddo
11763 endif
11764 if(debug.ge.4)write (moniou,202)
11765
11766 201 format(2x,'qgprox - propose Pomeron end LC momenta, imode=',i2)
11767 202 format(2x,'qgprox - end')
11768 return
11769 end
11770
11771
11772 double precision function qgweix(nbpom)
11773
11774
11775
11776
11777
11778 implicit double precision (a-h,o-z)
11779 integer debug
11780 parameter(iapmax=208,npbmax=1000,npnmax=900,npmax=900,legmax=900)
11781 common /qgarr1/ ia(2),icz,icp
11782 common /qgarr2/ scm,wp0,wm0
11783 common /qgarr6/ pi,bm,amws
11784 common /qgarr9/ iwp(iapmax),iwt(iapmax),lqa(iapmax),lqb(iapmax)
11785 *,iprcn(iapmax),itgcn(iapmax),ias(npbmax),ibs(npbmax),nqs(npbmax)
11786 *,npompr(npbmax),npomtg(npbmax),npomin(npbmax),nnpr(npmax,npbmax)
11787 *,nntg(npmax,npbmax),ilpr(legmax,npbmax),iltg(legmax,npbmax)
11788 *,lnpr(legmax,npbmax),lntg(legmax,npbmax)
11789 *,nbpi(npnmax,iapmax),nbti(npnmax,iapmax),idnpi(npnmax,iapmax)
11790 *,idnti(npnmax,iapmax),nppi(npnmax,iapmax),npti(npnmax,iapmax)
11791 *,nlpi(npnmax,iapmax),nlti(npnmax,iapmax)
11792 common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
11793 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
11794 common /qgarr23/ bbpom(npbmax),vvxpom(npbmax)
11795 *,bpompr(npnmax,iapmax),bpomtg(npnmax,iapmax)
11796 *,vvxpr(npnmax,iapmax),vvxtg(npnmax,iapmax)
11797 *,xpompr(npnmax,iapmax),xpomtg(npnmax,iapmax)
11798 *,xpopin(npmax,npbmax),xpomin(npmax,npbmax),vvxin(npmax,npbmax)
11799 *,bpomin(npmax,npbmax)
11800 common /qgarr40/ xppr(npnmax,iapmax),xmtg(npnmax,iapmax)
11801 common /qgarr43/ moniou
11802 common /qgdebug/ debug
11803
11804 if(debug.ge.3)write (moniou,201)nbpom
11805
11806 delf=dels
11807 qgweix=0.d0
11808 do npb=1,nbpom !loop over collisions
11809 ip=ias(npb) !proj. index
11810 it=ibs(npb) !targ. index
11811 icdp=iddp(ip) !proj. diffr. eigenstate
11812 icdt=iddt(it) !targ. diffr. eigenstate
11813 bbp=bbpom(npb) !b^2 between proj. and targ.
11814 vvx=vvxpom(npb) !nuclear screening factor
11815 if(nqs(npb).ne.0)then
11816 do n=1,nqs(npb) !loop over single Pomerons
11817 lnp=nnpr(n,npb) !proj. constituent index
11818 lnt=nntg(n,npb) !targ. constituent index
11819 xpp=xppr(lnp,ip) !LC+ for the Pomeron
11820 xpm=xmtg(lnt,it) !LC- for the Pomeron
11821 qgweix=qgweix+dlog(qgpomc(scm*xpp*xpm,xpp,xpm,bbp,vvx
11822 * ,icdp,icdt,icz,1)/(xpp*xpm)**delf) !add single Pomeron contrib.
11823 enddo
11824 endif
11825 if(npompr(npb).ne.0)then
11826 do l=1,npompr(npb) !loop over proj. leg Pomerons
11827 ipp=ilpr(l,npb) !proj. index
11828 lnp=lnpr(l,npb) !proj. constituent index
11829 xpp=xppr(lnp,ipp) !LC+ for the Pomeron
11830 xpomr=1.d0/xpompr(lnp,ipp)/scm !LC+ for the 3P vertex
11831 vvxp=vvxpr(lnp,ipp) !screening factor
11832 bbpr=bpompr(lnp,ipp) !b^2 for the Pomeron
11833 qgweix=qgweix+dlog(qglegc(xpp/xpomr,xpp,bbpr,vvxp
11834 * ,iddp(ipp),icz,9)/xpp**delf) !add leg Pomeron contrib.
11835 enddo
11836 endif
11837 if(npomtg(npb).ne.0)then
11838 do l=1,npomtg(npb) !loop over targ. leg Pomerons
11839 itt=iltg(l,npb) !targ. index
11840 lnt=lntg(l,npb) !targ. constituent index
11841 xpm=xmtg(lnt,itt) !LC- for the Pomeron
11842 xpomr=xpomtg(lnt,itt) !LC+ for the 3P vertex
11843 vvxt=vvxtg(lnt,itt) !screening factor
11844 bbtg=bpomtg(lnt,itt) !b^2 for the Pomeron
11845 qgweix=qgweix+dlog(qglegc(xpomr*scm*xpm,xpm,bbtg,vvxt
11846 * ,iddt(itt),2,9)/xpm**delf) !add leg Pomeron contrib.
11847 enddo
11848 endif
11849 enddo
11850 if(debug.ge.4)write (moniou,202)qgweix
11851
11852 201 format(2x,'qgweix - log-weight of x-configuration,'
11853 *,' N of collisions - ',i4)
11854 202 format(2x,'qgweix=',e10.3)
11855 return
11856 end
11857
11858
11859 subroutine qghot(wpp,wpm,b,vvx,nva,nvb,izp,izt,icdp,icdt,icz,iqq
11860 *,jpt)
11861
11862
11863
11864
11865
11866
11867
11868
11869
11870
11871
11872 implicit double precision (a-h,o-z)
11873 integer debug
11874 character*2 tyq
11875 parameter(njmax=50000)
11876 dimension ept(4),ep3(4),ey(3),ebal(4),
11877 *qmin(2),wp(2),iqc(2),iqp(2),nqc(2),ncc(2,2),
11878 *qv1(30,50),zv1(30,50),qm1(30,50),iqv1(30,50),
11879 *ldau1(30,49),lpar1(30,50),
11880 *qv2(30,50),zv2(30,50),qm2(30,50),iqv2(30,50),
11881 *ldau2(30,49),lpar2(30,50)
11882 parameter(iapmax=208,npbmax=1000,npnmax=900,npmax=900,legmax=900)
11883 common /qgarr2/ scm,wp0,wm0
11884 common /qgarr6/ pi,bm,amws
11885 common /qgarr8/ wwm,be(4),dc(5),deta,almpt,ptdif,ptndi
11886 common /qgarr10/ am(7),ammu
11887 common /qgarr11/ b10
11888 common /qgarr12/ nsp
11889 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
11890 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
11891 common /qgarr18/ alm,qt0,qtf,betp,dgqq
11892 common /qgarr26/ factk,fqscal
11893 common /qgarr37/ eqj(4,njmax),iqj(njmax),ncj(2,njmax),nj
11894 common /qgarr42/ tyq(16)
11895 common /qgarr43/ moniou
11896 common /qgarr51/ epsxmn
11897 common /qgdebug/ debug
11898 external qgran
11899
11900 if(debug.ge.1)write (moniou,201)iqq,wpp,wpm,izp,izt,icdp,icdt
11901 *,icz,jpt,nj
11902
11903 wwgg=0.d0
11904 wwqg=0.d0
11905 wwgq=0.d0
11906 wwqq=0.d0
11907 wpi=0.d0
11908 wmi=0.d0
11909 sjqg=0.d0
11910 sjqq=0.d0
11911 sea1=0.d0
11912 sea2=0.d0
11913 glu1=0.d0
11914 glu2=0.d0
11915 nj0=nj !store number of final partons
11916 nsp0=nsp !store number of final particles
11917
11918 1 sy=wpp*wpm !energy squared for semi-hard inter. (including preevolution)
11919 nj=nj0
11920 nsp=nsp0
11921 s2min=4.d0*fqscal*qt0 !threshold energy
11922 if(sy.lt.s2min)stop'qghot: sy<s2min!!!'
11923
11924 if(iqq.eq.3)then !q_vq_v-ladder
11925 wpi=wpp !LC+ for the hard interaction
11926 wmi=wpm !LC- for the hard interaction
11927 else
11928
11929
11930
11931 xmin=s2min/sy
11932 iq=(iqq+1)/2+1 !auxilliary type of parton (1 - g, 2 - q(q~))
11933 sj=qgjit(qt0,qt0,sy,1,iq) !inclusive parton-parton cross-sections
11934 if(iqq.eq.0)then
11935 gb0=-dlog(xmin)*(1.d0-dsqrt(xmin))**(2.d0*betp)*sj
11936 else
11937 gb0=(1.d0-xmin)**betp*sj
11938 endif
11939 if(jpt.eq.0)then !single Pomeron
11940 if(iqq.eq.0)then
11941 rp0=(rq(icdp,icz)+rq(icdt,2)+alfp*dlog(scm/s2min))
11942 * *4.d0*.0389d0
11943 gb0=gb0/(rq(icdp,icz)+rq(icdt,2)+alfp*dlog(scm/sy))
11944 * *exp(-b*b/rp0)
11945 elseif(iqq.eq.1)then
11946 rp0=(rq(icdp,icz)+rq(icdt,2)+alfp*dlog(wpp*wm0/s2min))
11947 * *4.d0*.0389d0
11948 gb0=gb0/(rq(icdp,icz)+rq(icdt,2)+alfp*dlog(wm0/wpm))
11949 * *exp(-b*b/rp0)
11950 elseif(iqq.eq.2)then
11951 rp0=(rq(icdp,icz)+rq(icdt,2)+alfp*dlog(wpm*wp0/s2min))
11952 * *4.d0*.0389d0
11953 gb0=gb0/(rq(icdp,icz)+rq(icdt,2)+alfp*dlog(wp0/wpp))
11954 * *exp(-b*b/rp0)
11955 endif
11956 elseif(jpt.eq.1)then !proj. leg Pomeron
11957 if(iqq.eq.0)then
11958 rp0=(rq(icdp,icz)+alfp*dlog(wp0*wpm/s2min))*4.d0*.0389d0
11959 gb0=gb0/(rq(icdp,icz)+alfp*dlog(wp0/wpp))*exp(-b*b/rp0)
11960 elseif(iqq.eq.1)then
11961 rp0=(rq(icdp,icz)+alfp*dlog(sy/s2min))*4.d0*.0389d0
11962 gb0=gb0/rq(icdp,icz)*exp(-b*b/rp0)
11963 endif
11964 elseif(jpt.eq.2)then !targ. leg Pomeron
11965 if(iqq.eq.0)then
11966 rp0=(rq(icdt,2)+alfp*dlog(wm0*wpp/s2min))*4.d0*.0389d0
11967 gb0=gb0/(rq(icdt,2)+alfp*dlog(wm0/wpm))*exp(-b*b/rp0)
11968 elseif(iqq.eq.2)then
11969 rp0=(rq(icdt,2)+alfp*dlog(sy/s2min))*4.d0*.0389d0
11970 gb0=gb0/rq(icdt,2)*exp(-b*b/rp0)
11971 endif
11972 endif
11973
11974
11975
11976 2 zpm=(1.d0-qgran(b10)*(1.d0-xmin**(delh-dels)))
11977 * **(1.d0/(delh-dels))
11978 sjqq=qgjit(qt0,qt0,zpm*sy,2,2) !inclusive qq cross-section
11979 sjqg=qgjit(qt0,qt0,zpm*sy,1,2) !inclusive qg cross-section
11980 sjgg=qgjit(qt0,qt0,zpm*sy,1,1) !inclusive gg cross-section
11981
11982 if(iqq.eq.0)then !gg-ladder
11983 xp=zpm**qgran(b10) !LC+ momentum share
11984 xm=zpm/xp !LC- momentum share
11985 wpi=wpp*xp !LC+ for the hard interaction
11986 wmi=wpm*xm !LC- for the hard interaction
11987 if(jpt.eq.0)then !single Pomeron
11988 rp1=(rq(icdp,icz)+alfp*dlog(wp0/wpi))*4.d0*.0389d0
11989 rp2=(rq(icdt,2)+alfp*dlog(wm0/wmi))*4.d0*.0389d0
11990 rp=rp1*rp2/(rp1+rp2)
11991 z=qgran(b10)
11992 phi=pi*qgran(b10)
11993 b0=dsqrt(-rp*dlog(z))
11994 bb1=(b*rp1/(rp1+rp2)+b0*cos(phi))**2+(b0*sin(phi))**2
11995 bb2=(b*rp2/(rp1+rp2)-b0*cos(phi))**2+(b0*sin(phi))**2
11996
11997 xpomr=wpi/wp0
11998 if(xpomr*sgap.ge.1.d0.or.xpomr*scm.le.sgap)then
11999 vvx1=0.d0
12000 else
12001 v1pnu0=qgfani(1.d0/xpomr,bb1,vvx,0.d0,0.d0,icdp,icz,1)
12002 v1tnu0=qgfani(xpomr*scm,bb2,vvx,0.d0,0.d0,icdt,2,1)
12003 nn=0
12004 21 nn=nn+1
12005 vvxt=1.d0-exp(-v1pnu0)*(1.d0-vvx)
12006 vvxp=1.d0-exp(-v1tnu0)*(1.d0-vvx)
12007 v1pnu=qgfani(1.d0/xpomr,bb1,vvxp,0.d0,0.d0,icdp,icz,1)
12008 v1tnu=qgfani(xpomr*scm,bb2,vvxt,0.d0,0.d0,icdt,2,1)
12009 if((abs(v1pnu0-v1pnu).gt.1.d-1.or.abs(v1tnu0-v1tnu).gt.1.d-1)
12010 * .and.nn.lt.100)then
12011 v1pnu0=v1pnu
12012 v1tnu0=v1tnu
12013 goto 21
12014 endif
12015 vvx1=1.d0-exp(-v1tnu)*(1.d0-vvx)
12016 endif
12017
12018 xpomr=wm0/wmi/scm
12019 if(xpomr*sgap.ge.1.d0.or.xpomr*scm.le.sgap)then
12020 vvx2=0.d0
12021 else
12022 v1pnu0=qgfani(1.d0/xpomr,bb1,vvx,0.d0,0.d0,icdp,icz,1)
12023 v1tnu0=qgfani(xpomr*scm,bb2,vvx,0.d0,0.d0,icdt,2,1)
12024 nn=0
12025 22 nn=nn+1
12026 vvxt=1.d0-exp(-v1pnu0)*(1.d0-vvx)
12027 vvxp=1.d0-exp(-v1tnu0)*(1.d0-vvx)
12028 v1pnu=qgfani(1.d0/xpomr,bb1,vvxp,0.d0,0.d0,icdp,icz,1)
12029 v1tnu=qgfani(xpomr*scm,bb2,vvxt,0.d0,0.d0,icdt,2,1)
12030 if((abs(v1pnu0-v1pnu).gt.1.d-1.or.abs(v1tnu0-v1tnu).gt.1.d-1)
12031 * .and.nn.lt.100)then
12032 v1pnu0=v1pnu
12033 v1tnu0=v1tnu
12034 goto 22
12035 endif
12036 vvx2=1.d0-exp(-v1pnu)*(1.d0-vvx)
12037 endif
12038
12039 glu1=qglegc(1.d0/xp,wpp/wp0,bb1,vvx1,icdp,icz,12) !upper gluon PDF
12040 sea1=qglegc(1.d0/xp,wpp/wp0,bb1,vvx1,icdp,icz,13) !upper quark PDF
12041 glu2=qglegc(1.d0/xm,wpm/wm0,bb2,vvx2,icdt,2,12) !lower gluon PDF
12042 sea2=qglegc(1.d0/xm,wpm/wm0,bb2,vvx2,icdt,2,13) !lower quark PDF
12043 elseif(jpt.eq.1)then !proj. leg Pomeron
12044 rp1=(rq(icdp,icz)+alfp*dlog(wp0/wpi))*4.d0*.0389d0
12045 rp2=-alfp*dlog(xm)*4.d0*.0389d0
12046 rp=rp1*rp2/(rp1+rp2)
12047 z=qgran(b10)
12048 phi=pi*qgran(b10)
12049 b0=dsqrt(-rp*dlog(z))
12050 bb1=(b*rp1/(rp1+rp2)+b0*cos(phi))**2+(b0*sin(phi))**2
12051 bb2=(b*rp2/(rp1+rp2)-b0*cos(phi))**2+(b0*sin(phi))**2
12052
12053 glu1=qglegc(1.d0/xp,wpp/wp0,bb1,vvx,icdp,icz,12) !upper gluon PDF
12054 sea1=qglegc(1.d0/xp,wpp/wp0,bb1,vvx,icdp,icz,13) !upper quark PDF
12055 glu2=qgppdi(xm,0)
12056 sea2=qgppdi(xm,1)
12057 elseif(jpt.eq.2)then !proj. leg Pomeron
12058 rp1=(rq(icdt,2)+alfp*dlog(wm0/wmi))*4.d0*.0389d0
12059 rp2=-alfp*dlog(xp)*4.d0*.0389d0
12060 rp=rp1*rp2/(rp1+rp2)
12061 z=qgran(b10)
12062 phi=pi*qgran(b10)
12063 b0=dsqrt(-rp*dlog(z))
12064 bb1=(b*rp1/(rp1+rp2)+b0*cos(phi))**2+(b0*sin(phi))**2
12065 bb2=(b*rp2/(rp1+rp2)-b0*cos(phi))**2+(b0*sin(phi))**2
12066
12067 glu1=qglegc(1.d0/xm,wpm/wm0,bb1,vvx,icdt,2,12) !upper gluon PDF
12068 sea1=qglegc(1.d0/xm,wpm/wm0,bb1,vvx,icdt,2,13) !upper quark PDF
12069 glu2=qgppdi(xp,0)
12070 sea2=qgppdi(xp,1)
12071 endif
12072 wwgg=glu1*glu2*sjgg
12073 wwqg=sea1*glu2*sjqg
12074 wwgq=glu1*sea2*sjqg
12075 wwqq=sea1*sea2*sjqq
12076 gbyj=-dlog(zpm)*(wwgg+wwqg+wwgq+wwqq)
12077 if(jpt.eq.0)then
12078 rh=rq(icdp,icz)+rq(icdt,2)-alfp*dlog(zpm*sy/scm)
12079 elseif(jpt.eq.1)then
12080 rh=rq(icdp,icz)-alfp*dlog(wpp/wp0*zpm)
12081 elseif(jpt.eq.2)then
12082 rh=rq(icdt,2)-alfp*dlog(wpm/wm0*zpm)
12083 else
12084 rh=0.d0
12085 stop 'Should not happen in qghot'
12086 endif
12087 gbyj=gbyj/rh*exp(-b*b/(4.d0*.0389d0*rh))
12088
12089 else !q_vg-(gq_v-)ladder
12090 if(iqq.eq.1)then !q_vg-ladder
12091 wpi=wpp
12092 wmi=wpm*zpm
12093 xm=zpm
12094 if(jpt.eq.0)then !single Pomeron
12095 rp1=rq(icdp,icz)*4.d0*.0389d0
12096 rp2=(rq(icdt,2)+alfp*dlog(wm0/wmi))*4.d0*.0389d0
12097 rp=rp1*rp2/(rp1+rp2)
12098 z=qgran(b10)
12099 phi=pi*qgran(b10)
12100 b0=dsqrt(-rp*dlog(z))
12101 bb1=(b*rp1/(rp1+rp2)+b0*cos(phi))**2+(b0*sin(phi))**2
12102 bb2=(b*rp2/(rp1+rp2)-b0*cos(phi))**2+(b0*sin(phi))**2
12103
12104 xpomr=wm0/wmi/scm
12105 if(xpomr*sgap.ge.1.d0.or.xpomr*scm.le.sgap)then
12106 vvx2=0.d0
12107 else
12108 v1pnu0=qgfani(1.d0/xpomr,bb1,vvx,0.d0,0.d0,icdp,icz,1)
12109 v1tnu0=qgfani(xpomr*scm,bb2,vvx,0.d0,0.d0,icdt,2,1)
12110 nn=0
12111 23 nn=nn+1
12112 vvxt=1.d0-exp(-v1pnu0)*(1.d0-vvx)
12113 vvxp=1.d0-exp(-v1tnu0)*(1.d0-vvx)
12114 v1pnu=qgfani(1.d0/xpomr,bb1,vvxp,0.d0,0.d0,icdp,icz,1)
12115 v1tnu=qgfani(xpomr*scm,bb2,vvxt,0.d0,0.d0,icdt,2,1)
12116 if((abs(v1pnu0-v1pnu).gt.1.d-1.or.abs(v1tnu0-v1tnu).gt.1.d-1)
12117 * .and.nn.lt.100)then
12118 v1pnu0=v1pnu
12119 v1tnu0=v1tnu
12120 goto 23
12121 endif
12122 vvx2=1.d0-exp(-v1pnu)*(1.d0-vvx)
12123 endif
12124
12125 glu2=qglegc(1.d0/xm,wpm/wm0,bb2,vvx2,icdt,2,12) !upper gluon PDF
12126 sea2=qglegc(1.d0/xm,wpm/wm0,bb2,vvx2,icdt,2,13) !upper quark PDF
12127 wwqg=glu2*sjqg
12128 wwqq=sea2*sjqq
12129 else !leg Pomeron
12130 wwqg=qgppdi(xm,0)*sjqg
12131 wwqq=qgppdi(xm,1)*sjqq
12132 endif
12133 elseif(iqq.eq.2)then !gq_v-ladder
12134 wpi=wpp*zpm
12135 wmi=wpm
12136 xp=zpm
12137 if(jpt.eq.0)then !single Pomeron
12138 rp1=(rq(icdp,icz)+alfp*dlog(wp0/wpi))*4.d0*.0389d0
12139 rp2=rq(icdt,2)*4.d0*.0389d0
12140 rp=rp1*rp2/(rp1+rp2)
12141 z=qgran(b10)
12142 phi=pi*qgran(b10)
12143 b0=dsqrt(-rp*dlog(z))
12144 bb1=(b*rp1/(rp1+rp2)+b0*cos(phi))**2+(b0*sin(phi))**2
12145 bb2=(b*rp2/(rp1+rp2)-b0*cos(phi))**2+(b0*sin(phi))**2
12146
12147 xpomr=wpi/wp0
12148 if(xpomr*sgap.ge.1.d0.or.xpomr*scm.le.sgap)then
12149 vvx1=0.d0
12150 else
12151 v1pnu0=qgfani(1.d0/xpomr,bb1,vvx,0.d0,0.d0,icdp,icz,1)
12152 v1tnu0=qgfani(xpomr*scm,bb2,vvx,0.d0,0.d0,icdt,2,1)
12153 nn=0
12154 24 nn=nn+1
12155 vvxt=1.d0-exp(-v1pnu0)*(1.d0-vvx)
12156 vvxp=1.d0-exp(-v1tnu0)*(1.d0-vvx)
12157 v1pnu=qgfani(1.d0/xpomr,bb1,vvxp,0.d0,0.d0,icdp,icz,1)
12158 v1tnu=qgfani(xpomr*scm,bb2,vvxt,0.d0,0.d0,icdt,2,1)
12159 if((abs(v1pnu0-v1pnu).gt.1.d-1.or.abs(v1tnu0-v1tnu).gt.1.d-1)
12160 * .and.nn.lt.100)then
12161 v1pnu0=v1pnu
12162 v1tnu0=v1tnu
12163 goto 24
12164 endif
12165 vvx1=1.d0-exp(-v1tnu)*(1.d0-vvx)
12166 endif
12167
12168 glu1=qglegc(1.d0/xp,wpp/wp0,bb1,vvx1,icdp,icz,12) !upper gluon PDF
12169 sea1=qglegc(1.d0/xp,wpp/wp0,bb1,vvx1,icdp,icz,13) !upper quark PDF
12170 wwqg=glu1*sjqg
12171 wwqq=sea1*sjqq
12172 else !leg Pomeron
12173 wwqg=qgppdi(xp,0)*sjqg
12174 wwqq=qgppdi(xp,1)*sjqq
12175 endif
12176 endif
12177 gbyj=wwqg+wwqq
12178 if(jpt.eq.0)then
12179 if(iqq.eq.1)then
12180 rh=rq(icdp,icz)+rq(icdt,2)-alfp*dlog(wpm/wm0*zpm)
12181 else
12182 rh=rq(icdp,icz)+rq(icdt,2)-alfp*dlog(wpp/wp0*zpm)
12183 endif
12184 elseif(jpt.eq.1)then
12185 rh=rq(icdp,icz)-alfp*dlog(zpm)
12186 elseif(jpt.eq.2)then
12187 rh=rq(icdt,2)-alfp*dlog(zpm)
12188 else
12189 rh=0.d0
12190 stop 'Should not happen in qghot'
12191 endif
12192 gbyj=gbyj/rh*exp(-b*b/(4.d0*.0389d0*rh))
12193 endif
12194
12195 gbyj=gbyj/gb0/zpm**delh
12196 if(qgran(b10).gt.gbyj)goto 2
12197 endif
12198 if(debug.ge.2)write (moniou,202)wpi*wmi
12199
12200 11 wpi1=wpi
12201 wmi1=wmi
12202 wpq=0.d0
12203 wmq=0.d0
12204 nj=nj0 !initialization for the number of final partons
12205 rrr=qgran(b10)
12206 jqq=0 !gg-ladder
12207 if(iqq.eq.1.or.iqq.eq.2)then
12208 if(rrr.lt.wwqq/(wwqg+wwqq))jqq=1 !q_vq_s-laddder
12209 elseif(iqq.eq.0)then
12210 if(rrr.lt.wwqg/(wwgg+wwqg+wwgq+wwqq))then
12211 jqq=1 !q_sg-ladder
12212 elseif(rrr.lt.(wwqg+wwgq)/(wwgg+wwqg+wwgq+wwqq))then
12213 jqq=2 !gq_s-ladder
12214 elseif(rrr.lt.(wwqg+wwgq+wwqq)/(wwgg+wwqg+wwgq+wwqq))then
12215 jqq=3 !q_sq_s-ladder
12216 endif
12217 endif
12218
12219
12220
12221
12222
12223 if(iqq.ne.0.and.iqq.ne.2)then !q_v from the proj.
12224 call qgvdef(izp,ic1,ic2,icz) !leading state flavor
12225 iqc(1)=ic1 !upper leg parton
12226 nj=nj+1
12227 if(nj.gt.njmax)stop'increase njmax!!!'
12228 nva=nj
12229 iqj(nj)=ic2 !leading jet parton
12230 ncc(1,1)=nj !color connection with leading jet
12231 ncc(2,1)=0
12232 else !g(q_s) from the proj.
12233 nj=nj+1
12234 if(nj.gt.njmax)stop'increase njmax!!!'
12235 if(qgran(b10).lt.dc(2))then
12236 iqj(nj)=-4
12237 else
12238 iqj(nj)=-int(2.d0*qgran(b10)+1.d0)
12239 endif
12240 iqj(nj+1)=-iqj(nj)
12241 wp1=wpp-wpi
12242 wp2=wp1*qgran(b10)
12243 wp1=wp1-wp2
12244 eqj(1,nj)=.5d0*wp1
12245 eqj(2,nj)=eqj(1,nj)
12246 eqj(3,nj)=0.d0
12247 eqj(4,nj)=0.d0
12248 eqj(1,nj+1)=.5d0*wp2
12249 eqj(2,nj+1)=eqj(1,nj+1)
12250 eqj(3,nj+1)=0.d0
12251 eqj(4,nj+1)=0.d0
12252 if(jqq.eq.0.or.iqq.eq.0.and.jqq.eq.2)then
12253 iqc(1)=0
12254 ncc(1,1)=nj
12255 ncc(2,1)=nj+1
12256 nj=nj+1
12257 if(nj.gt.njmax)stop'increase njmax!!!'
12258 else
12259 if(qgran(b10).lt..3333d0)then
12260 iqc(1)=3*(2.d0*int(.5d0+qgran(b10))-1.d0)
12261 else
12262 iqc(1)=int(2.d0*qgran(b10)+1.d0)
12263 * *(2.d0*int(.5d0+qgran(b10))-1.d0)
12264 endif
12265 12 zg=xp+qgran(b10)*(1.d0-xp) !gluon splitting into qq~
12266 if(qgran(b10).gt.zg**dels*((1.d0-xp/zg)/ (1.d0-xp))**betp)
12267 * goto 12
12268 xg=xp/zg
12269 wpq0=wpp*(xg-xp)
12270 wmq=1.d0/wpq0
12271 wmi1=wmi1-wmq
12272 if(wmi1*wpi1.le.s2min)goto 11
12273 nj=nj+2
12274 if(nj.gt.njmax)stop'increase njmax!!!'
12275 iqj(nj)=-iqc(1)
12276 if(iabs(iqc(1)).eq.3)iqj(nj)=iqj(nj)*4/3
12277 eqj(1,nj)=.5d0*wmq
12278 eqj(2,nj)=-.5d0*wmq
12279 eqj(3,nj)=0.d0
12280 eqj(4,nj)=0.d0
12281 if(iqc(1).gt.0)then
12282 ncj(1,nj)=nj-1
12283 ncj(1,nj-1)=nj
12284 ncj(2,nj)=0
12285 ncj(2,nj-1)=0
12286 ncc(1,1)=nj-2
12287 ncc(2,1)=0
12288 else
12289 ncj(1,nj)=nj-2
12290 ncj(1,nj-2)=nj
12291 ncj(2,nj)=0
12292 ncj(2,nj-2)=0
12293 ncc(1,1)=nj-1
12294 ncc(2,1)=0
12295 endif
12296 endif
12297 endif
12298
12299 if((iqq-2)*(iqq-3)*(iqq-4).eq.0)then !q_v from the targ.
12300 call qgvdef(izt,ic1,ic2,2) !leading state flavor
12301 iqc(2)=ic1 !lower leg parton
12302 nj=nj+1
12303 if(nj.gt.njmax)stop'increase njmax!!!'
12304 nvb=nj
12305 iqj(nj)=ic2
12306 ncc(1,2)=nj
12307 ncc(2,2)=0
12308 else
12309 nj=nj+1
12310 if(nj.gt.njmax)stop'increase njmax!!!'
12311 if(qgran(b10).lt.dc(2))then
12312 iqj(nj)=-4
12313 else
12314 iqj(nj)=-int(2.d0*qgran(b10)+1.d0)
12315 endif
12316 iqj(nj+1)=-iqj(nj)
12317 wm1=wpm-wmi
12318 wm2=wm1*qgran(b10)
12319 wm1=wm1-wm2
12320 eqj(1,nj)=.5d0*wm1
12321 eqj(2,nj)=-eqj(1,nj)
12322 eqj(3,nj)=0.d0
12323 eqj(4,nj)=0.d0
12324 eqj(1,nj+1)=.5d0*wm2
12325 eqj(2,nj+1)=-eqj(1,nj+1)
12326 eqj(3,nj+1)=0.d0
12327 eqj(4,nj+1)=0.d0
12328 if(jqq.eq.0.or.iqq.eq.0.and.jqq.eq.1)then
12329 iqc(2)=0
12330 ncc(1,2)=nj
12331 ncc(2,2)=nj+1
12332 nj=nj+1
12333 if(nj.gt.njmax)stop'increase njmax!!!'
12334 else
12335 if(qgran(b10).lt..3333d0)then
12336 iqc(2)=3*(2.d0*int(.5d0+qgran(b10))-1.d0)
12337 else
12338 iqc(2)=int(2.d0*qgran(b10)+1.d0)
12339 * *(2.d0*int(.5d0+qgran(b10))-1.d0)
12340 endif
12341 14 zg=xm+qgran(b10)*(1.d0-xm) !gluon splitting into qq~
12342 if(qgran(b10).gt.zg**dels*((1.d0-xm/zg)/ (1.d0-xm))**betp)
12343 * goto 14
12344 xg=xm/zg
12345 wmq0=wpm*(xg-xm)
12346 wpq=1.d0/wmq0
12347 wpi1=wpi1-wpq
12348 if(wmi1*wpi1.le.s2min)goto 11
12349 nj=nj+2
12350 if(nj.gt.njmax)stop'increase njmax!!!'
12351 iqj(nj)=-iqc(2)
12352 if(iabs(iqc(2)).eq.3)iqj(nj)=iqj(nj)*4/3
12353 eqj(1,nj)=.5d0*wpq
12354 eqj(2,nj)=.5d0*wpq
12355 eqj(3,nj)=0.d0
12356 eqj(4,nj)=0.d0
12357 if(iqc(2).gt.0)then
12358 ncj(1,nj)=nj-1
12359 ncj(1,nj-1)=nj
12360 ncj(2,nj)=0
12361 ncj(2,nj-1)=0
12362 ncc(1,2)=nj-2
12363 ncc(2,2)=0
12364 else
12365 ncj(1,nj)=nj-2
12366 ncj(1,nj-2)=nj
12367 ncj(2,nj)=0
12368 ncj(2,nj-2)=0
12369 ncc(1,2)=nj-1
12370 ncc(2,2)=0
12371 endif
12372 endif
12373 endif
12374
12375 if(jqq.ne.0)then
12376 if(iqq.ne.0.or.iqq.eq.0.and.jqq.eq.3)then
12377 sjqq1=qgjit(qt0,qt0,wpi1*wmi1,2,2)
12378 gbs=sjqq1/sjqq
12379 else
12380 sjqg1=qgjit(qt0,qt0,wpi1*wmi1,1,2)
12381 gbs=sjqg1/sjqg
12382 endif
12383 if(qgran(b10).gt.gbs)goto 11
12384 endif
12385 wpi=wpi1
12386 wmi=wmi1
12387
12388 ept(1)=.5d0*(wpi+wmi) !ladder 4-momentum
12389 ept(2)=.5d0*(wpi-wmi)
12390 ept(3)=0.d0
12391 ept(4)=0.d0
12392 qmin(1)=qt0 !q^2 cutoff for the upper leg
12393 qmin(2)=qt0 !q^2 cutoff for the downer leg
12394 qminn=max(qmin(1),qmin(2)) !overall q^2 cutoff
12395 si=qgnrm(ept)
12396 jini=1
12397 jj=int(1.5d0+qgran(b10)) !1st parton at upper (jj=1) or downer (jj=2) leg
12398
12399 3 continue
12400
12401 aaa=qgnrm(ept) !ladder mass squared
12402 if(debug.ge.3)write (moniou,203)si,iqc,ept,aaa
12403
12404 pt2=ept(3)**2+ept(4)**2
12405 pt=dsqrt(pt2)
12406 ww=si+pt2
12407
12408 iqp(1)=min(1,iabs(iqc(1)))+1
12409 iqp(2)=min(1,iabs(iqc(2)))+1
12410 wp(1)=ept(1)+ept(2) !LC+ for the ladder
12411 wp(2)=ept(1)-ept(2) !LC- for the ladder
12412 s2min=4.d0*fqscal*qminn !minimal energy squared for 2-parton production
12413 if(jini.eq.1)then !general ladder
12414 sj=qgjit(qmin(jj),qmin(3-jj),si,iqp(jj),iqp(3-jj)) !total ladder contribution
12415 sj1=qgjit1(qmin(3-jj),qmin(jj),si,iqp(3-jj),iqp(jj)) !one-way ordered
12416 sjb=qgbit(qmin(1),qmin(2),si,iqp(1),iqp(2)) !born contribution
12417 aks=qgran(b10)
12418 if(aks.lt.sjb/sj)then
12419 goto 6 !born process sampled
12420 elseif(aks.lt.sj1/sj)then !change to one-way ordered ladder
12421 jj=3-jj
12422 sj=sj1
12423 jini=0
12424 endif
12425 else !one-way ordered ladder
12426 sj=qgjit1(qmin(jj),qmin(3-jj),si,iqp(jj),iqp(3-jj)) !one-way ordered
12427 sjb=qgbit(qmin(1),qmin(2),si,iqp(1),iqp(2)) !born contribution
12428 if(qgran(b10).lt.sjb/sj)goto 6 !born process sampled
12429 endif
12430 wwmin=(s2min+qmin(jj)+pt2-2.d0*pt*dsqrt(qmin(jj)*epsxmn))
12431 */(1.d0-epsxmn) !minimal energy squared for 3-parton production
12432
12433 if(debug.ge.3)write (moniou,204)s2min,wwmin,sj,sjb
12434
12435 if(ww.lt.1.1d0*wwmin)goto 6 !energy too low -> born process
12436
12437 xxx=pt*dsqrt(qmin(jj))/ww
12438 xmin=(s2min+qmin(jj)+pt2)/ww
12439 xmin=xmin-2.d0*xxx*(xxx+dsqrt(xxx**2+1.d0-xmin))
12440
12441 xmax=1.d0-epsxmn
12442 if(debug.ge.3)write (moniou,205)xmin,xmax
12443
12444 qqmax=(pt*dsqrt(epsxmn)+dsqrt(max(0.d0,pt2*epsxmn
12445 *+(1.d0+4.d0*fqscal)*(xmax*ww-pt2))))/(1.d0+4.d0*fqscal)
12446 qqmin=qmin(jj) !minimal parton virtuality in the current rung
12447 if(debug.ge.3)write (moniou,206)qqmin,qqmax
12448
12449 qm0=qqmin
12450 xm0=xmax
12451 s2max=xm0*ww
12452
12453 if(jini.eq.1)then
12454 sj0=qgjit(qm0,qmin(3-jj),s2max,1,iqp(3-jj))*qgfap(xm0,iqp(jj),1)
12455 * +qgjit(qm0,qmin(3-jj),s2max,2,iqp(3-jj))*qgfap(xm0,iqp(jj),2)
12456 else
12457 sj0=qgjit1(qm0,qmin(3-jj),s2max,1,iqp(3-jj))
12458 * *qgfap(xm0,iqp(jj),1)
12459 * +qgjit1(qm0,qmin(3-jj),s2max,2,iqp(3-jj))*qgfap(xm0,iqp(jj),2)
12460 endif
12461
12462 gb0=sj0*qm0*qgalf(qm0/alm)*qgsudx(qm0,iqp(jj)) *4.5d0 !normal. of accept.
12463 if(xm0.le..5d0)then
12464 gb0=gb0*xm0**(1.d0-delh)
12465 else
12466 gb0=gb0*(1.d0-xm0)*2.d0**delh
12467 endif
12468 if(debug.ge.3)write (moniou,208)xm0,xmin,xmax,gb0
12469
12470 xmin2=max(.5d0,xmin)
12471 xmin1=xmin**delh
12472 xmax1=min(xmax,.5d0)**delh
12473 if(xmin.ge..5d0)then !choose proposal function
12474 djl=1.d0
12475 elseif(xmax.lt..5d0)then
12476 djl=0.d0
12477 else
12478 djl=1.d0/(1.d0+((2.d0*xmin)**delh-1.d0)/delh
12479 * /dlog(2.d0*(1.d0-xmax)))
12480 endif
12481
12482
12483
12484 4 continue
12485 if(qgran(b10).gt.djl)then
12486 x=(xmin1+qgran(b10)*(xmax1-xmin1))**(1.d0/delh) !parton LC share
12487 else
12488 x=1.d0-(1.d0-xmin2)*((1.d0-xmax)/(1.d0-xmin2))**qgran(b10)
12489 endif
12490 qq=qqmin/(1.d0+qgran(b10)*(qqmin/qqmax-1.d0)) !parton virtuality
12491 qt2=qq*(1.d0-x) !parton p_t^2
12492 if(debug.ge.4)write (moniou,209)qq,qqmin,qqmax,x,qt2
12493
12494 if(qq.gt.qminn)then !update virtuality cutoff
12495 qmin2=qq
12496 else
12497 qmin2=qminn
12498 endif
12499 qt=dsqrt(qt2)
12500 call qgcs(c,s)
12501 ep3(3)=qt*c !final parton p_x, p_y
12502 ep3(4)=qt*s
12503 pt2new=(ept(3)-ep3(3))**2+(ept(4)-ep3(4))**2!p_t^2 for the remained ladder
12504 s2min2=max(s2min,4.d0*fqscal*qmin2) !new ladder kinematic limit
12505 s2=x*ww-qt2*x/(1.d0-x)-pt2new !mass squared for the remained ladder
12506 if(s2.lt.s2min2)goto 4 !ladder mass below threshold -> rejection
12507
12508 if(jini.eq.1)then !weights for g- and q-legs
12509 sj1=qgjit(qq,qmin(3-jj),s2,1,iqp(3-jj))*qgfap(x,iqp(jj),1)
12510 sj2=qgjit(qq,qmin(3-jj),s2,2,iqp(3-jj))*qgfap(x,iqp(jj),2)
12511 else
12512 sj1=qgjit1(qq,qmin(3-jj),s2,1,iqp(3-jj))*qgfap(x,iqp(jj),1)
12513 sj2=qgjit1(qq,qmin(3-jj),s2,2,iqp(3-jj))*qgfap(x,iqp(jj),2)
12514 endif
12515 gb7=(sj1+sj2)*qgalf(qq/alm)*qq*qgsudx(qq,iqp(jj))/gb0 /2.d0
12516 !acceptance probability for x and q**2 simulation
12517 if(x.le..5d0)then
12518 gb7=gb7*x**(1.d0-delh)
12519 else
12520 gb7=gb7*(1.d0-x)*2.d0**delh
12521 endif
12522 if(debug.ge.4)write (moniou,210)gb7,s2,sj1,sj2,jj,jini
12523 if(qgran(b10).gt.gb7)goto 4 !rejection
12524
12525
12526
12527 nqc(2)=0
12528 if(qgran(b10).lt.sj1/(sj1+sj2))then !new gluon-leg ladder
12529 if(iqc(jj).eq.0)then !g -> gg
12530 jt=1
12531 jq=int(1.5d0+qgran(b10))
12532 nqc(1)=ncc(jq,jj) !color connection for the jet
12533 nqc(2)=0
12534 else !q -> qg
12535 jt=2
12536 if(iqc(jj).gt.0)then !orientation of color flow
12537 jq=1
12538 else
12539 jq=2
12540 endif
12541 nqc(1)=0
12542 ncc(jq,jj)=ncc(1,jj) !color connection for the jet
12543 endif
12544 iq1=iqc(jj) !jet flavor (type)
12545 iqc(jj)=0 !new ladder leg flavor (type)
12546
12547 else !new quark-leg ladder
12548 if(iqc(jj).ne.0)then !q -> gq
12549 iq1=0
12550 jt=3
12551 if(iqc(jj).gt.0)then !orientation of color flow
12552 jq=1
12553 else
12554 jq=2
12555 endif
12556 nqc(1)=ncc(1,jj) !color connection for the jet
12557 nqc(2)=0
12558
12559 else !g -> qq~
12560 jq=int(1.5d0+qgran(b10)) !orientation of color flow
12561 iq1=int(3.d0*qgran(b10)+1.d0)*(3-2*jq) !jet flavor (type)
12562 iqc(jj)=-iq1 !new ladder leg flavor (type)
12563 jt=4
12564 nqc(1)=ncc(jq,jj) !color connections for the jet
12565 ncc(1,jj)=ncc(3-jq,jj)
12566 endif
12567 endif
12568 if(debug.ge.3)write (moniou,211)jt
12569
12570 call qgcjet(qt2,iq1,qv1,zv1,qm1,iqv1,ldau1,lpar1,jq) !final state emission
12571 si=x*ww-(qt2+qm1(1,1))*x/(1.d0-x)-pt2new !mass squared for the new ladder
12572 if(si.gt.s2min2)then
12573 iq=min(1,iabs(iqc(jj)))+1
12574 if(jini.eq.1)then
12575 gb=qgjit(qq,qmin(3-jj),si,iq,iqp(3-jj))
12576 * /qgjit(qq,qmin(3-jj),s2,iq,iqp(3-jj))
12577 else
12578 gb=qgjit1(qq,qmin(3-jj),si,iq,iqp(3-jj))
12579 * /qgjit1(qq,qmin(3-jj),s2,iq,iqp(3-jj))
12580 endif
12581 if(qgran(b10).gt.gb)goto 1 !jet mass correction for the acceptance
12582 else !below threshold -> rejection
12583 goto 1
12584 endif
12585
12586 wp3=wp(jj)*(1.d0-x)
12587 wm3=(qt2+qm1(1,1))/wp3
12588 ep3(1)=.5d0*(wp3+wm3) !jet 4-momentum
12589 ep3(2)=.5d0*(wp3-wm3)*(3-2*jj)
12590 call qgrec(ep3,nqc,qv1,zv1,qm1,iqv1,ldau1,lpar1,jq)
12591 !reconstruction of 4-momenta of all final partons
12592
12593
12594 if(jt.eq.1)then
12595 if(ncc(1,jj).eq.0.and.ncc(2,jj).eq.0)ncc(3-jq,jj)=nqc(1)
12596 ncc(jq,jj)=nqc(2)
12597 elseif(jt.eq.2)then
12598 ncc(3-jq,jj)=nqc(1)
12599 elseif(jt.eq.3)then
12600 ncc(1,jj)=nqc(2)
12601 elseif(jt.eq.4.and.ncc(1,jj).eq.0.and.ncc(2,jj).eq.0)then
12602 ncc(1,jj)=nqc(1)
12603 endif
12604
12605 if(iabs(iq1).eq.3)then
12606 iqqq=8+iq1/3*4
12607 else
12608 iqqq=8+iq1
12609 endif
12610 if(debug.ge.3)write (moniou,212)tyq(iqqq),qt2,ep3
12611 do i=1,4
12612 ept(i)=ept(i)-ep3(i) !new ladder 4-momentum
12613 enddo
12614 qmin(jj)=qq !new virtuality cutoffs
12615 qminn=qmin2
12616 goto 3 !consider next parton emission
12617
12618
12619
12620 6 continue
12621 if(debug.ge.2)write (moniou,214)si,qminn,iqc
12622 tmin=qminn*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qminn*fqscal/si)))
12623 qtmin=tmin*(1.d0-tmin/si)
12624 if(iqc(1).ne.0.or.iqc(2).ne.0)then
12625 gb0=tmin**2*qgalf(qtmin/fqscal/alm)**2
12626 * *qgfbor(si,tmin,iqc(1),iqc(2),1) *1.1d0
12627 else
12628 gb0=.25d0*si**2*qgalf(qtmin/fqscal/alm)**2
12629 * *qgfbor(si,.5d0*si,iqc(1),iqc(2),1)
12630 endif
12631 gb0=gb0*qgsudx(qtmin/fqscal,iqp(1))*qgsudx(qtmin/fqscal,iqp(2))
12632 !normalization of acceptance
12633 if(debug.ge.3)write (moniou,215)gb0
12634
12635 7 q2=tmin/(1.d0-qgran(b10)*(1.d0-2.d0*tmin/si)) !proposed q^2
12636 z=q2/si !parton LC momentum share
12637 qt2=q2*(1.d0-z) !parton p_t^2
12638 if(qgran(b10).lt..5d0)then
12639 jm=2
12640 tq=si-q2
12641 else
12642 jm=1
12643 tq=q2
12644 endif
12645 gb=q2**2*qgalf(qt2/fqscal/alm)**2*qgfbor(si,tq,iqc(1),iqc(2),1)
12646 **qgsudx(qt2/fqscal,iqp(1))*qgsudx(qt2/fqscal,iqp(2))/gb0
12647 !acceptance probabilty
12648 if(debug.ge.4)write (moniou,216)gb,q2,z,qt2
12649 if(qgran(b10).gt.gb)goto 7 !rejection
12650
12651
12652
12653 nqc(2)=0
12654 if(iqc(1).eq.0.and.iqc(2).eq.0)then !gg-process
12655 jq=int(1.5d0+qgran(b10)) !orientation of color flow
12656 nqc(1)=ncc(jq,jm)
12657
12658 if(qgran(b10).lt..5d0)then
12659 jt=1 !gg -> gg
12660 nqc(2)=0
12661 njc1=ncc(3-jq,jm) !color connections for 1st jet
12662 njc2=ncc(jq,3-jm)
12663 if(ncc(1,1).eq.0.and.ncc(2,1).eq.0)then
12664 if(jm.eq.1)nqc(1)=njc2
12665 else
12666 if(iqj(njc1).ne.0)then
12667 ncj(1,njc1)=njc2
12668 else
12669 ncj(jq,njc1)=njc2
12670 endif
12671 if(iqj(njc2).ne.0)then
12672 ncj(1,njc2)=njc1
12673 else
12674 ncj(3-jq,njc2)=njc1
12675 endif
12676 endif
12677 else !gg -> gg (inverse color connection)
12678 jt=2
12679 nqc(2)=ncc(3-jq,3-jm)
12680 endif
12681
12682 elseif(iqc(1)*iqc(2).eq.0)then !qg -> qg
12683 if(iqc(1)+iqc(2).gt.0)then !orientation of color flow
12684 jq=1
12685 else
12686 jq=2
12687 endif
12688 if(qgran(b10).lt..5d0)then
12689 if(iqc(jm).eq.0)then
12690 jt=3
12691 nqc(1)=ncc(jq,jm)
12692 nqc(2)=0
12693 njc1=ncc(3-jq,jm)
12694 njc2=ncc(1,3-jm)
12695 if(ncc(1,jm).eq.0.and.ncc(2,jm).eq.0)then
12696 nqc(1)=njc2
12697 else
12698 if(iqj(njc1).ne.0)then
12699 ncj(1,njc1)=njc2
12700 else
12701 ncj(jq,njc1)=njc2
12702 endif
12703 if(iqj(njc2).ne.0)then
12704 ncj(1,njc2)=njc1
12705 else
12706 ncj(3-jq,njc2)=njc1
12707 endif
12708 endif
12709 else
12710 jt=4
12711 nqc(1)=0
12712 njc1=ncc(1,jm)
12713 njc2=ncc(3-jq,3-jm)
12714 if(njc2.ne.0)then
12715 if(iqj(njc1).ne.0)then
12716 ncj(1,njc1)=njc2
12717 else
12718 ncj(3-jq,njc1)=njc2
12719 endif
12720 if(iqj(njc2).ne.0)then
12721 ncj(1,njc2)=njc1
12722 else
12723 ncj(jq,njc2)=njc1
12724 endif
12725 endif
12726 endif
12727 else
12728 if(iqc(jm).eq.0)then
12729 jt=5
12730 nqc(2)=ncc(3-jq,jm)
12731 nqc(1)=ncc(1,3-jm)
12732 else
12733 jt=6
12734 nqc(1)=ncc(jq,3-jm)
12735 endif
12736 endif
12737
12738 elseif(iqc(1)*iqc(2).gt.0)then !qq (q~q~) -> qq (q~q~)
12739 jt=7
12740 if(iqc(1).gt.0)then
12741 jq=1
12742 else
12743 jq=2
12744 endif
12745 nqc(1)=ncc(1,3-jm)
12746 else !qq~ -> qq~
12747 jt=8
12748 if(iqc(jm).gt.0)then
12749 jq=1
12750 else
12751 jq=2
12752 endif
12753 nqc(1)=0
12754 njc1=ncc(1,jm)
12755 njc2=ncc(1,3-jm)
12756 if(iqj(njc1).ne.0)then
12757 ncj(1,njc1)=njc2
12758 else
12759 ncj(3-jq,njc1)=njc2
12760 endif
12761 if(iqj(njc2).ne.0)then
12762 ncj(1,njc2)=njc1
12763 else
12764 ncj(jq,njc2)=njc1
12765 endif
12766 endif
12767 if(jt.ne.8)then
12768 jq2=jq
12769 else
12770 jq2=3-jq
12771 endif
12772 if(debug.ge.3)write (moniou,211)jt
12773 call qgcjet(qt2,iqc(jm),qv1,zv1,qm1,iqv1,ldau1,lpar1,jq)!final state emis.
12774 call qgcjet(qt2,iqc(3-jm),qv2,zv2,qm2,iqv2,ldau2,lpar2,jq2)
12775 amt1=qt2+qm1(1,1)
12776 amt2=qt2+qm2(1,1)
12777 if(dsqrt(si).gt.dsqrt(amt1)+dsqrt(amt2))then
12778 z=qgtwd(si,amt1,amt2)
12779 else
12780 if(debug.ge.4)write (moniou,217)dsqrt(si),dsqrt(amt1),dsqrt(amt2)
12781 goto 1 !below threshold -> rejection
12782 endif
12783
12784 call qgdeft(si,ept,ey)
12785 wp3=z*dsqrt(si)
12786 wm3=(qt2+qm1(1,1))/wp3
12787 ep3(1)=.5d0*(wp3+wm3) !1st jet 4-momentum
12788 ep3(2)=.5d0*(wp3-wm3)
12789 qt=dsqrt(qt2)
12790 call qgcs(c,s)
12791 ep3(3)=qt*c
12792 ep3(4)=qt*s
12793
12794 call qgtran(ep3,ey,1)
12795 call qgrec(ep3,nqc,qv1,zv1,qm1,iqv1,ldau1,lpar1,jq)
12796 !reconstruction of 4-momenta of all final partons
12797 if(iabs(iqc(jm)).eq.3)then
12798 iqqq=8+iqc(jm)/3*4
12799 else
12800 iqqq=8+iqc(jm)
12801 endif
12802 if(debug.ge.3)write (moniou,212)tyq(iqqq),qt2,ep3
12803
12804 wp3=(1.d0-z)*dsqrt(si)
12805 wm3=(qt2+qm2(1,1))/wp3
12806 ep3(1)=.5d0*(wp3+wm3) !2nd jet 4-momentum
12807 ep3(2)=.5d0*(wp3-wm3)
12808 ep3(3)=-qt*c
12809 ep3(4)=-qt*s
12810 call qgtran(ep3,ey,1)
12811
12812
12813
12814 if(jt.eq.1)then
12815 nqc(1)=nqc(2)
12816 if(ncc(1,3-jm).eq.0.and.ncc(2,3-jm).eq.0)then
12817 nqc(2)=ncc(3-jq,jm)
12818 else
12819 nqc(2)=ncc(3-jq,3-jm)
12820 endif
12821 elseif(jt.eq.2)then
12822 if(ncc(1,1).eq.0.and.ncc(2,1).eq.0)then
12823 if(jm.eq.1)then
12824 nqc(2)=nqc(1)
12825 nqc(1)=ncc(jq,3-jm)
12826 else
12827 nqc(1)=nqc(2)
12828 nqc(2)=ncc(3-jq,jm)
12829 endif
12830 else
12831 nqc(2)=ncc(3-jq,jm)
12832 nqc(1)=ncc(jq,3-jm)
12833 endif
12834 elseif(jt.eq.3)then
12835 nqc(1)=nqc(2)
12836 elseif(jt.eq.4)then
12837 nqc(2)=nqc(1)
12838 if(ncc(1,1).eq.0.and.ncc(2,1).eq.0)then
12839 nqc(1)=ncc(1,jm)
12840 else
12841 nqc(1)=ncc(jq,3-jm)
12842 endif
12843 elseif(jt.eq.5)then
12844 if(ncc(1,jm).eq.0.and.ncc(2,jm).eq.0)then
12845 nqc(1)=nqc(2)
12846 else
12847 nqc(1)=ncc(jq,jm)
12848 endif
12849 elseif(jt.eq.6)then
12850 if(ncc(1,3-jm).eq.0.and.ncc(2,3-jm).eq.0)then
12851 nqc(2)=nqc(1)
12852 else
12853 nqc(2)=ncc(3-jq,3-jm)
12854 endif
12855 nqc(1)=ncc(1,jm)
12856 elseif(jt.eq.7)then
12857 nqc(1)=ncc(1,jm)
12858 endif
12859 call qgrec(ep3,nqc,qv2,zv2,qm2,iqv2,ldau2,lpar2,jq2)
12860 !reconstruction of 4-momenta of all final partons
12861 if(iabs(iqc(3-jm)).eq.3)then
12862 iqqq=8+iqc(3-jm)/3*4
12863 else
12864 iqqq=8+iqc(3-jm)
12865 endif
12866 if(debug.ge.3)write (moniou,212)tyq(iqqq),qt2,ep3
12867
12868 ebal(1)=.5d0*(wpp+wpm) !balans of 4-momentum
12869 ebal(2)=.5d0*(wpp-wpm)
12870 ebal(3)=0.d0
12871 ebal(4)=0.d0
12872 do i=nj0+1,nj
12873 if(iqq.eq.0.or.iqq.eq.1.and.i.ne.nva.or.iqq.eq.2
12874 * .and.i.ne.nvb.or.iqq.eq.3.and.i.ne.nva.and.i.ne.nvb)then
12875 do j=1,4
12876 ebal(j)=ebal(j)-eqj(j,i)
12877 enddo
12878 endif
12879 enddo
12880 if(debug.ge.2)write (moniou,218)nj
12881 if(debug.ge.5)write (moniou,219)ebal
12882 if(debug.ge.1)write (moniou,220)
12883
12884 201 format(2x,'qghot - semihard interaction:'/
12885 *4x,'type of the interaction - ',i2/
12886 *4x,'initial light cone momenta - ',2e10.3/
12887 *4x,'remnant types - ',2i3,2x,'diffr. eigenstates - ',2i2/
12888 *4x,'proj. class - ',i2,2x,'Pomeron type - ',i2/
12889 *4x,'initial number of final partons - ',i4)
12890 202 format(2x,'qghot: mass squared for parton ladder - ',e10.3)
12891 203 format(2x,'qghot: ',' mass squared for the laddder:',e10.3/
12892 *4x,'ladder end flavors:',2i3/4x,'ladder 5-momentum: ',5e10.3)
12893 204 format(2x,'qghot: kinematic bounds s2min=',e10.3,
12894 *2x,'wwmin=',e10.3/4x,'jet cross section sj=',e10.3,
12895 *2x,'born cross section sjb=',e10.3)
12896 205 format(2x,'qghot: xmin=',e10.3,2x,'xmax=',e10.3)
12897 206 format(2x,'qghot: qqmin=',e10.3,2x,'qqmax=',e10.3)
12898 208 format(2x,'qghot: xm0=',e10.3,2x,'xmin=',e10.3,2x,
12899 *'xmax=',e10.3,2x,'gb0=',e10.3)
12900 209 format(2x,'qghot: qq=',e10.3,2x,'qqmin=',e10.3,2x,
12901 *'qqmax=',e10.3,2x,'x=',e10.3,2x,'qt2=',e10.3)
12902 210 format(2x,'qghot: gb7=',e10.3,2x,'s2=',e10.3,2x,'sj1=',e10.3
12903 *,2x,'sj2=',e10.3,2x,'jj=',i2,2x,'jini=',i2)
12904 211 format(2x,'qghot: colour connection jt=:',i1)
12905 212 format(2x,'qghot: new jet flavor:',a2,
12906 *' pt squared for the jet:',e10.3/4x,'jet 4-momentum:',4e10.3)
12907 214 format(2x,'qghot - highest virtuality subprocess in the ladder:'/
12908 *4x,'mass squared for the process:',e10.3/4x,'q^2-cutoff:',e10.3
12909 *,2x,'iqc=',2i3)
12910 215 format(2x,'qghot - normalization of acceptance:',' gb0=',e10.3)
12911 216 format(2x,'qghot - acceptance probabilty:'/
12912 *4x,'gb=',e10.3,2x,'q2=',e10.3,2x,'z=',e10.3,2x,'qt2=',e10.3)
12913 217 format(2x,'qghot: ecm=',e10.3,2x,'mt1=',e10.3,2x,'mt2=',e10.3)
12914 218 format(2x,'qghot: total number of jets - ',i4)
12915 219 format(2x,'qghot: 4-momentum balans - ',4e10.3)
12916 220 format(2x,'qghot - end')
12917 return
12918 end
12919
12920
12921 function npgen(vv,npmin,npmax)
12922
12923
12924
12925
12926
12927
12928 implicit double precision (a-h,o-z)
12929 integer debug
12930 common /qgarr11/ b10
12931 common /qgarr43/ moniou
12932 common /qgdebug/ debug
12933 EXTERNAL qgran
12934
12935 if(npmin.eq.0)then
12936 aks=qgran(b10)
12937 vvn=exp(-vv)
12938 do n=1,npmax
12939 aks=aks-vvn
12940 if(aks.lt.0.d0)goto 1
12941 vvn=vvn*vv/dble(n)
12942 enddo
12943 elseif(npmin.eq.1)then
12944 aks=qgran(b10)*(1.d0-exp(-vv))
12945 vvn=exp(-vv)
12946 do n=1,npmax
12947 vvn=vvn*vv/dble(n)
12948 aks=aks-vvn
12949 if(aks.lt.0.d0)goto 2
12950 enddo
12951 elseif(npmin.eq.2)then
12952 aks=qgran(b10)*(1.d0-exp(-vv)*(1.d0+vv))
12953 vvn=vv*exp(-vv)
12954 do n=2,npmax
12955 vvn=vvn*vv/dble(n)
12956 aks=aks-vvn
12957 if(aks.lt.0.d0)goto 2
12958 enddo
12959 else
12960 stop'npgen'
12961 endif
12962 1 n=n-1
12963 2 npgen=n
12964 return
12965 end
12966
12967
12968 subroutine qglead(wppr0,wmtg0,lqa,lqb,lqa0,lqb0,lva,lvb
12969 *,izp,izt,ila,ilb,iret)
12970
12971
12972
12973 implicit double precision (a-h,o-z)
12974 integer debug
12975 parameter(njmax=50000)
12976 common /qgdebug/ debug
12977 common /qgarr37/ eqj(4,njmax),iqj(njmax),ncj(2,njmax),nj
12978
12979 iret=0
12980 if(lqa0.eq.0.and.lqb0.eq.0)then
12981 if(lva.eq.0.and.lvb.eq.0)then
12982 call qgdifr(wppr0,wmtg0,izp,izt,lqa,lqb,iret)
12983 elseif(lva.eq.0)then
12984 call qgdifr(wppr0,wmtg0,izp,izt,lqa,-1,iret)
12985 elseif(lvb.eq.0)then
12986 call qgdifr(wppr0,wmtg0,izp,izt,-1,lqb,iret)
12987 endif
12988 if(lva.eq.1)then
12989 eqj(1,ila)=.5d0*wppr0
12990 eqj(2,ila)=eqj(1,ila)
12991 eqj(3,ila)=0.d0
12992 eqj(4,ila)=0.d0
12993 endif
12994 if(lvb.eq.1)then
12995 eqj(1,ilb)=.5d0*wmtg0
12996 eqj(2,ilb)=-eqj(1,ilb)
12997 eqj(3,ilb)=0.d0
12998 eqj(4,ilb)=0.d0
12999 endif
13000 elseif(lqa0.eq.0)then
13001 if(lva.eq.0)then
13002 call qgdifr(wppr0,wmtg0,izp,izt,lqa,-1,iret)
13003 else
13004 eqj(1,ila)=.5d0*wppr0
13005 eqj(2,ila)=eqj(1,ila)
13006 eqj(3,ila)=0.d0
13007 eqj(4,ila)=0.d0
13008 endif
13009 elseif(lqb0.eq.0)then
13010 if(lvb.eq.0)then
13011 call qgdifr(wppr0,wmtg0,izp,izt,-1,lqb,iret)
13012 else
13013 eqj(1,ilb)=.5d0*wmtg0
13014 eqj(2,ilb)=-eqj(1,ilb)
13015 eqj(3,ilb)=0.d0
13016 eqj(4,ilb)=0.d0
13017 endif
13018 endif
13019 return
13020 end
13021
13022
13023 double precision function qgbit(qi,qj,s,m,l)
13024
13025
13026
13027
13028
13029
13030
13031 implicit double precision (a-h,o-z)
13032 integer debug
13033 dimension wi(3),wk(3)
13034 common /qgarr18/ alm,qt0,qtf,betp,dgqq
13035 common /qgarr20/ spmax
13036 common /qgarr26/ factk,fqscal
13037 common /qgarr31/ csj(40,160)
13038 common /qgarr43/ moniou
13039 common /qgdebug/ debug
13040
13041 if(debug.ge.2)write (moniou,201)qi,qj,s,m,l
13042 qgbit=0.d0
13043 qq=max(qi,qj)
13044 s2min=qq*4.d0*fqscal
13045 if(s.le..99d0*s2min)then
13046 if(debug.ge.3)write (moniou,202)qgbit
13047 return
13048 endif
13049
13050 tmin=qq*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qq*fqscal/s)))
13051 ml=40*(m-1)+80*(l-1)
13052 qli=dlog(qq)/dlog(spmax/4.d0/fqscal)*39.d0+1.d0
13053 sl=dlog(s/s2min)/dlog(spmax/s2min)*39.d0+1.d0
13054 i=min(38,int(qli))
13055 k=min(38,int(sl))
13056
13057 wk(2)=sl-k
13058 wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
13059 wk(1)=1.d0-wk(2)+wk(3)
13060 wk(2)=wk(2)-2.d0*wk(3)
13061 wi(2)=qli-i
13062 wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
13063 wi(1)=1.d0-wi(2)+wi(3)
13064 wi(2)=wi(2)-2.d0*wi(3)
13065 do k1=1,3
13066 k2=k+k1-1+ml
13067 do i1=1,3
13068 qgbit=qgbit+csj(i+i1-1,k2)*wi(i1)*wk(k1)
13069 enddo
13070 enddo
13071 qgbit=exp(qgbit)*(1.d0/tmin-2.d0/s)
13072 if(qi.lt.qq)qgbit=qgbit*qgsudx(qq,m)/qgsudx(qi,m)
13073 if(qj.lt.qq)qgbit=qgbit*qgsudx(qq,l)/qgsudx(qj,l)
13074
13075 if(debug.ge.3)write (moniou,202)qgbit
13076 201 format(2x,'qgbit: qi=',e10.3,2x,'qj=',e10.3
13077 *,2x,'s= ',e10.3,2x,'m= ',i1,2x,'l= ',i1)
13078 202 format(2x,'qgbit=',e10.3)
13079 return
13080 end
13081
13082
13083 double precision function qgfbor(s,t,iq1,iq2,n)
13084
13085
13086
13087
13088
13089
13090
13091 implicit double precision (a-h,o-z)
13092 integer debug
13093 common /qgarr18/ alm,qt0,qtf,betp,dgqq
13094 common /qgarr43/ moniou
13095 common /qgdebug/ debug
13096
13097 if(debug.ge.2)write (moniou,201)s,t,iq1,iq2
13098
13099 u=s-t
13100
13101 qgfbor=0.0
13102 if(n.eq.1)then
13103 if(iq1.eq.0.and.iq2.eq.0)then !gluon-gluon
13104 qgfbor=(3.d0-t*u/s**2+s*u/t**2+s*t/u**2)*4.5d0
13105 elseif(iq1*iq2.eq.0)then !gluon-quark
13106 qgfbor=(s**2+u**2)/t**2+(s/u+u/s)/2.25d0
13107 elseif(iq1.eq.iq2)then !quark-quark (same flavor)
13108 qgfbor=((s**2+u**2)/t**2+(s**2+t**2)/u**2)/2.25d0
13109 * -s**2/t/u/3.375d0
13110 elseif(iq1+iq2.eq.0)then !quark-antiquark (same flavor)
13111 qgfbor=((s**2+u**2)/t**2+(u**2+t**2)/s**2)/2.25d0
13112 * +u**2/t/s/3.375d0
13113 else !quark-antiquark (different flavors)
13114 qgfbor=(s**2+u**2)/t**2/2.25d0
13115 endif
13116 elseif(n.eq.2)then
13117 if(iq1.eq.0.and.iq2.eq.0)then !gluon-gluon->quark-antiquark
13118 qgfbor=.5d0*(t/u+u/t)-1.125d0*(t*t+u*u)/s**2
13119 elseif(iq1+iq2.eq.0)then !quark-antiquark->quark-antiquark
13120 qgfbor=(t*t+u*u)/s**2/1.125d0 !(different flavor)
13121 else
13122 qgfbor=0.d0
13123 endif
13124 elseif(n.eq.3)then
13125 if(iq1.ne.0.and.iq1+iq2.eq.0)then !quark-antiquark->gluon-gluon
13126 qgfbor=32.d0/27.d0*(t/u+u/t)-(t*t+u*u)/s**2/.375d0
13127 else
13128 qgfbor=0.d0
13129 endif
13130 endif
13131
13132 if(debug.ge.2)write (moniou,202)qgfbor
13133 201 format(2x,'qgfbor - hard scattering matrix element squared:'/
13134 *4x,'s=',e10.3,2x,'|t|=',e10.3,2x,'iq1=',i1,2x,'iq2=',i1)
13135 202 format(2x,'qgfbor=',e10.3)
13136 return
13137 end
13138
13139
13140 double precision function qgborn(qi,qj,s,iq1,iq2)
13141
13142
13143
13144
13145
13146
13147 implicit double precision (a-h,o-z)
13148 integer debug
13149 common /qgarr6/ pi,bm,amws
13150 common /qgarr18/ alm,qt0,qtf,betp,dgqq
13151 common /qgarr26/ factk,fqscal
13152 common /qgarr43/ moniou
13153 common /qgdebug/ debug
13154 common /arr3/ x1(7),a1(7)
13155
13156 if(debug.ge.2)write (moniou,201)qi,qj,s,iq1,iq2
13157
13158 qgborn=0.d0
13159 qq=max(qi,qj)
13160 tmin=qq*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qq*fqscal/s)))
13161 do i=1,7
13162 do m=1,2
13163 t=2.d0*tmin/(1.d0+2.d0*tmin/s-x1(i)*(2*m-3)*(1.d0-2.d0*tmin/s))
13164 qt=t*(1.d0-t/s)
13165
13166 fb=0.d0
13167 do n=1,3
13168 fb=fb+qgfbor(s,t,iq1,iq2,n)+qgfbor(s,s-t,iq1,iq2,n)
13169 enddo
13170 fb=fb*qgsudx(qt/fqscal,iabs(iq1)+1)
13171 * *qgsudx(qt/fqscal,iabs(iq2)+1)
13172
13173 qgborn=qgborn+a1(i)*fb*qgalf(qt/fqscal/alm)**2*t**2
13174 enddo
13175 enddo
13176 qgborn=qgborn*2.d0*pi**3/s**2
13177
13178 qgborn=qgborn/qgsudx(qi,iabs(iq1)+1)/qgsudx(qj,iabs(iq2)+1)
13179 if(iq1.eq.iq2)qgborn=qgborn*.5d0
13180
13181 if(debug.ge.3)write (moniou,202)qgborn
13182 201 format(2x,'qgborn: qi=',e10.3,2x,'qj=',e10.3,2x,
13183 *'s= ',e10.3,2x,'iq1= ',i1,2x,'iq2= ',i1)
13184 202 format(2x,'qgborn=',e10.3)
13185 return
13186 end
13187
13188
13189 subroutine qgcjet(qq,iq1,qv,zv,qm,iqv,ldau,lpar,jq)
13190
13191
13192
13193
13194
13195
13196
13197
13198
13199
13200
13201
13202
13203
13204
13205
13206
13207
13208 implicit double precision (a-h,o-z)
13209 integer debug
13210 dimension qmax(30,50),iqm(2),lnv(50),
13211 *qv(30,50),zv(30,50),qm(30,50),iqv(30,50),
13212 *ldau(30,49),lpar(30,50)
13213 common /qgarr11/ b10
13214 common /qgarr18/ alm,qt0,qtf,betp,dgqq
13215 common /qgarr43/ moniou
13216 common /qgdebug/ debug
13217 EXTERNAL qgran
13218
13219 if(debug.ge.2)write (moniou,201)qq,iq1,jq
13220
13221 do i=2,20
13222 lnv(i)=0
13223 enddo
13224 lnv(1)=1
13225 qmax(1,1)=qq
13226 iqv(1,1)=iq1
13227 nlev=1
13228 nrow=1
13229
13230 2 qlmax=dlog(qmax(nrow,nlev)/qtf/16.d0)
13231 iq=min(1,iabs(iqv(nrow,nlev)))+1
13232
13233 if(qgran(b10).gt.qgsudi(qlmax,iq))then
13234 q=qgqint(qlmax,qgran(b10),iq)
13235 z=qgzsim(q,iq)
13236 ll=lnv(nlev+1)+1
13237 ldau(nrow,nlev)=ll
13238 lpar(ll,nlev+1)=nrow
13239 lpar(ll+1,nlev+1)=nrow
13240 lnv(nlev+1)=ll+1
13241
13242 if(iq.ne.1)then
13243 if((3-2*jq)*iqv(nrow,nlev).gt.0)then
13244 iqm(1)=0
13245 iqm(2)=iqv(nrow,nlev)
13246 else
13247 iqm(2)=0
13248 iqm(1)=iqv(nrow,nlev)
13249 z=1.d0-z
13250 endif
13251 else
13252 wg=qgfap(z,1,1)
13253 wg=wg/(wg+qgfap(z,1,2))
13254 if(qgran(b10).lt.wg)then
13255 iqm(1)=0
13256 iqm(2)=0
13257 else
13258 iqm(1)=int(3.d0*qgran(b10)+1.d0)*(3-2*jq)
13259 iqm(2)=-iqm(1)
13260 endif
13261 if(qgran(b10).lt..5d0)z=1.d0-z
13262 endif
13263 qv(nrow,nlev)=q
13264 zv(nrow,nlev)=z
13265 nrow=ll
13266 nlev=nlev+1
13267 qmax(nrow,nlev)=q*z**2
13268 qmax(nrow+1,nlev)=q*(1.d0-z)**2
13269 iqv(nrow,nlev)=iqm(1)
13270 iqv(nrow+1,nlev)=iqm(2)
13271 if(debug.ge.3)write (moniou,203)nlev,nrow,q,z
13272 goto 2
13273 else
13274 qv(nrow,nlev)=0.d0
13275 zv(nrow,nlev)=0.d0
13276 qm(nrow,nlev)=0.d0
13277 if(debug.ge.3)write (moniou,204)nlev,nrow
13278 endif
13279
13280 3 continue
13281 if(nlev.eq.1)then
13282 if(debug.ge.3)write (moniou,202)
13283 return
13284 endif
13285
13286 lprow=lpar(nrow,nlev)
13287 if(ldau(lprow,nlev-1).eq.nrow)then
13288 nrow=nrow+1
13289 goto 2
13290 else
13291 z=zv(lprow,nlev-1)
13292 qm(lprow,nlev-1)=z*(1.d0-z)*qv(lprow,nlev-1)
13293 * +qm(nrow-1,nlev)/z+qm(nrow,nlev)/(1.d0-z)
13294 nrow=lprow
13295 nlev=nlev-1
13296 if(debug.ge.3)write (moniou,205)nlev,nrow,qm(lprow,nlev)
13297 goto 3
13298 endif
13299
13300 201 format(2x,'qgcjet: qq=',e10.3,2x,'iq1= ',i1,2x,'jq=',i1)
13301 202 format(2x,'qgcjet - end')
13302 203 format(2x,'qgcjet: new branching at level nlev=',i2,' nrow=',i2
13303 */4x,' effective momentum q=',e10.3,2x,' z=',e10.3)
13304 204 format(2x,'qgcjet: new final jet at level nlev=',i2,' nrow=',i2)
13305 205 format(2x,'qgcjet: jet mass at level nlev=',i2,' nrow=',i2
13306 *,' - qm=',e10.3)
13307 end
13308
13309
13310 subroutine qgcs(c,s)
13311
13312
13313
13314 implicit double precision (a-h,o-z)
13315 integer debug
13316 common /qgarr11/ b10
13317 common /qgarr43/ moniou
13318 common /qgdebug/ debug
13319 EXTERNAL qgran
13320
13321 if(debug.ge.2)write (moniou,201)
13322 1 s1=2.d0*qgran(b10)-1.d0
13323 s2=2.d0*qgran(b10)-1.d0
13324 s3=s1*s1+s2*s2
13325 if(s3.gt.1.d0)goto 1
13326 s3=dsqrt(s3)
13327 c=s1/s3
13328 s=s2/s3
13329
13330 if(debug.ge.3)write (moniou,202)c,s
13331 201 format(2x,'qgcs - cos(fi) and sin(fi) are generated',
13332 *' (0<fi<2*pi)')
13333 202 format(2x,'qgcs: c=',e10.3,2x,'s=',e10.3)
13334 return
13335 end
13336
13337
13338 subroutine qgdeft(s,ep,ey)
13339
13340
13341
13342
13343 implicit double precision (a-h,o-z)
13344 integer debug
13345 dimension ey(3),ep(4)
13346 common /qgarr43/ moniou
13347 common /qgdebug/ debug
13348
13349 if(debug.ge.2)write (moniou,201)ep,s
13350
13351 do i=1,3
13352 if(ep(i+1).eq.0.d0)then
13353 ey(i)=1.d0
13354 else
13355 wp=ep(1)+ep(i+1)
13356 wm=ep(1)-ep(i+1)
13357 if(wm/wp.lt.1.d-8)then
13358 ww=s
13359 do l=1,3
13360 if(l.ne.i)ww=ww+ep(l+1)**2
13361 enddo
13362 wm=ww/wp
13363 endif
13364 ey(i)=dsqrt(wm/wp)
13365 ep(1)=wp*ey(i)
13366 ep(i+1)=0.d0
13367 endif
13368 enddo
13369
13370 if(debug.ge.3)write (moniou,202)ey
13371 201 format(2x,'qgdeft - lorentz boost parameters:'
13372 */4x,'4-vector ep=',4e10.3/4x,'4-vector squared s=',e10.3)
13373 202 format(2x,'qgdeft: lorentz boost parameters ey(i)=',2x,3e10.3)
13374 return
13375 end
13376
13377
13378 subroutine qgdefr(ep,s0x,c0x,s0,c0)
13379
13380
13381
13382
13383 implicit double precision (a-h,o-z)
13384 integer debug
13385 dimension ep(4)
13386 common /qgarr43/ moniou
13387 common /qgdebug/ debug
13388
13389 if(debug.ge.2)write (moniou,201)ep
13390
13391
13392 pt2=ep(3)**2+ep(4)**2
13393 if(pt2.ne.0.d0)then
13394 pt=dsqrt(pt2)
13395
13396
13397 c0x=ep(3)/pt
13398 s0x=ep(4)/pt
13399
13400 pl=dsqrt(pt2+ep(2)**2)
13401 s0=pt/pl
13402 c0=ep(2)/pl
13403 else
13404 c0x=1.d0
13405 s0x=0.d0
13406 pl=abs(ep(2))
13407 s0=0.d0
13408 c0=ep(2)/pl
13409 endif
13410 ep(2)=pl
13411 ep(3)=0.d0
13412 ep(4)=0.d0
13413
13414 if(debug.ge.3)write (moniou,202)s0x,c0x,s0,c0,ep
13415 201 format(2x,'qgdefr - spacial rotation parameters'/4x,
13416 *'4-vector ep=',2x,4(e10.3,1x))
13417 202 format(2x,'qgdefr: spacial rotation parameters'/
13418 *4x,'s0x=',e10.3,2x,'c0x=',e10.3,2x,'s0=',e10.3,2x,'c0=',e10.3/
13419 *4x,'rotated 4-vector ep=',4(e10.3,1x))
13420 return
13421 end
13422
13423
13424 double precision function qgfap(x,j,l)
13425
13426
13427
13428
13429
13430
13431 implicit double precision (a-h,o-z)
13432 integer debug
13433 common /qgarr43/ moniou
13434 common /qgdebug/ debug
13435
13436 if(debug.ge.2)write (moniou,201)x,j,l
13437
13438 if(j.eq.1)then
13439 if(l.eq.1)then
13440 qgfap=((1.d0-x)/x+x/(1.d0-x)+x*(1.d0-x))*6.d0
13441 else
13442 qgfap=(x**2+(1.d0-x)**2)*3.d0
13443 endif
13444 else
13445 if(l.eq.1)then
13446 qgfap=(1.d0+(1.d0-x)**2)/x/.75d0
13447 else
13448 qgfap=(x**2+1.d0)/(1.d0-x)/.75d0
13449 endif
13450 endif
13451
13452 if(debug.ge.3)write (moniou,202)qgfap
13453 201 format(2x,'qgfap - altarelli-parisi function:'
13454 *,2x,'x=',e10.3,2x,'j=',i1,2x,'l=',i1)
13455 202 format(2x,'qgfap=',e10.3)
13456 return
13457 end
13458
13459
13460 subroutine qggea(ia,xa,jj)
13461
13462
13463
13464
13465 implicit double precision (a-h,o-z)
13466 integer debug
13467 parameter(iapmax=208)
13468 dimension xa(iapmax,3)
13469 common /qgarr5/ rnuc(2),wsnuc(2),wbnuc(2),anorm
13470 *,cr1(2),cr2(2),cr3(2)
13471 common /qgarr6/ pi,bm,amws
13472 common /qgarr11/ b10
13473 common /qgarr43/ moniou
13474 common /qgdebug/ debug
13475 EXTERNAL qgran
13476
13477 if(debug.ge.2)write (moniou,201)jj,ia
13478
13479 if(ia.ge.10)then
13480 do i=1,ia
13481 1 zuk=qgran(b10)*cr1(jj)-1.d0
13482
13483 if(zuk.le.0.d0)then
13484 tt=rnuc(jj)/wsnuc(jj)*(qgran(b10)**.3333d0-1.d0)
13485 goto 6
13486 else
13487 if(zuk.gt.cr2(jj))goto 4
13488 tt=-dlog(qgran(b10))
13489 goto 6
13490 4 if(zuk.gt.cr3(jj))goto 5
13491 tt=-dlog(qgran(b10))-dlog(qgran(b10))
13492 goto 6
13493 5 tt=-dlog(qgran(b10))-dlog(qgran(b10))-dlog(qgran(b10))
13494 endif
13495 6 rim=tt*wsnuc(jj)+rnuc(jj)
13496 if(qgran(b10).gt.(1.d0+wbnuc(jj)*rim**2/rnuc(jj)**2)
13497 * /(1.d0+exp(-abs(tt))))goto 1
13498 z=rim*(2.d0*qgran(b10)-1.d0)
13499 rim=dsqrt(rim*rim-z*z)
13500 xa(i,3)=z
13501 call qgcs(c,s)
13502 xa(i,1)=rim*c
13503 xa(i,2)=rim*s
13504 enddo
13505 else
13506 do l=1,3
13507 summ=0.d0
13508 do i=1,ia-1
13509 j=ia-i
13510 aks=rnuc(jj)*(qgran(b10)+qgran(b10)+qgran(b10)-1.5d0)
13511 k=j+1
13512 xa(k,l)=summ-aks*sqrt(float(j)/k)
13513 summ=summ+aks/sqrt(float(j*k))
13514 enddo
13515 xa(1,l)=summ
13516 enddo
13517 endif
13518
13519 if(debug.ge.3)then
13520 write (moniou,203)
13521 do i=1,ia
13522 write (moniou,204)i,(xa(i,l),l=1,3)
13523 enddo
13524 write (moniou,202)
13525 endif
13526 201 format(2x,'qggea - configuration of the nucleus ',i1,';',2x,
13527 *'coordinates for ',i2,' nucleons')
13528 202 format(2x,'qggea - end')
13529 203 format(2x,'qggea: positions of the nucleons')
13530 204 format(2x,'qggea: ',i2,' - ',3(e10.3,1x))
13531 return
13532 end
13533
13534
13535 double precision function qgapi(x,j,l)
13536
13537
13538
13539
13540
13541
13542 implicit double precision (a-h,o-z)
13543 integer debug
13544 common /qgarr43/ moniou
13545 common /qgdebug/ debug
13546
13547 if(debug.ge.2)write (moniou,201)x,j,l
13548
13549 if(j.eq.1)then
13550 if(l.eq.1)then
13551 qgapi=6.d0*(dlog(x/(1.d0-x))-x**3/3.d0+x**2/2.d0-2.d0*x)
13552 else
13553 qgapi=3.d0*(x+x**3/1.5d0-x*x)
13554 endif
13555 else
13556 if(l.eq.1)then
13557 qgapi=(dlog(x)-x+.25d0*x*x)/.375d0
13558 else
13559 z=1.d0-x
13560 qgapi=-(dlog(z)-z+.25d0*z*z)/.375d0
13561 endif
13562 endif
13563
13564 if(debug.ge.2)write (moniou,202)qgapi
13565 201 format(2x,'qgapi: x=',e10.3,2x,'j= ',i1,2x,'l= ',i1)
13566 202 format(2x,'qgapi=',e10.3)
13567 return
13568 end
13569
13570
13571 subroutine qgjarr(jfl)
13572
13573
13574
13575 implicit double precision (a-h,o-z)
13576 integer debug
13577 parameter(njmax=50000)
13578 dimension mark(njmax),ept(4)
13579 common /qgarr10/ am(7),ammu
13580 common /qgarr36/ epjet(4,njmax),ipjet(njmax),njtot
13581 common /qgarr37/ eqj(4,njmax),iqj(njmax),ncj(2,njmax),nj
13582 common /qgarr43/ moniou
13583 common /qgdebug/ debug
13584
13585 if(debug.ge.2)write (moniou,201)nj
13586 if(debug.ge.2.and.nj.ne.0)then
13587 do i=1,nj
13588 write (moniou,203)i,iqj(i),(eqj(l,i),l=1,4)
13589 if(iqj(i).eq.0)then
13590 write (moniou,204)ncj(1,i),ncj(2,i)
13591 else
13592 ncdum=0
13593 write (moniou,204)ncj(1,i),ncdum
13594 endif
13595 enddo
13596 endif
13597
13598 njpar=0
13599 jfl=0
13600 do i=1,nj
13601 mark(i)=1
13602 enddo
13603 njtot=0
13604
13605 2 continue
13606 do ij=1,nj
13607 if(mark(ij).ne.0.and.iqj(ij).ne.0)goto 4
13608 enddo
13609 4 continue
13610
13611 jfirst=1
13612 if(iabs(iqj(ij)).le.2)then
13613 am1=am(1)
13614 elseif(iabs(iqj(ij)).eq.4)then
13615 am1=am(3)
13616 else
13617 am1=am(2)
13618 endif
13619 do i=1,4
13620 ept(i)=0.d0
13621 enddo
13622
13623 6 mark(ij)=0
13624 njtot=njtot+1
13625 ipjet(njtot)=iqj(ij)
13626 do i=1,4
13627 ept(i)=ept(i)+eqj(i,ij)
13628 epjet(i,njtot)=eqj(i,ij)
13629 enddo
13630
13631 if(iqj(ij).ne.0)then
13632 if(jfirst.ne.1)then
13633 if(iabs(iqj(ij)).le.2)then
13634 am2=am(1)
13635 elseif(iabs(iqj(ij)).eq.4)then
13636 am2=am(3)
13637 else
13638 am2=am(2)
13639 endif
13640 amj=(am1+am2)**2
13641 if(amj.gt.qgnrm(ept))then
13642 if(debug.ge.3)write (moniou,202)jfl
13643 return
13644 endif
13645
13646 if(njtot.lt.nj)then
13647 goto 2
13648 else
13649 jfl=1
13650 nj=0
13651 if(debug.ge.3)write (moniou,202)jfl
13652 return
13653 endif
13654 else
13655 jfirst=0
13656 njpar=ij
13657 ij=ncj(1,ij)
13658 goto 6
13659 endif
13660 else
13661 if(ncj(1,ij).eq.njpar)then
13662 njdau=ncj(2,ij)
13663 else
13664 njdau=ncj(1,ij)
13665 endif
13666 njpar=ij
13667 ij=njdau
13668 goto 6
13669 endif
13670
13671 201 format(2x,'qgjarr: total number of jets nj=',i4)
13672 202 format(2x,'qgjarr - end,jfl=',i2)
13673 203 format(2x,'qgjarr: ij=',i3,2x,'iqj=',i2,2x,'eqj=',4e10.3)
13674 204 format(2x,'qgjarr: ncj=',2i3)
13675 end
13676
13677
13678 double precision function qgjet(q1,q2,s,s2min,j,l)
13679
13680
13681
13682
13683
13684
13685
13686
13687
13688
13689 implicit double precision (a-h,o-z)
13690 integer debug
13691 common /qgarr6/ pi,bm,amws
13692 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
13693 common /qgarr18/ alm,qt0,qtf,betp,dgqq
13694 common /qgarr26/ factk,fqscal
13695 common /qgarr43/ moniou
13696 common /qgarr51/ epsxmn
13697 common /qgdebug/ debug
13698 common /arr3/ x1(7),a1(7)
13699
13700 if(debug.ge.2)write (moniou,201)s,q1,q2,s2min,j,l
13701
13702 qgjet=0.d0
13703 qmax=s/4.d0/fqscal*(1.d0-epsxmn)
13704 qmin=q1
13705 if(debug.ge.3)write (moniou,203)qmin,qmax
13706
13707 if(qmax.gt.qmin)then
13708
13709
13710 do i=1,7
13711 do m=1,2
13712 qi=2.d0*qmin/(1.d0+qmin/qmax+(2*m-3)*x1(i)*(1.d0-qmin/qmax))
13713 zmax=(1.d0-epsxmn)**delh
13714 zmin=(max(4.d0*fqscal*qi,s2min)/s)**delh
13715 fsj=0.d0
13716 if(debug.ge.3)write (moniou,204)qi,zmin,zmax
13717
13718 if(zmax.gt.zmin)then
13719 do i1=1,7
13720 do m1=1,2
13721 z=(.5d0*(zmax+zmin+(2*m1-3)*x1(i1)*(zmax-zmin)))**(1.d0/delh)
13722 s2=z*s
13723
13724 sj=0.d0
13725 do k=1,2
13726 sj=sj+qgjit(qi,q2,s2,k,l)*qgfap(z,j,k)*z
13727 enddo
13728 fsj=fsj+a1(i1)*sj/z**delh
13729 enddo
13730 enddo
13731 fsj=fsj*(zmax-zmin)
13732 endif
13733 qgjet=qgjet+a1(i)*fsj*qi*qgsudx(qi,j)*qgalf(qi/alm)
13734 enddo
13735 enddo
13736 qgjet=qgjet*(1.d0/qmin-1.d0/qmax)/qgsudx(q1,j)/delh/4.d0
13737 endif
13738
13739 if(debug.ge.3)write (moniou,202)qgjet
13740 201 format(2x,'qgjet - unordered ladder cross section:'
13741 */4x,'s=',e10.3,2x,'q1=',e10.3,2x,'q2=',e10.3,2x,'s2min=',
13742 *e10.3,2x,'j=',i1,2x,'l=',i1)
13743 202 format(2x,'qgjet=',e10.3)
13744 203 format(2x,'qgjet:',2x,'qmin=',e10.3,2x,'qmax=',e10.3)
13745 204 format(2x,'qgjet:',2x,'qi=',e10.3,2x,'zmin=',e10.3
13746 *,2x,'zmax=',e10.3)
13747 return
13748 end
13749
13750
13751 double precision function qgjet1(q1,q2,s,s2min,j,l)
13752
13753
13754
13755
13756
13757
13758
13759
13760
13761
13762 implicit double precision (a-h,o-z)
13763 integer debug
13764 common /qgarr6/ pi,bm,amws
13765 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
13766 common /qgarr18/ alm,qt0,qtf,betp,dgqq
13767 common /qgarr26/ factk,fqscal
13768 common /qgarr43/ moniou
13769 common /qgarr51/ epsxmn
13770 common /qgdebug/ debug
13771 common /arr3/ x1(7),a1(7)
13772
13773 if(debug.ge.2)write (moniou,201)s,q1,q2,s2min,j,l
13774
13775 qgjet1=0.d0
13776 qmax=s/4.d0/fqscal*(1.d0-epsxmn)
13777 qmin=q1
13778 if(debug.ge.3)write (moniou,203)qmin,qmax
13779
13780 if(qmax.gt.qmin)then
13781
13782
13783 do i=1,7
13784 do m=1,2
13785 qi=2.d0*qmin/(1.d0+qmin/qmax+(2*m-3)*x1(i)*(1.d0-qmin/qmax))
13786 zmax=(1.d0-epsxmn)**delh
13787 zmin=(max(4.d0*fqscal*qi,s2min)/s)**delh
13788 fsj=0.d0
13789 if(debug.ge.3)write (moniou,204)qi,zmin,zmax
13790
13791 if(zmax.gt.zmin)then
13792 do i1=1,7
13793 do m1=1,2
13794 z=(.5d0*(zmax+zmin+(2*m1-3)*x1(i1)*(zmax-zmin)))**(1.d0/delh)
13795 s2=z*s
13796
13797 sj=0.d0
13798 do k=1,2
13799 sj=sj+qgjit1(qi,q2,s2,k,l)*qgfap(z,j,k)*z
13800 enddo
13801 fsj=fsj+a1(i1)*sj/z**delh
13802 enddo
13803 enddo
13804 fsj=fsj*(zmax-zmin)
13805 endif
13806 qgjet1=qgjet1+a1(i)*fsj*qi*qgsudx(qi,j)*qgalf(qi/alm)
13807 enddo
13808 enddo
13809 qgjet1=qgjet1*(1.d0/qmin-1.d0/qmax)/qgsudx(q1,j)/delh/4.d0
13810 endif
13811
13812 if(debug.ge.3)write (moniou,202)qgjet1
13813 201 format(2x,'qgjet1 - strictly ordered ladder cross section:'
13814 */4x,'s=',e10.3,2x,'q1=',e10.3,2x,'q2=',e10.3,2x,'s2min=',
13815 *e10.3,2x,'j=',i1,2x,'l=',i1)
13816 202 format(2x,'qgjet1=',e10.3)
13817 203 format(2x,'qgjet1:',2x,'qmin=',e10.3,2x,'qmax=',e10.3)
13818 204 format(2x,'qgjet1:',2x,'qi=',e10.3,2x,'zmin=',e10.3
13819 *,2x,'zmax=',e10.3)
13820 return
13821 end
13822
13823
13824 double precision function qgjit(q1,q2,s,m,l)
13825
13826
13827
13828
13829
13830
13831
13832
13833
13834 implicit double precision (a-h,o-z)
13835 integer debug
13836 dimension wi(3),wj(3),wk(3)
13837 common /qgarr18/ alm,qt0,qtf,betp,dgqq
13838 common /qgarr20/ spmax
13839 common /qgarr26/ factk,fqscal
13840 common /qgarr29/ csj(40,40,160)
13841 common /qgarr43/ moniou
13842 common /qgdebug/ debug
13843
13844 if(debug.ge.2)write (moniou,201)s,q1,q2,m,l
13845
13846 qgjit=0.d0
13847 qq=max(q1,q2)
13848 s2min=qq*4.d0*fqscal
13849 if(s.le..99d0*s2min)then
13850 if(debug.ge.3)write (moniou,202)qgjit
13851 return
13852 endif
13853
13854 if(q1.le.q2)then
13855 qi=q1
13856 qj=q2
13857 ml=40*(m-1)+80*(l-1)
13858 else
13859 qi=q2
13860 qj=q1
13861 ml=40*(l-1)+80*(m-1)
13862 endif
13863
13864 tmin=qq*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qq*fqscal/s)))
13865 qli=dlog(qi)/dlog(spmax/4.d0/fqscal)*39.d0+1.d0
13866 if(qi.lt..99d0*spmax/4.d0/fqscal)then
13867 qlj=dlog(qj/qi)/dlog(spmax/4.d0/fqscal/qi)*39.d0+1.d0
13868 else
13869 qlj=1.d0
13870 endif
13871 sl=dlog(s/s2min)/dlog(spmax/s2min)*39.d0+1.d0
13872 i=min(38,int(qli))
13873 j=min(38,int(qlj))
13874 k=min(38,int(sl))
13875
13876 wk(2)=sl-k
13877 wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
13878 wk(1)=1.d0-wk(2)+wk(3)
13879 wk(2)=wk(2)-2.d0*wk(3)
13880 wi(2)=qli-i
13881 wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
13882 wi(1)=1.d0-wi(2)+wi(3)
13883 wi(2)=wi(2)-2.d0*wi(3)
13884 wj(2)=qlj-j
13885 wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
13886 wj(1)=1.d0-wj(2)+wj(3)
13887 wj(2)=wj(2)-2.d0*wj(3)
13888 do k1=1,3
13889 k2=k+k1-1+ml
13890 do i1=1,3
13891 do j1=1,3
13892 qgjit=qgjit+csj(i+i1-1,j+j1-1,k2)*wi(i1)*wj(j1)*wk(k1)
13893 enddo
13894 enddo
13895 enddo
13896 qgjit=exp(qgjit)*(1.d0/tmin-2.d0/s)
13897
13898 if(debug.ge.3)write (moniou,202)qgjit
13899 201 format(2x,'qgjit - unordered ladder cross section interpol.:'/4x,
13900 *'s=',e10.3,2x,'q1=',e10.3,2x,'q2=',e10.3,2x,2x,'m=',i1,2x,'l=',i1)
13901 202 format(2x,'qgjit=',e10.3)
13902 return
13903 end
13904
13905
13906 double precision function qgjit1(q1,q2,s,m,l)
13907
13908
13909
13910
13911
13912
13913
13914
13915
13916 implicit double precision (a-h,o-z)
13917 integer debug
13918 dimension wi(3),wj(3),wk(3)
13919 common /qgarr18/ alm,qt0,qtf,betp,dgqq
13920 common /qgarr20/ spmax
13921 common /qgarr26/ factk,fqscal
13922 common /qgarr30/ csj(40,40,160)
13923 common /qgarr43/ moniou
13924 common /qgdebug/ debug
13925
13926 if(debug.ge.2)write (moniou,201)s,q1,q2,m,l
13927
13928 qgjit1=0.d0
13929 qq=max(q1,q2)
13930 s2min=qq*4.d0*fqscal
13931 if(s.le.s2min)then
13932 if(debug.ge.3)write (moniou,202)qgjit1
13933 return
13934 endif
13935
13936 tmin=qq*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qq*fqscal/s)))
13937 ml=40*(m-1)+80*(l-1)
13938 qli=dlog(q1)/dlog(spmax/4.d0/fqscal)*39.d0+1.d0
13939 if(q1.lt..99d0*spmax/4.d0/fqscal)then
13940 qlj=dlog(qq/q1)/dlog(spmax/4.d0/fqscal/q1)*39.d0+1.d0
13941 else
13942 qlj=1.d0
13943 endif
13944 sl=dlog(s/s2min)/dlog(spmax/s2min)*39.d0+1.d0
13945 i=min(38,int(qli))
13946 j=min(38,int(qlj))
13947 k=min(38,int(sl))
13948 wk(2)=sl-k
13949 wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
13950 wk(1)=1.d0-wk(2)+wk(3)
13951 wk(2)=wk(2)-2.d0*wk(3)
13952 wi(2)=qli-i
13953 wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
13954 wi(1)=1.d0-wi(2)+wi(3)
13955 wi(2)=wi(2)-2.d0*wi(3)
13956 wj(2)=qlj-j
13957 wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
13958 wj(1)=1.d0-wj(2)+wj(3)
13959 wj(2)=wj(2)-2.d0*wj(3)
13960
13961 do k1=1,3
13962 k2=k+k1-1+ml
13963 do i1=1,3
13964 do j1=1,3
13965 qgjit1=qgjit1+csj(i+i1-1,j+j1-1,k2)*wi(i1)*wj(j1)*wk(k1)
13966 enddo
13967 enddo
13968 enddo
13969 qgjit1=exp(qgjit1)*(1.d0/tmin-2.d0/s)
13970 if(q2.lt.q1)qgjit1=qgjit1*qgsudx(q1,l)/qgsudx(q2,l)
13971
13972 if(debug.ge.3)write (moniou,202)qgjit1
13973 201 format(2x,'qgjit1 - ordered ladder cross section interpol.:'/4x,
13974 *'s=',e10.3,2x,'q1=',e10.3,2x,'q2=',e10.3,2x,2x,'m=',i1,2x,'l=',i1)
13975 202 format(2x,'qgjit1=',e10.3)
13976 return
13977 end
13978
13979
13980 double precision function qglam(s,a,b)
13981
13982
13983
13984
13985
13986
13987 implicit double precision (a-h,o-z)
13988 integer debug
13989 common /qgarr43/ moniou
13990 common /qgdebug/ debug
13991
13992 if(debug.ge.2)write (moniou,201)s,a,b
13993
13994 qglam=max(0.d0,.25d0/s*(s+a-b)**2-a)
13995
13996 if(debug.ge.3)write (moniou,202)qglam
13997 201 format(2x,'qglam - kinematical function s=',e10.3,2x,'a='
13998 *,e10.3,2x,'b=',e10.3)
13999 202 format(2x,'qglam=',e10.3)
14000 return
14001 end
14002
14003
14004 double precision function qgnrm(ep)
14005
14006
14007
14008 implicit double precision (a-h,o-z)
14009 integer debug
14010 dimension ep(4)
14011 common /qgarr43/ moniou
14012 common /qgdebug/ debug
14013
14014 if(debug.ge.2)write (moniou,201)ep
14015 qgnrm=(ep(1)-ep(2))*(ep(1)+ep(2))-ep(3)**2-ep(4)**2
14016
14017 if(debug.ge.3)write (moniou,202)qgnrm
14018 201 format(2x,'qgnrm - 4-vector squared for ','ep=',4(e10.3,1x))
14019 202 format(2x,'qgnrm=',e10.3)
14020 return
14021 end
14022
14023
14024 subroutine qgrec(ep,nqc,qv,zv,qm,iqv,ldau,lpar,jq)
14025
14026
14027
14028
14029
14030
14031
14032
14033
14034
14035
14036
14037
14038
14039
14040 implicit double precision (a-h,o-z)
14041 integer debug
14042 parameter(njmax=50000)
14043 dimension ep(4),ep3(4),epv(4,30,50),nqc(2),ncc(2,30,50),
14044 *qv(30,50),zv(30,50),qm(30,50),iqv(30,50),
14045 *ldau(30,49),lpar(30,50)
14046
14047
14048
14049 common /qgarr37/ eqj(4,njmax),iqj(njmax),ncj(2,njmax),nj
14050 common /qgarr43/ moniou
14051 common /qgdebug/ debug
14052
14053 if(debug.ge.2)write (moniou,201)jq,ep,iqv(1,1),nqc
14054
14055 do i=1,4
14056 epv(i,1,1)=ep(i)
14057 enddo
14058 ncc(1,1,1)=nqc(1)
14059 if(iqv(1,1).eq.0)ncc(2,1,1)=nqc(2)
14060 nlev=1
14061 nrow=1
14062
14063 2 continue
14064 if(qv(nrow,nlev).eq.0.d0)then
14065 nj=nj+1
14066 do i=1,4
14067 eqj(i,nj)=epv(i,nrow,nlev)
14068 enddo
14069 iqj(nj)=iqv(nrow,nlev)
14070 if(iabs(iqj(nj)).eq.3)iqj(nj)=iqj(nj)*4/3
14071
14072 if(iqj(nj).ne.0)then
14073 njc=ncc(1,nrow,nlev)
14074 if(njc.ne.0)then
14075 ncj(1,nj)=njc
14076 iqc=iqj(njc)
14077 if(iqc.ne.0)then
14078 ncj(1,njc)=nj
14079 else
14080 if(iqj(nj).gt.0)then
14081 ncj(2,njc)=nj
14082 else
14083 ncj(1,njc)=nj
14084 endif
14085 endif
14086 else
14087 ncc(1,nrow,nlev)=nj
14088 endif
14089 else
14090
14091 do m=1,2
14092 if(jq.eq.1)then
14093 m1=m
14094 else
14095 m1=3-m
14096 endif
14097 njc=ncc(m1,nrow,nlev)
14098 if(njc.ne.0)then
14099 ncj(m,nj)=njc
14100 iqc=iqj(njc)
14101 if(iqc.ne.0)then
14102 ncj(1,njc)=nj
14103 else
14104 ncj(3-m,njc)=nj
14105 endif
14106 else
14107 ncc(m1,nrow,nlev)=nj
14108 endif
14109 enddo
14110 endif
14111 if(debug.ge.3)write (moniou,204)
14112 * nj,nlev,nrow,iqj(nj),(eqj(i,nj),i=1,4)
14113
14114 else
14115 do i=1,4
14116 ep3(i)=epv(i,nrow,nlev)
14117 enddo
14118 call qgdefr(ep3,s0x,c0x,s0,c0)
14119 z=zv(nrow,nlev)
14120 qt2=(z*(1.d0-z))**2*qv(nrow,nlev)
14121 ldrow=ldau(nrow,nlev)
14122
14123 wp0=ep3(1)+ep3(2)
14124 wpi=z*wp0
14125 wmi=(qt2+qm(ldrow,nlev+1))/wpi
14126 ep3(1)=.5d0*(wpi+wmi)
14127 ep3(2)=.5d0*(wpi-wmi)
14128 qt=dsqrt(qt2)
14129 call qgcs(c,s)
14130 ep3(3)=qt*c
14131 ep3(4)=qt*s
14132 call qgrota(ep3,s0x,c0x,s0,c0)
14133 do i=1,4
14134 epv(i,ldrow,nlev+1)=ep3(i)
14135 enddo
14136 if(debug.ge.3)write (moniou,206)nlev+1,ldrow,ep3
14137
14138 wpi=(1.d0-z)*wp0
14139 wmi=(qt2+qm(ldrow+1,nlev+1))/wpi
14140 ep3(1)=.5d0*(wpi+wmi)
14141 ep3(2)=.5d0*(wpi-wmi)
14142 ep3(3)=-qt*c
14143 ep3(4)=-qt*s
14144 call qgrota(ep3,s0x,c0x,s0,c0)
14145 do i=1,4
14146 epv(i,ldrow+1,nlev+1)=ep3(i)
14147 enddo
14148 if(debug.ge.3)write (moniou,206)nlev+1,ldrow+1,ep3
14149
14150 if(iqv(nrow,nlev).eq.0)then
14151 if(iqv(ldrow,nlev+1).ne.0)then
14152 ncc(1,ldrow,nlev+1)=ncc(1,nrow,nlev)
14153 ncc(1,ldrow+1,nlev+1)=ncc(2,nrow,nlev)
14154 else
14155 ncc(1,ldrow,nlev+1)=ncc(1,nrow,nlev)
14156 ncc(2,ldrow,nlev+1)=0
14157 ncc(1,ldrow+1,nlev+1)=0
14158 ncc(2,ldrow+1,nlev+1)=ncc(2,nrow,nlev)
14159 endif
14160 else
14161 if(iqv(ldrow,nlev+1).eq.0)then
14162 ncc(1,ldrow,nlev+1)=ncc(1,nrow,nlev)
14163 ncc(2,ldrow,nlev+1)=0
14164 ncc(1,ldrow+1,nlev+1)=0
14165 else
14166 ncc(1,ldrow,nlev+1)=0
14167 ncc(1,ldrow+1,nlev+1)=0
14168 ncc(2,ldrow+1,nlev+1)=ncc(1,nrow,nlev)
14169 endif
14170 endif
14171
14172 nrow=ldrow
14173 nlev=nlev+1
14174 goto 2
14175 endif
14176
14177 8 continue
14178 if(nlev.eq.1)then
14179 if(nqc(1).eq.0)nqc(1)=ncc(1,1,1)
14180 if(iqv(1,1).eq.0.and.nqc(2).eq.0)nqc(2)=ncc(2,1,1)
14181 if(debug.ge.3)write (moniou,202)
14182 return
14183 endif
14184
14185 lprow=lpar(nrow,nlev)
14186 if(ldau(lprow,nlev-1).eq.nrow)then
14187 if(iqv(nrow,nlev).eq.0)then
14188 if(ncc(1,lprow,nlev-1).eq.0)ncc(1,lprow,nlev-1)=ncc(1,nrow,nlev)
14189 ncc(1,nrow+1,nlev)=ncc(2,nrow,nlev)
14190 else
14191 if(iqv(lprow,nlev-1).eq.0)then
14192 if(ncc(1,lprow,nlev-1).eq.0)
14193 * ncc(1,lprow,nlev-1)=ncc(1,nrow,nlev)
14194 else
14195 ncc(1,nrow+1,nlev)=ncc(1,nrow,nlev)
14196 endif
14197 endif
14198 nrow=nrow+1
14199 goto 2
14200 else
14201 if(iqv(nrow,nlev).eq.0)then
14202 if(iqv(lprow,nlev-1).eq.0)then
14203 if(ncc(2,lprow,nlev-1).eq.0)
14204 * ncc(2,lprow,nlev-1)=ncc(2,nrow,nlev)
14205 else
14206 if(ncc(1,lprow,nlev-1).eq.0)
14207 * ncc(1,lprow,nlev-1)=ncc(2,nrow,nlev)
14208 endif
14209 else
14210 if(iqv(lprow,nlev-1).eq.0.and.ncc(2,lprow,nlev-1).eq.0)
14211 * ncc(2,lprow,nlev-1)=ncc(1,nrow,nlev)
14212 endif
14213 nrow=lprow
14214 nlev=nlev-1
14215 goto 8
14216 endif
14217
14218 201 format(2x,'qgrec - jet reconstructuring: jq=',i1
14219 */4x,'jet 4-momentum ep=',4(e10.3,1x)
14220 */4x,'jet flavor: ',i2,2x,'colour connections: ',2i3)
14221 202 format(2x,'qgrec - end')
14222 204 format(2x,'qgrec: ',i3,'-th final jet at level nlev=',i2,' nrow='
14223 *,i2/4x,'jet flavor: ',i3,2x,'jet 4-momentum:',4(e10.3,1x))
14224 206 format(2x,'qgrec: jet at level nlev='
14225 *,i2,' nrow=',i2/4x,'jet 4-momentum:',4(e10.3,1x))
14226 end
14227
14228
14229 double precision function qgroot(qlmax,g,j)
14230
14231
14232
14233
14234
14235
14236
14237
14238 implicit double precision (a-h,o-z)
14239 integer debug
14240 common /qgarr43/ moniou
14241 common /qgdebug/ debug
14242
14243 if(debug.ge.2)write (moniou,201)qlmax,g,j
14244
14245 ql0=0.d0
14246 ql1=qlmax
14247 f0=-g
14248 f1=1.d0-g
14249 sud0=-dlog(qgsudi(qlmax,j))
14250
14251 1 ql2=ql1-(ql1-ql0)*f1/(f1-f0)
14252 if(ql2.lt.0.d0)then
14253 ql2=0.d0
14254 f2=-g
14255 elseif(ql2.gt.qlmax)then
14256 ql2=qlmax
14257 f2=1.d0-g
14258 else
14259 f2=-dlog(qgsudi(ql2,j))/sud0-g
14260 endif
14261 if(abs(f2).gt.1.d-3)then
14262 if(f1*f2.lt.0.d0)then
14263 ql0=ql1
14264 f0=f1
14265 endif
14266 ql1=ql2
14267 f1=f2
14268 goto 1
14269 else
14270 qgroot=ql2
14271 endif
14272
14273 if(debug.ge.3)write (moniou,202)qgroot
14274 201 format(2x,'qgqint - branching momentum tabulation:'
14275 */4x,'qlmax=',e10.3,2x,'g=',e10.3,2x,'j=',i1)
14276 202 format(2x,'qgroot=',e10.3)
14277 return
14278 end
14279
14280
14281 subroutine qgrota(ep,s0x,c0x,s0,c0)
14282
14283
14284
14285 implicit double precision (a-h,o-z)
14286 integer debug
14287 dimension ep(4),ep1(3)
14288 common /qgarr43/ moniou
14289 common /qgdebug/ debug
14290
14291 if(debug.ge.2)write (moniou,201)ep,s0x,c0x,s0,c0
14292
14293 ep1(3)=ep(4)
14294 ep1(2)=ep(2)*s0+ep(3)*c0
14295 ep1(1)=ep(2)*c0-ep(3)*s0
14296 ep(2)=ep1(1)
14297 ep(4)=ep1(2)*s0x+ep1(3)*c0x
14298 ep(3)=ep1(2)*c0x-ep1(3)*s0x
14299
14300 if(debug.ge.3)write (moniou,202)ep
14301 201 format(2x,'qgrota - spacial rotation:'/4x,'4-vector ep=',4(e10.3
14302 *,1x)/4x,'s0x=',e10.3,'c0x=',e10.3,2x,'s0=',e10.3,'c0=',e10.3)
14303 202 format(2x,'qgrota: rotated 4-vector ep=',2x,4e10.3)
14304 return
14305 end
14306
14307
14308 double precision function qgqint(qlmax,g,j)
14309
14310
14311
14312
14313
14314
14315
14316 implicit double precision (a-h,o-z)
14317 integer debug
14318 dimension wi(3),wk(3)
14319 common /qgarr18/ alm,qt0,qtf,betp,dgqq
14320 common /qgarr34/ qrt(10,101,2)
14321 common /qgarr43/ moniou
14322 common /qgdebug/ debug
14323
14324 if(debug.ge.2)write (moniou,201)qlmax,g,j
14325
14326 qli=qlmax/1.38629d0
14327 sud0=1.d0/qgsudi(qlmax,j)
14328 sl=100.d0*dlog(1.d0-g*(1.d0-sud0))/dlog(sud0)
14329 i=int(qli)
14330 k=int(sl)
14331 if(k.gt.98)k=98
14332 wk(2)=sl-k
14333 wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
14334 wk(1)=1.d0-wk(2)+wk(3)
14335 wk(2)=wk(2)-2.d0*wk(3)
14336 qgqint=0.d0
14337 if(i.gt.7)i=7
14338 wi(2)=qli-i
14339 wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
14340 wi(1)=1.d0-wi(2)+wi(3)
14341 wi(2)=wi(2)-2.d0*wi(3)
14342 do k1=1,3
14343 do i1=1,3
14344 qgqint=qgqint+qrt(i+i1,k+k1,j)*wi(i1)*wk(k1)
14345 enddo
14346 enddo
14347 if(qgqint.le.0.d0)qgqint=0.d0
14348 qgqint=16.d0*qtf*exp(qgqint)
14349
14350 if(debug.ge.3)write (moniou,202)qgqint
14351 201 format(2x,'qgqint - branching momentum interpolation:'
14352 */4x,'qlmax=',e10.3,2x,'g=',e10.3,2x,'j=',i1)
14353 202 format(2x,'qgqint=',e10.3)
14354 return
14355 end
14356
14357
14358 double precision function qgalf(qq)
14359
14360
14361
14362 implicit double precision (a-h,o-z)
14363 integer debug
14364 common /qgarr43/ moniou
14365 common /qgdebug/ debug
14366
14367 qgalf=2.d0/9.d0/dlog(qq)
14368 return
14369 end
14370
14371
14372 subroutine qgtran(ep,ey,jj)
14373
14374
14375
14376
14377 implicit double precision (a-h,o-z)
14378 integer debug
14379 dimension ey(3),ep(4)
14380 common /qgarr43/ moniou
14381 common /qgdebug/ debug
14382
14383 if(debug.ge.2)write (moniou,201)ep,ey
14384
14385 if(jj.eq.1)then
14386
14387 do i=1,3
14388 if(ey(4-i).ne.1.d0)then
14389 wp=(ep(1)+ep(5-i))/ey(4-i)
14390 wm=(ep(1)-ep(5-i))*ey(4-i)
14391 ep(1)=.5d0*(wp+wm)
14392 ep(5-i)=.5d0*(wp-wm)
14393 endif
14394 enddo
14395 else
14396
14397 do i=1,3
14398 if(ey(i).ne.1.d0)then
14399 wp=(ep(1)+ep(i+1))*ey(i)
14400 wm=(ep(1)-ep(i+1))/ey(i)
14401 ep(1)=.5d0*(wp+wm)
14402 ep(i+1)=.5d0*(wp-wm)
14403 endif
14404 enddo
14405 endif
14406
14407 if(debug.ge.3)write (moniou,202)ep
14408 201 format(2x,'qgtran - lorentz boost for 4-vector'/4x,'ep='
14409 *,2x,4(e10.3,1x)/4x,'boost parameters ey=',3e10.3)
14410 202 format(2x,'qgtran: transformed 4-vector ep=',2x,4(e10.3,1x))
14411 return
14412 end
14413
14414
14415 double precision function qgsudi(qlmax,j)
14416
14417
14418
14419
14420
14421 implicit double precision (a-h,o-z)
14422 integer debug
14423 dimension wk(3)
14424 common /qgarr33/ fsud(10,2)
14425 common /qgarr43/ moniou
14426 common /qgdebug/ debug
14427
14428 if(debug.ge.2)write (moniou,201)j,qlmax
14429
14430 ql=qlmax/1.38629d0
14431 if(ql.le.0.d0)then
14432 qgsudi=1.d0
14433 else
14434 k=int(ql)
14435 if(k.gt.7)k=7
14436 wk(2)=ql-k
14437 wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
14438 wk(1)=1.d0-wk(2)+wk(3)
14439 wk(2)=wk(2)-2.d0*wk(3)
14440
14441 qgsudi=0.d0
14442 do k1=1,3
14443 qgsudi=qgsudi+fsud(k+k1,j)*wk(k1)
14444 enddo
14445 if(qgsudi.le.0.d0)qgsudi=0.d0
14446 qgsudi=exp(-qgsudi)
14447 endif
14448
14449 if(debug.ge.3)write (moniou,202)qgsudi
14450 201 format(2x,'qgsudi - spacelike form factor interpolation:'
14451 */4x,'parton type j=',i1,2x,'momentum logarithm qlmax=',e10.3)
14452 202 format(2x,'qgsudi=',e10.3)
14453 return
14454 end
14455
14456
14457 double precision function qgsudx(q,j)
14458
14459
14460
14461
14462
14463 implicit double precision (a-h,o-z)
14464 integer debug
14465 common /qgarr18/ alm,qt0,qtf,betp,dgqq
14466 common /qgarr43/ moniou
14467 common /qgarr51/ epsxmn
14468 common /qgdebug/ debug
14469
14470 if(debug.ge.2)write (moniou,201)j,q
14471
14472 if(q.gt.1.d0)then
14473 qgsudx=dlog(dlog(q/alm)/dlog(1.d0/alm))*(.75d0+dlog(epsxmn))
14474 if(j.eq.1)then
14475 qgsudx=exp(qgsudx/.75d0)
14476 else
14477 qgsudx=exp(qgsudx*16.d0/27.d0)
14478 endif
14479 else
14480 qgsudx=1.d0
14481 endif
14482
14483 if(debug.ge.3)write (moniou,202)qgsudx
14484 201 format(2x,'qgsudx - spacelike form factor: parton type j='
14485 *,i1,2x,'momentum q=',e10.3)
14486 202 format(2x,'qgsudx=',e10.3)
14487 return
14488 end
14489
14490
14491 double precision function qgsudt(qmax,j)
14492
14493
14494
14495
14496
14497 implicit double precision (a-h,o-z)
14498 integer debug
14499 common /qgarr18/ alm,qt0,qtf,betp,dgqq
14500 common/arr3/x1(7),a1(7)
14501 common /qgarr43/ moniou
14502 common /qgdebug/ debug
14503
14504 if(debug.ge.2)write (moniou,201)j,qmax
14505
14506 qgsudt=0.d0
14507 qlmax=dlog(dlog(qmax/16.d0/alm))
14508 qfl=dlog(dlog(qtf/alm))
14509
14510
14511 do i=1,7
14512 do m=1,2
14513 qtl=.5d0*(qlmax+qfl+(2*m-3)*x1(i)*(qlmax-qfl))
14514 qt=alm*exp(exp(qtl))
14515 if(qt.ge.qmax/16.d0)qt=qmax/16.0001d0
14516 zmin=.5d0-dsqrt((.25d0-dsqrt(qt/qmax)))
14517 zmax=1.d0-zmin
14518
14519 if(j.eq.1)then
14520 ap=(qgapi(zmax,1,1)-qgapi(zmin,1,1)+
14521 * qgapi(zmax,1,2)-qgapi(zmin,1,2))*.5d0
14522 else
14523 ap=qgapi(zmax,2,1)-qgapi(zmin,2,1)
14524 endif
14525 qgsudt=qgsudt+a1(i)*ap
14526 enddo
14527 enddo
14528 qgsudt=qgsudt*(qlmax-qfl)/9.d0
14529
14530 if(debug.ge.3)write (moniou,202)qgsudt
14531 201 format(2x,'qgsudt - timelike form factor: parton type j='
14532 *,i1,2x,'momentum qmax=',e10.3)
14533 202 format(2x,'qgsudt=',e10.3)
14534 return
14535 end
14536
14537
14538 double precision function qgtwd(s,a,b)
14539
14540
14541
14542
14543
14544
14545 implicit double precision (a-h,o-z)
14546 integer debug
14547 common /qgarr43/ moniou
14548 common /qgdebug/ debug
14549
14550 if(debug.ge.2)write (moniou,201)s,a,b
14551
14552 x=.5d0*(1.d0+(a-b)/s)
14553 dx=x-dsqrt(a/s)
14554 if(dx.gt.0.d0)then
14555 x=x+dsqrt(dx)*dsqrt(x+dsqrt(a/s))
14556 else
14557 x=dsqrt(a/s)
14558 endif
14559 qgtwd=x
14560
14561 if(debug.ge.3)write (moniou,202)qgtwd
14562 201 format(2x,'qgtwd: s=',e10.3,2x,'a=',e10.3,2x,'b=',e10.3)
14563 202 format(2x,'qgtwd=',e10.3)
14564 return
14565 end
14566
14567
14568 subroutine qgvdef(ich,ic1,ic2,icz)
14569
14570
14571
14572
14573 implicit double precision (a-h,o-z)
14574 integer debug
14575 common /qgarr11/ b10
14576 common /qgarr43/ moniou
14577 common /qgdebug/ debug
14578 EXTERNAL qgran
14579
14580 if(debug.ge.2)write (moniou,201)ich,icz
14581
14582 is=iabs(ich)/ich
14583 if(icz.eq.1)then
14584 ic1=ich*(1-3*int(.5d0+qgran(b10)))
14585 ic2=-ic1-ich
14586 elseif(icz.eq.2)then
14587 if(qgran(b10).gt..33333d0.or.ich.lt.0)then
14588 ic1=ich-is
14589 ic2=3*is
14590 else
14591 ic1=4*is-ich
14592 ic2=ich+4*is
14593 endif
14594 elseif(icz.eq.3)then
14595 ic1=ich-3*is
14596 ic2=-4*is
14597 elseif(icz.eq.4)then
14598 ic1=ich-9*is
14599 ic2=5*is
14600 endif
14601
14602 if(debug.ge.3)write (moniou,202)ic1,ic2
14603 201 format(2x,'qgvdef: hadron type ich=',i2,' auxilliary type icz='
14604 *,i1)
14605 202 format(2x,'qgvdef-end: parton flavors ic1=',i2,
14606 *'ic2=',i2)
14607 return
14608 end
14609
14610
14611 double precision function qgzsim(qq,j)
14612
14613
14614
14615
14616
14617
14618 implicit double precision (a-h,o-z)
14619 integer debug
14620 common /qgarr11/ b10
14621 common /qgarr18/ alm,qt0,qtf,betp,dgqq
14622 common /qgarr43/ moniou
14623 common /qgdebug/ debug
14624 EXTERNAL qgran
14625
14626 if(debug.ge.2)write (moniou,201)qq,j
14627
14628 zmin=.5d0-dsqrt(.25d0-dsqrt(qtf/qq))
14629 qlf=dlog(qtf/alm)
14630 1 continue
14631 if(j.eq.1)then
14632 qgzsim=.5d0*(2.d0*zmin)**qgran(b10)
14633 gb=qgzsim*(qgfap(qgzsim,1,1)+qgfap(qgzsim,1,2))/7.5d0
14634 else
14635 qgzsim=zmin*((1.d0-zmin)/zmin)**qgran(b10)
14636 gb=qgzsim*qgfap(qgzsim,2,1)*.375d0
14637 endif
14638 qt=qq*(qgzsim*(1.d0-qgzsim))**2
14639 gb=gb/dlog(qt/alm)*qlf
14640 if(debug.ge.3)write (moniou,203)qt,gb
14641 if(qgran(b10).gt.gb)goto 1
14642
14643 if(debug.ge.3)write (moniou,202)qgzsim
14644 201 format(2x,'qgzsim - z-share simulation: qq=',e10.3,2x,'j=',i1)
14645 202 format(2x,'qgzsim=',e10.3)
14646 203 format(2x,'qgzsim: qt=',e10.3,2x,'gb=',e10.3)
14647 return
14648 end
14649
14650
14651 subroutine qgixxd(ich,ic1,ic2,icz)
14652
14653
14654
14655
14656 implicit double precision (a-h,o-z)
14657 integer debug
14658 common /qgarr8/ wwm,be(4),dc(5),deta,almpt,ptdif,ptndi
14659 common /qgarr11/ b10
14660 common /qgarr43/ moniou
14661 common /qgdebug/ debug
14662 EXTERNAL qgran
14663
14664 if(debug.ge.2)write (moniou,201)ich,icz
14665
14666 is=iabs(ich)/ich
14667 if(icz.eq.1)then !pion
14668 ic1=ich*(1-3*int(.5d0+qgran(b10)))
14669 if(qgran(b10).lt.dc(2))then
14670 ic2=-4*ic1/iabs(ic1)
14671 if(iabs(ic1).eq.1)then
14672 ich1=-5*is
14673 else
14674 ich1=4*is
14675 endif
14676 else
14677 ich1=ich*int(.5d0+qgran(b10))
14678 ic2=-ic1*iabs(ich1)-(ich+ic1)*iabs(ich-ich1)
14679 endif
14680 elseif(icz.eq.2)then
14681
14682 ic1=int(1.3333d0+qgran(b10))
14683
14684 if(ic1.eq.1)then
14685 ich1=int(qgran(b10)+.5d0)+2
14686 ic2=1-ich1
14687 elseif(qgran(b10).lt..5d0)then
14688 ich1=2
14689 ic2=-2
14690 else
14691 ich1=7 !uuu
14692 ic2=-1
14693 endif
14694 if(iabs(ich).eq.3)then !neutron
14695 ic1=3-ic1
14696 ic2=-3-ic2
14697 if(ich1.eq.7)then
14698 ich1=8 !ddd
14699 else
14700 ich1=5-ich1
14701 endif
14702 endif
14703 if(ich.lt.0)then
14704 ic1=-ic1
14705 ic2=-ic2
14706 ich1=-ich1
14707 endif
14708 elseif(icz.eq.3)then
14709 ic1=ich-3*is
14710 ic2=-is*int(1.5d0+qgran(b10))
14711 ich1=3*is-ic2
14712 elseif(icz.eq.4)then
14713 ic1=ich-9*is
14714 ic2=is*int(1.5d0+qgran(b10))
14715 ich1=9*is-ic2
14716 elseif(icz.eq.5)then
14717 ic1=is*int(1.5d0+qgran(b10))
14718 ic2=-ic1
14719 ich1=ich
14720 else
14721 ich1=0
14722 stop 'Should not happen in qgixxd !'
14723 endif
14724 ich=ich1
14725
14726 if(debug.ge.3)write (moniou,202)ic1,ic2,ich
14727 201 format(2x,'qgixxd: hadron type ich=',i2,' auxilliary type icz='
14728 *,i1)
14729 202 format(2x,'qgixxd-end: parton flavors ic1=',i2,' ic2='
14730 *,i2,'new hadron type ich=',i2)
14731 return
14732 end
14733
14734
14735 subroutine qgdifr(wppr,wmtg,izp,izt,jexpr,jextg,iret)
14736
14737
14738
14739
14740
14741
14742
14743
14744
14745
14746
14747 implicit double precision (a-h,o-z)
14748 integer debug
14749 dimension ey(3),ep(4)
14750 common /qgarr1/ ia(2),icz,icp
14751 common /qgarr2/ scm,wp0,wm0
14752 common /qgarr6/ pi,bm,amws
14753 common /qgarr8/ wwm,be(4),dc(5),deta,almpt,ptdif,ptndi
14754 common /qgarr10/ am(7),ammu
14755 common /qgarr11/ b10
14756 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
14757 common /qgarr21/ dmmin(3),wex(3),dmres(3),wdres(3)
14758 common /qgarr43/ moniou
14759 common /qgdebug/ debug
14760 EXTERNAL qgran
14761
14762 if(debug.ge.2)write (moniou,201)izp,izt,wppr,wmtg
14763
14764 iret=0
14765 jexip=0
14766 jexit=0
14767 ddmin1=0.d0
14768 ddmax1=0.d0
14769
14770 if(jexpr.eq.-2.or.jexpr.gt.0.and.qgran(b10)
14771 *.lt.1.d0-(1.d0-wex(icz))**dble(jexpr).and.iabs(izp).lt.7)jexip=1
14772 if(jextg.eq.-2.or.jextg.gt.0.and.qgran(b10)
14773 *.lt.1.d0-(1.d0-wex(2))**dble(jextg).and.iabs(izt).lt.7)jexit=1
14774
14775 if(wppr.ge.wp0.and.jexpr.gt.0.and.jexip.eq.0.and.iabs(izp).lt.7)
14776 *jexip=1
14777 if(wmtg.ge.wm0.and.jextg.gt.0.and.jexit.eq.0.and.iabs(izt).lt.7)
14778 *jexit=1
14779
14780 sd0=wppr*wmtg !energy squared available
14781 if(jextg.eq.-1)then !more collisions to follow
14782 dmass2=0.d0
14783 ddmin2=0.d0
14784 elseif(jexit.eq.0)then !no excitation
14785 if(iabs(izt).eq.7.or.iabs(izt).eq.8)then !delta++/-
14786 dmass2=dmmin(2)
14787 else
14788 dmass2=am(2)
14789 endif
14790 ddmin2=dmass2
14791 else !low mass excitation
14792 ddmin2=dmmin(2)
14793 if(jextg.eq.-2)ddmin2=dmres(2) !low mass diffraction
14794 endif
14795 if(jexpr.eq.-1)then !more collisions to follow
14796 dmass1=0.d0
14797 elseif(jexip.eq.0)then !no excitation
14798 if(iabs(izp).eq.7.or.iabs(izp).eq.8)then !delta++/-
14799 dmass1=dmmin(2)
14800 elseif(izp.eq.0)then !rho0
14801 dmass1=dmmin(1)
14802 izp=-10
14803 else
14804 dmass1=am(icz)
14805 endif
14806 else !low mass excitation
14807 ddmin1=dmmin(icz)
14808 if(jexpr.eq.-2)ddmin1=dmres(icz) !low mass diffraction
14809 ddmax1=dsqrt(sd0)-ddmin2
14810 endif
14811
14812
14813
14814 if(jexip.eq.1)then
14815 if(jexpr.ne.-2)then !low mass excitation (dM/M^2)
14816 if(ddmax1.gt.ddmin1)then
14817 dmass1=ddmin1/(1.d0-qgran(b10)*(1.d0-ddmin1/ddmax1))
14818 else
14819 dmass1=ddmin1
14820 endif
14821 else !low mass diffraction (res. + PPR)
14822 ddmin=dmmin(icz)+am(1)
14823 ddmax=min(ddmax1,dmres(icz)+.5d0*wdres(icz))
14824 ddmax=max(ddmax,ddmin)
14825 wres=1.d0/(1.d0+.5d0*(1.d0+2.d0*dmres(icz)/wdres(icz))
14826 * *(1.d0-(dmres(icz)+.5d0*wdres(icz))
14827 * /max(ddmax1,dmres(icz)+.5d0*wdres(icz)))
14828 * /(.25d0*pi+atan(2.d0*(dmres(icz)-ddmin)/wdres(icz))))
14829 if(qgran(b10).gt.wres)then !PPR contribution
14830 dmass1=ddmax/(1.d0-qgran(b10)*(1.d0-ddmax/ddmax1))
14831 else !resonance contribution
14832 dmass1=dmres(icz)+.5d0*wdres(icz)
14833 * *tan(atan(2.d0*(ddmax-dmres(icz))/wdres(icz))
14834 * -qgran(b10)*(atan(2.d0*(ddmax-dmres(icz))/wdres(icz))
14835 * +atan(2.d0*(dmres(icz)-ddmin)/wdres(icz))))
14836 jexip=0
14837 izp=izp+10*izp/iabs(izp)
14838 endif
14839 endif
14840 endif
14841
14842
14843 if(jexit.eq.1)then
14844 ddmax2=dsqrt(sd0)-dmass1
14845 if(jextg.ne.-2)then !low mass excitation (dM/M^2)
14846 if(ddmax2.gt.ddmin2)then
14847 dmass2=ddmin2/(1.d0-qgran(b10)*(1.d0-ddmin2/ddmax2))
14848 else !low mass diffraction
14849 dmass2=ddmin2
14850 endif
14851 else !low mass diffraction (res. + PPR)
14852 ddmin=dmmin(2)+am(1)
14853 ddmax=min(ddmax2,dmres(2)+.5d0*wdres(2))
14854 ddmax=max(ddmax,ddmin)
14855 wres=1.d0/(1.d0+.5d0*(1.d0+2.d0*dmres(2)/wdres(2))
14856 * *(1.d0-(dmres(2)+.5d0*wdres(2))/max(ddmax2,dmres(2)+.5d0
14857 * *wdres(2)))/(.25d0*pi+atan(2.d0*(dmres(2)-ddmin)/wdres(2))))
14858 if(qgran(b10).gt.wres)then !PPR contribution
14859 dmass2=ddmax/(1.d0-qgran(b10)*(1.d0-ddmax/ddmax2))
14860 else !resonance contribution
14861 dmass2=dmres(2)+.5d0*wdres(2)*tan(atan(2.d0*(ddmax-dmres(2))
14862 * /wdres(2))-qgran(b10)*(atan(2.d0*(ddmax-dmres(2))/wdres(2))
14863 * +atan(2.d0*(dmres(2)-ddmin)/wdres(2))))
14864 izt=izt+10*izt/iabs(izt)
14865 jexit=0
14866 endif
14867 endif
14868 endif
14869
14870 wpp=wppr
14871 wpm=wmtg
14872 if(sd0.lt.(dmass1+dmass2)**2)then
14873 iret=1
14874 return
14875 endif
14876 dmass1=dmass1**2
14877 dmass2=dmass2**2
14878
14879 if(jexpr.ne.-1.and.jextg.ne.-1)then
14880 ptmax=max(0.d0,qglam(sd0,dmass1,dmass2))
14881 if(jexpr.eq.-2.or.jextg.eq.-2)then
14882 ptmean=ptdif
14883 else
14884 ptmean=ptndi*dsqrt(dble(max(jexpr,jextg)))
14885 endif
14886 if(ptmax.lt.ptmean**2)then
14887 1 pti=ptmax*qgran(b10)
14888 if(qgran(b10).gt.exp(-dsqrt(pti)/ptmean))goto 1
14889 else
14890 2 pti=(ptmean*dlog(qgran(b10)*qgran(b10)))**2
14891 if(pti.gt.ptmax)goto 2
14892 endif
14893 else
14894 pti=0.d0
14895 endif
14896 amt1=dmass1+pti
14897 amt2=dmass2+pti
14898 wpd1=wpp*qgtwd(sd0,amt1,amt2)
14899 if(wpd1.gt.0.d0)then
14900 wmd1=amt1/wpd1
14901 else
14902 wmd1=0.d0
14903 endif
14904 wmd2=wpm-wmd1
14905 if(wmd2.gt.0.d0)then
14906 wpd2=amt2/wmd2
14907 else
14908 wpd2=0.d0
14909 endif
14910 pt=dsqrt(pti)
14911 call qgcs(c,s)
14912
14913 if(jexpr.eq.-1)then
14914 wppr=wpd1
14915 if(wmd1.ne.0.d0)stop'wmd1.ne.0!!!'
14916 else
14917 ep(1)=.5d0*(wpd1+wmd1)
14918 ep(2)=.5d0*(wpd1-wmd1)
14919 ep(3)=pt*c
14920 ep(4)=pt*s
14921 wppr=0.d0
14922 if(jexip.eq.0)then
14923 call qgreg(ep,izp)
14924 else
14925 is=0
14926 if(izp.ne.0)is=iabs(izp)/izp
14927 if(icz.eq.1)then
14928 if(iabs(izp).ge.4)then
14929 ic2=-4*is
14930 ic1=izp-3*is
14931 elseif(izp.ne.0)then
14932 ic1=izp*(1-3*int(.5d0+qgran(b10)))
14933 ic2=-izp-ic1
14934 else
14935 ic1=int(1.5d0+qgran(b10))*(2*int(.5d0+qgran(b10))-1)
14936 ic2=-ic1
14937 endif
14938 elseif(icz.eq.2)then
14939 if(qgran(b10).gt..33333d0)then
14940 ic1=3*is
14941 ic2=izp-is
14942 else
14943 ic1=izp+4*is
14944 ic2=4*is-izp
14945 endif
14946 elseif(icz.eq.3)then
14947 ic1=-4*is
14948 ic2=izp-3*is
14949 endif
14950 call qgdeft(dmass1,ep,ey)
14951 call qggene(dsqrt(dmass1),dsqrt(dmass1),ey
14952 * ,0.d0,1.d0,0.d0,1.d0,ic1,ic2)
14953 endif
14954 endif
14955
14956 if(jextg.eq.-1)then
14957 wmtg=wmd2
14958 if(wpd2.ne.0.d0)stop'wpd2.ne.0!!!'
14959 else
14960 ep(1)=.5d0*(wpd2+wmd2)
14961 ep(2)=.5d0*(wpd2-wmd2)
14962 ep(3)=-pt*c
14963 ep(4)=-pt*s
14964 wmtg=0.d0
14965 if(jexit.eq.0)then
14966 call qgreg(ep,izt)
14967 else
14968 is=iabs(izt)/izt
14969 if(qgran(b10).gt..33333d0)then
14970 ic1=3*is
14971 ic2=izt-is
14972 else
14973 ic1=izt+4*is
14974 ic2=4*is-izt
14975 endif
14976 call qgdeft(dmass2,ep,ey)
14977 call qggene(dsqrt(dmass2),dsqrt(dmass2),ey
14978 * ,0.d0,1.d0,0.d0,1.d0,ic2,ic1)
14979 endif
14980 endif
14981
14982 if(debug.ge.3)write (moniou,202)
14983 201 format(2x,'qgdifr - leading clusters hadronization:'
14984 */4x,'cluster types izp=',i2,2x,
14985 *'izt=',i2/4x,'available light cone momenta: wppr=',e10.3,
14986 *' wmtg=',e10.3)
14987 202 format(2x,'qgdifr - end')
14988 return
14989 end
14990
14991
14992 subroutine qgfau(b,gz)
14993
14994
14995
14996 implicit double precision (a-h,o-z)
14997 integer debug
14998 parameter(iapmax=208)
14999 dimension gz(3),gz0(5)
15000 common /qgarr1/ ia(2),icz,icp
15001 common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
15002 common /qgarr5/ rnuc(2),wsnuc(2),wbnuc(2),anorm
15003 *,cr1(2),cr2(2),cr3(2)
15004 common /qgarr43/ moniou
15005 common /qgdebug/ debug
15006
15007 if(debug.ge.2)write (moniou,201)b
15008
15009 do l=1,3
15010 gz(l)=0.d0
15011 enddo
15012
15013 ab=float(ia(2))
15014 do iddp1=1,2
15015 do iddp2=1,2
15016 call qgfz(b,gz0,iddp1,iddp2)
15017 if(iddp1.eq.iddp2)gz(1)=gz(1)+(1.d0-gz0(1)*anorm)**ab
15018 * *cc(iddp1,icz)
15019 do l=2,3
15020 gz(l)=gz(l)+(1.d0-gz0(l-1)*anorm)**ab
15021 * *cc(iddp1,icz)*cc(iddp2,icz)
15022 enddo
15023 enddo
15024 enddo
15025
15026 gz(3)=gz(2)-gz(3)
15027 gz(2)=gz(1)-gz(2)
15028 gz(1)=1.d0-gz(1)
15029
15030 if(debug.ge.2)write (moniou,203)gz
15031 if(debug.ge.3)write (moniou,202)
15032 201 format(2x,'qgfau - integrands for hadron-hadron and hadron'
15033 *,'-nucleus cross-sections calculation'/4x,'b=',e10.3)
15034 202 format(2x,'qgfau - end')
15035 203 format(2x,'qgfau: gz=',3e10.3)
15036 return
15037 end
15038
15039
15040 subroutine qgfrag(sa,na,rc)
15041
15042
15043
15044
15045 implicit double precision (a-h,o-z)
15046 integer debug
15047 parameter(iapmax=208)
15048 dimension sa(iapmax,3)
15049 common /qgarr13/ nsf,iaf(iapmax)
15050 common /qgarr43/ moniou
15051 common /qgdebug/ debug
15052
15053 if(debug.ge.2)write (moniou,201)na
15054 if(debug.ge.3)then
15055 write (moniou,203)
15056 do i=1,na
15057 write (moniou,204)(sa(i,l),l=1,3)
15058 enddo
15059 endif
15060
15061 ni=1
15062 ng=1
15063 j=0
15064 1 j=j+1
15065 j1=ni+1
15066
15067 do 4 i=j1,na
15068 ri=0.d0
15069 do m=1,3
15070 ri=ri+(sa(j,m)-sa(i,m))**2
15071 enddo
15072 if(ri.gt.rc)goto 4
15073
15074 ni=ni+1
15075 ng=ng+1
15076 if(i.eq.ni)goto 4
15077 do m=1,3
15078 s0=sa(ni,m)
15079 sa(ni,m)=sa(i,m)
15080 sa(i,m)=s0
15081 enddo
15082 4 continue
15083
15084 if(j.lt.ni.and.na-ni.gt.0)goto 1
15085 nsf=nsf+1
15086 iaf(nsf)=ng
15087 if(debug.ge.3)write (moniou,206)nsf,iaf(nsf)
15088
15089 ng=1
15090 j=ni
15091 ni=ni+1
15092 if(na.eq.ni)then
15093 nsf=nsf+1
15094 iaf(nsf)=1
15095 if(debug.ge.3)write (moniou,206)nsf,iaf(nsf)
15096 elseif(na.gt.ni)then
15097 goto 1
15098 endif
15099
15100 if(debug.ge.3)write (moniou,202)
15101 201 format(2x,'qgfrag-multifragmentation: nucleus mass number: na='
15102 *,i2)
15103 202 format(2x,'qgfrag - end')
15104 203 format(2x,'nucleons coordinates:')
15105 204 format(2x,3e10.3)
15106 206 format(2x,'qgfrag: fragment n',i2,2x,'fragment mass - ',i2)
15107 return
15108 end
15109
15110
15111 subroutine qgfrgm(ns,xa)
15112
15113
15114
15115
15116
15117 implicit double precision (a-h,o-z)
15118 parameter(iapmax=208)
15119 dimension xa(iapmax,3)
15120 integer debug
15121 common /qgarr1/ ia(2),icz,icp
15122 common /qgarr3/ rmin,emax,eev
15123 common /qgarr11/ b10
15124
15125
15126 common /qgarr13/ nsf,iaf(iapmax)
15127 common /qgarr43/ moniou
15128 common /qgdebug/ debug
15129 EXTERNAL qgran
15130
15131 if(debug.ge.2)write (moniou,201)ns
15132
15133 nsf=0
15134 if(ns.eq.0)then !no fragments
15135 return
15136 elseif(ns.eq.1)then !single spectator nucleon recorded
15137 nsf=nsf+1
15138 iaf(nsf)=1
15139 if(debug.ge.3)write (moniou,205)
15140 return
15141 endif
15142
15143 eex=0.d0 !excitation energy for spectator part
15144 !sum of excitations due to wounded nucleons (including diffractive)
15145 do i=1,ia(1)-ns
15146
15147 eex=eex+(qgran(b10)+qgran(b10)+qgran(b10)+
15148 * qgran(b10)+qgran(b10)-2.5d0)**2*2.4d0
15149 enddo
15150 if(debug.ge.3)write (moniou,203)eex
15151
15152 if(eex/ns.gt.emax)then !if eex>emax -> multifragmentation
15153 call qgfrag(xa,ns,rmin) !multifragmentation (percolation algorithm)
15154 else !otherwise eveporation
15155 nf=npgen(eex/eev,0,ns-1) !number of eveporated nucleons (mean=eex/eev)
15156 nsf=nsf+1
15157 iaf(nsf)=ns-nf !recording of the fragment produced
15158 if(debug.ge.3)write (moniou,206)iaf(nsf)
15159
15160 nal=nf/4 !number of evapotared alphas (taken as nf/4)
15161 if(nal.ne.0)then
15162 do i=1,nal !recording the evaporated alphas
15163 nsf=nsf+1
15164 iaf(nsf)=4
15165 enddo
15166 endif
15167 nf=nf-4*nal
15168
15169 if(nf.ne.0)then
15170 do i=1,nf !recording the evaporated nucleons
15171 nsf=nsf+1
15172 iaf(nsf)=1
15173 enddo
15174 endif
15175 if(debug.ge.3)write (moniou,204)nf,nal
15176 endif
15177
15178
15179 if(debug.ge.3)write (moniou,202)
15180 201 format(2x,'qgfrgm: number of spectators: ns=',i2)
15181 202 format(2x,'qgfrgm - end')
15182 203 format(2x,'qgfrgm: excitation energy: eex=',e10.3)
15183 204 format(2x,'qgfrgm - evaporation: number of nucleons nf='
15184 *,i2,'number of alphas nal=',i2)
15185 205 format(2x,'qgfrgm - single spectator')
15186 206 format(2x,'qgfrgm - evaporation: mass number of the fragment:',i2)
15187 return
15188 end
15189
15190
15191 subroutine qggau(gz)
15192
15193
15194
15195
15196 implicit double precision (a-h,o-z)
15197 integer debug
15198 dimension gz(3),gz0(3)
15199 common /qgarr5/ rnuc(2),wsnuc(2),wbnuc(2),anorm
15200 *,cr1(2),cr2(2),cr3(2)
15201 common /qgarr6/ pi,bm,amws
15202 common /arr3/ x1(7),a1(7)
15203 common /qgarr43/ moniou
15204 common /qgdebug/ debug
15205
15206 if(debug.ge.2)write (moniou,201)
15207
15208 do i=1,3
15209 gz(i)=0.d0
15210 enddo
15211 do i=1,7
15212 do m=1,2
15213 b=bm*dsqrt(.5d0+x1(i)*(m-1.5d0))
15214 call qgfau(b,gz0)
15215 do l=1,3
15216 gz(l)=gz(l)+gz0(l)*a1(i)
15217 enddo
15218 enddo
15219 enddo
15220
15221 do l=1,3
15222 gz(l)=gz(l)*bm**2*pi*.5d0
15223 enddo
15224
15225 if(debug.ge.3)write (moniou,202)
15226 201 format(2x,'qggau - nuclear cross-sections calculation')
15227 202 format(2x,'qggau - end')
15228 return
15229 end
15230
15231
15232 subroutine qggau1(gz)
15233
15234
15235
15236
15237 implicit double precision (a-h,o-z)
15238 integer debug
15239 dimension gz(3),gz0(3)
15240 common /qgarr5/ rnuc(2),wsnuc(2),wbnuc(2),anorm
15241 *,cr1(2),cr2(2),cr3(2)
15242 common /qgarr6/ pi,bm,amws
15243 common /qgarr43/ moniou
15244 common /arr3/ x1(7),a1(7)
15245 common /qgdebug/ debug
15246
15247 if(debug.ge.2)write (moniou,201)
15248
15249 do i=1,7
15250 do m=1,2
15251 b=bm-wsnuc(2)*dlog(.5d0+x1(i)*(m-1.5d0))
15252 call qgfau(b,gz0)
15253 do l=1,3
15254 gz(l)=gz(l)+gz0(l)*a1(i)*exp((b-bm)/wsnuc(2))*b*pi*wsnuc(2)
15255 enddo
15256 enddo
15257 enddo
15258
15259 if(debug.ge.3)write (moniou,202)
15260 201 format(2x,'qggau1 - nuclear cross-sections calculation')
15261 202 format(2x,'qggau1 - end')
15262 return
15263 end
15264
15265
15266 double precision function qganrm(rnuc,wsnuc,wbnuc)
15267
15268
15269
15270
15271 implicit double precision (a-h,o-z)
15272 integer debug
15273 common /qgarr6/ pi,bm,amws
15274 common /arr3/ x1(7),a1(7)
15275 common /qgarr43/ moniou
15276 common /qgdebug/ debug
15277
15278 if(debug.ge.2)write (moniou,201)
15279
15280 qganrm=0.d0
15281 do i=1,7
15282 do m=1,2
15283 r=rnuc*(.5d0+x1(i)*(m-1.5d0))**(1.d0/3.d0)
15284 quq=(r-rnuc)/wsnuc
15285 if(quq.lt.1.d80)qganrm=qganrm+a1(i)/(1.d0+exp(quq))
15286 * *(1.d0+wbnuc*(r/rnuc)**2)
15287 enddo
15288 enddo
15289 qganrm=qganrm*rnuc**3*pi/1.5d0
15290
15291 dnrm=0.d0
15292 do i=1,7
15293 do m=1,2
15294 t=.5d0+x1(i)*(m-1.5d0)
15295 r=rnuc-wsnuc*log(t)
15296 dnrm=dnrm+a1(i)/(1.d0+t)*r*r
15297 * *(1.d0+wbnuc*(r/rnuc)**2)
15298 enddo
15299 enddo
15300 qganrm=1.d0/(qganrm+dnrm*2.d0*pi*wsnuc)
15301
15302 if(debug.ge.3)write (moniou,202)qganrm
15303 201 format(2x,'qganrm - nuclear density normalization')
15304 202 format(2x,'qganrm=',e10.3)
15305 return
15306 end
15307
15308
15309 subroutine qggene(wp0,wm0,ey0,s0x,c0x,s0,c0,ic1,ic2)
15310
15311
15312
15313
15314
15315
15316
15317
15318
15319 implicit double precision (a-h,o-z)
15320 integer debug
15321 character *2 tyq
15322 dimension wp(2),ic(2),ept(4),ep(4),ey(3),ey0(3)
15323
15324
15325 common /qgarr8/ wwm,bep,ben,bek,bec,dc(5),deta,almpt,ptdif
15326 *,ptndi
15327 common /qgarr10/ am0,amn,amk,amc,amlamc,amlam,ameta,ammu
15328 common /qgarr11/ b10
15329 common /qgarr19/ ahl(3)
15330 common /qgarr28/ arr(5)
15331 common /qgarr42/ tyq(16)
15332 common /qgarr43/ moniou
15333 common /qgdebug/ debug
15334 external qgran
15335
15336 if(debug.ge.2)write (moniou,201)tyq(8+ic1),tyq(8+ic2)
15337 *,wp0,wm0,ey0,s0x,c0x,s0,c0
15338
15339 ww=wp0*wm0 !mass squared for the string
15340 ept(1)=.5d0*(wp0+wm0) !4-momentum for the string
15341 ept(2)=.5d0*(wp0-wm0)
15342 ept(3)=0.d0
15343 ept(4)=0.d0
15344
15345 if(iabs(ic1).eq.5.or.iabs(ic2).eq.5.or.iabs(ic1).gt.8
15346 *.or.iabs(ic2).gt.8)stop'qggene: problem with parton types'
15347
15348 ic(1)=ic1 !parton types at string ends
15349 ic(2)=ic2
15350
15351 1 sww=dsqrt(ww)
15352 call qgdeft(ww,ept,ey) !boost to c.m. for the string
15353 j=int(2.d0*qgran(b10))+1 !choose string end to start
15354
15355 if(debug.ge.3)then
15356 iqt=8+ic(j)
15357 write (moniou,203)j,tyq(iqt),ww
15358 endif
15359
15360 iab=iabs(ic(j))
15361 is=ic(j)/iab
15362 if(iab.eq.8)then
15363 iab=6
15364 elseif(iab.gt.5)then
15365 iab=3
15366 endif
15367 iaj=iabs(ic(3-j))
15368 if(iaj.eq.8)then
15369 iaj=6
15370 elseif(iaj.gt.5)then
15371 iaj=3
15372 endif
15373 if(iab.eq.5)stop'no charm anymore!'
15374
15375 if(iaj.eq.3)then
15376 restm=amn
15377 elseif(iaj.eq.4)then
15378 restm=amk
15379 elseif(iaj.eq.5)then
15380 stop'no charm anymore!'
15381 elseif(iaj.eq.6)then
15382 restm=amlam
15383 else
15384 restm=am0
15385 endif
15386
15387 if(iab.le.2.and.sww.gt.restm+2.d0*am0+wwm
15388 *.or.iab.eq.3.and.sww.gt.restm+am0+amn+wwm
15389 *.or.iab.eq.4.and.sww.gt.restm+am0+amk+wwm
15390 *.or.iab.eq.6.and.sww.gt.restm+am0+amlam+wwm)then !more than 2 particles
15391 if(iab.le.2)then !light quark string end
15392 if(iab.eq.2.and.iabs(ic(3-j)).ne.7
15393 * .and.sww.gt.restm+2.d0*amlam.and.qgran(b10).lt.dc(1)*dc(2))then
15394
15395 restm=(restm+amlam)**2
15396 bet=ben
15397 ami=amlam**2
15398 alf=almpt-arr(2)+arr(1)-arr(3)
15399 blf=1.d0-arr(2)-arr(3)
15400 ic0=6*is !(anti-)lambda
15401 ic(j)=-8*is !US(us)
15402 elseif(sww.gt.restm+2.d0*amn.and.qgran(b10).lt.dc(1))then
15403
15404 restm=(restm+amn)**2
15405 bet=ben
15406 ami=amn**2
15407 alf=almpt-arr(2)
15408 blf=1.d0-arr(1)-arr(2)
15409 ic0=ic(j)+is
15410 ic(j)=-3*is
15411 elseif(sww.gt.restm+2.d0*amk.and.qgran(b10).lt.dc(2))then
15412
15413 restm=(restm+amk)**2
15414 bet=bek
15415 ami=amk**2
15416 alf=almpt-arr(3)
15417 blf=1.d0-arr(1)-arr(3)
15418 ic0=ic(j)+3*is
15419 ic(j)=4*is
15420 elseif(sww.gt.restm+ameta+am0.and.qgran(b10).lt.deta)then
15421
15422 restm=(restm+am0)**2
15423 bet=bek
15424 ami=ameta**2
15425 alf=almpt-arr(1)
15426 blf=1.d0-2.d0*arr(1)
15427 ic0=10
15428 else
15429
15430 restm=(restm+am0)**2
15431 bet=bep
15432 ami=am0**2
15433 alf=almpt-arr(1)
15434 blf=1.d0-2.d0*arr(1)
15435 if(qgran(b10).lt..3333d0)then
15436 ic0=0
15437 else
15438 ic0=3*is-2*ic(j)
15439 ic(j)=3*is-ic(j)
15440 endif
15441 endif
15442
15443 elseif(iab.eq.3)then
15444 if(sww.gt.restm+amk+amlam.and.qgran(b10).lt.dc(4)
15445 * .and.iabs(ic(j)).eq.3)then
15446
15447 restm=(restm+amk)**2
15448 bet=bek
15449 ami=amlam**2
15450 alf=almpt-arr(3)
15451 blf=1.d0-arr(2)-arr(3)
15452 ic0=6*is
15453 ic(j)=-4*is
15454 else
15455
15456 restm=(restm+am0)**2
15457 bet=ben
15458 ami=amn**2
15459 alf=almpt-arr(1)
15460 blf=1.d0-arr(1)-arr(2)
15461 if(iabs(ic(j)).eq.3)then
15462 ic0=is*int(2.5d0+qgran(b10))
15463 ic(j)=is-ic0
15464 else
15465 ic0=ic(j)-4*is
15466 ic(j)=ic0-4*is
15467 endif
15468 endif
15469
15470 elseif(iab.eq.4)then
15471 if(sww.gt.restm+amn+amlam.and.qgran(b10).lt.dc(1))then
15472
15473 restm=(restm+amn)**2
15474 bet=ben
15475 ami=amlam**2
15476 alf=almpt-arr(2)
15477 blf=1.d0-arr(2)-arr(3)
15478 ic0=6*is
15479 ic(j)=-3*is
15480 else
15481
15482 restm=(restm+am0)**2
15483 bet=bep
15484 ami=amk**2
15485 alf=almpt-arr(1)
15486 blf=1.d0-arr(1)-arr(3)
15487 ic(j)=is*int(1.5d0+qgran(b10))
15488 ic0=-3*is-ic(j)
15489 endif
15490
15491 elseif(iab.eq.6)then
15492
15493 restm=(restm+am0)**2
15494 bet=bep
15495 ami=amlam**2
15496 alf=almpt-arr(1)
15497 blf=1.d0-arr(2)-arr(3)
15498 ic0=6*is
15499 ic(j)=-2*is
15500 endif
15501
15502 ptmax=qglam(ww,restm,ami)
15503 if(ptmax.lt.0.)ptmax=0.
15504
15505 if(ptmax.lt.bet**2)then
15506 2 pti=ptmax*qgran(b10)
15507 if(qgran(b10).gt.exp(-dsqrt(pti)/bet))goto 2
15508 else
15509 3 pti=(bet*dlog(qgran(b10)*qgran(b10)))**2
15510 if(pti.gt.ptmax)goto 3
15511 endif
15512
15513 amt=ami+pti
15514 restm1=restm+pti
15515 zmin=1.d0-qgtwd(ww,restm1,amt)
15516 zmax=qgtwd(ww,amt,restm1)
15517
15518 z1=(1.d0-zmax)**alf
15519 z2=(1.d0-zmin)**alf
15520 4 z=1.-(z1+(z2-z1)*qgran(b10))**(1./alf)
15521 if(qgran(b10).gt.(z/zmax)**blf)goto 4
15522 wp(j)=z*sww
15523 wp(3-j)=amt/wp(j)
15524 ep(1)=.5d0*(wp(1)+wp(2))
15525 ep(2)=.5d0*(wp(1)-wp(2))
15526 pti=dsqrt(pti)
15527 call qgcs(c,s)
15528 ep(3)=pti*c
15529 ep(4)=pti*s
15530 ept(1)=sww-ep(1)
15531 do i=2,4
15532 ept(i)=-ep(i)
15533 enddo
15534 ww=qgnrm(ept)
15535 if(ww.lt.restm)goto 4
15536
15537 call qgtran(ep,ey,1)
15538 call qgtran(ept,ey,1)
15539 if(s0x.ne.0.d0.or.s0.ne.0.d0)then
15540 call qgrota(ep,s0x,c0x,s0,c0)
15541 endif
15542 if(ey0(1)*ey0(2)*ey0(3).ne.1.d0)then
15543 call qgtran(ep,ey0,1)
15544 endif
15545 call qgreg(ep,ic0)
15546
15547 else
15548 ami2=restm**2
15549 bet=bep
15550 if(iab.eq.6.or.iaj.eq.6)then
15551 if(iab.eq.6)then
15552 ami=amlam**2
15553 ic(j)=6*is
15554 if(iaj.eq.6)then
15555 ic(3-j)=-6*is
15556 elseif(iaj.eq.4)then
15557 ic(3-j)=-5*is
15558 elseif(iaj.le.2)then
15559 ic(3-j)=2*is-ic(3-j)
15560 else
15561 if(iabs(ic(3-j)).eq.3)then
15562 ic(3-j)=-3*is
15563 elseif(iabs(ic(3-j)).eq.6)then
15564 ic(3-j)=-2*is
15565 else
15566 stop'wrong parton types'
15567 endif
15568 endif
15569 elseif(iab.eq.4)then
15570 ami=amk**2
15571 ic(j)=-5*is
15572 ic(3-j)=6*is
15573 elseif(iab.le.2)then
15574 ami=am0**2
15575 ic(j)=2*is-ic(j)
15576 ic(3-j)=6*is
15577 else
15578 ami=amn**2
15579 ic(3-j)=-6*is
15580 if(iabs(ic(j)).eq.3)then
15581 ic(j)=3*is
15582 elseif(iabs(ic(j)).eq.6)then
15583 ic(j)=2*is
15584 else
15585 stop'wrong parton types'
15586 endif
15587 endif
15588
15589 elseif(iab.le.2.and.iaj.le.2)then
15590 if(sww.gt.2.d0*amk.and.qgran(b10).lt.dc(2))then
15591 bet=bek
15592 ami=amk**2
15593 ami2=ami
15594 ic(j)=ic(j)+3*is
15595 ic(3-j)=ic(3-j)-3*is
15596 else
15597 ami=am0**2
15598 ic0=-ic(1)-ic(2)
15599 if(ic0.ne.0)then
15600 ic(j)=ic0*int(.5d0+qgran(b10))
15601 ic(3-j)=ic0-ic(j)
15602 else
15603 if(qgran(b10).lt..2d0)then
15604 ic(j)=0
15605 ic(3-j)=0
15606 else
15607 ic(j)=3*is-2*ic(j)
15608 ic(3-j)=-ic(j)
15609 endif
15610 endif
15611 endif
15612
15613 elseif(iab.eq.3.or.iaj.eq.3)then
15614 if(iab.eq.3)then
15615 ami=amn**2
15616 if(iabs(ic(j)).eq.3)then
15617 if(iaj.eq.3)then
15618 if(iabs(ic(3-j)).eq.3)then
15619 if(sww.gt.2.d0*amlam.and.qgran(b10).lt.dc(4))then
15620 bet=bek
15621 ami=amlam**2
15622 ami2=ami
15623 ic(j)=6*is
15624 ic(3-j)=-6*is
15625 else
15626 ic(j)=is*int(2.5d0+qgran(b10))
15627 ic(3-j)=-ic(j)
15628 endif
15629 else
15630 ic(3-j)=ic(3-j)+4*is
15631 ic(j)=5*is+ic(3-j)
15632 endif
15633 elseif(iaj.lt.3)then
15634 if(sww.gt.amlam+amk.and.qgran(b10).lt.dc(4))then
15635 bet=bek
15636 ami=amlam**2
15637 ami2=amk**2
15638 ic(j)=6*is
15639 ic(3-j)=ic(3-j)+3*is
15640 else
15641 if(qgran(b10).lt..3333d0)then
15642 ic(j)=ic(3-j)+is
15643 ic(3-j)=0
15644 else
15645 ic(j)=is*(4-iaj)
15646 ic(3-j)=is*(3-2*iaj)
15647 endif
15648 endif
15649 elseif(iaj.eq.4)then
15650 ic(j)=is*int(2.5d0+qgran(b10))
15651 ic(3-j)=-ic(j)-2*is
15652 endif
15653 else
15654 if(iabs(ic(3-j)).gt.4)stop'qggene: problem with parton types'
15655 ic(j)=ic(j)-4*is
15656 ic0=ic(j)-4*is
15657 if(iaj.eq.3)then
15658 ic(3-j)=ic0-is
15659 elseif(iaj.lt.3)then
15660 ic(3-j)=-ic(3-j)-ic0
15661 elseif(iaj.eq.4)then
15662 ic(3-j)=ic0-3*is
15663 endif
15664 endif
15665 else
15666 if(iabs(ic(3-j)).eq.3)then
15667 if(iab.lt.3)then
15668 if(sww.gt.amlam+amk.and.qgran(b10).lt.dc(4))then
15669 bet=bek
15670 ami2=amlam**2
15671 ami=amk**2
15672 ic(j)=ic(j)+3*is
15673 ic(3-j)=6*is
15674 else
15675 ami=am0**2
15676 if(qgran(b10).lt..3333d0)then
15677 ic(3-j)=ic(j)+is
15678 ic(j)=0
15679 else
15680 ic(3-j)=is*(4-iab)
15681 ic(j)=is*(3-2*iab)
15682 endif
15683 endif
15684 elseif(iab.eq.4)then
15685 ami=amk**2
15686 ic(3-j)=is*int(2.5d0+qgran(b10))
15687 ic(j)=-ic(3-j)-2*is
15688 endif
15689 else
15690 ic(3-j)=ic(3-j)-4*is
15691 ic0=ic(3-j)-4*is
15692 if(iab.lt.3)then
15693 ami=am0**2
15694 ic(j)=-ic0-ic(j)
15695 elseif(iab.eq.4)then
15696 ami=amk**2
15697 ic(j)=ic0-3*is
15698 endif
15699 endif
15700 endif
15701 elseif(iab.eq.4.or.iaj.eq.4)then
15702 if(iab.eq.4)then
15703 ami=amk**2
15704 if(iaj.eq.4)then
15705 ic(j)=-is*int(4.5d0+qgran(b10))
15706 ic(3-j)=-ic(j)
15707 else
15708 ic0=ic(3-j)+int(.6667d0+qgran(b10))*(-3*is-2*ic(3-j))
15709 ic(j)=ic0-3*is
15710 ic(3-j)=ic0-ic(3-j)
15711 endif
15712 else
15713 ami=am0**2
15714 ic0=ic(j)+int(.6667d0+qgran(b10))*(3*is-2*ic(j))
15715 ic(j)=ic0-ic(j)
15716 ic(3-j)=ic0+3*is
15717 endif
15718 endif
15719
15720 ptmax=qglam(ww,ami2,ami)
15721 if(ptmax.lt.0.)ptmax=0.
15722 if(ptmax.lt.bet**2)then
15723 5 pti=ptmax*qgran(b10)
15724 if(qgran(b10).gt.exp(-dsqrt(pti)/bet))goto 5
15725 else
15726 6 pti=(bet*dlog(qgran(b10)*qgran(b10)))**2
15727 if(pti.gt.ptmax)goto 6
15728 endif
15729 amt1=ami+pti
15730 amt2=ami2+pti
15731 z=qgtwd(ww,amt1,amt2)
15732 wp(j)=z*sww
15733 wp(3-j)=amt1/wp(j)
15734 ep(1)=.5d0*(wp(1)+wp(2))
15735 ep(2)=.5d0*(wp(1)-wp(2))
15736 pti=dsqrt(pti)
15737 call qgcs(c,s)
15738 ep(3)=pti*c
15739 ep(4)=pti*s
15740 ept(1)=sww-ep(1)
15741 do i=2,4
15742 ept(i)=-ep(i)
15743 enddo
15744 call qgtran(ep,ey,1)
15745 call qgtran(ept,ey,1)
15746 if(s0x.ne.0.d0.or.s0.ne.0.d0)then
15747 call qgrota(ep,s0x,c0x,s0,c0)
15748 call qgrota(ept,s0x,c0x,s0,c0)
15749 endif
15750 if(ey0(1)*ey0(2)*ey0(3).ne.1.d0)then
15751 call qgtran(ep,ey0,1)
15752 call qgtran(ept,ey0,1)
15753 endif
15754
15755 call qgreg(ep,ic(j))
15756 call qgreg(ept,ic(3-j))
15757 if(debug.ge.3)write (moniou,202)
15758 return
15759 endif
15760 goto 1
15761
15762 201 format(2x,'qggene: parton flavors at the ends of the string:'
15763 *,2x,a2,2x,a2/4x,'light cone momenta of the string: ',e10.3
15764 *,2x,e10.3/4x,'ey0=',3e10.3/4x,'s0x=',e10.3,2x,'c0x=',e10.3
15765 *,2x,'s0=',e10.3,2x,'c0=',e10.3)
15766 202 format(2x,'qggene - end')
15767 203 format(2x,'qggene: current parton flavor at the end '
15768 *,i1,' of the string: ',a2/4x,' string mass: ',e10.3)
15769 end
15770
15771
15772 subroutine qgxjet
15773
15774
15775
15776 implicit double precision (a-h,o-z)
15777 integer debug
15778 parameter(njmax=50000)
15779 dimension ep(4),ept(4),ept1(4),ey(3)
15780 *,epj(4,2,2*njmax),ipj(2,2*njmax)
15781 common /qgarr8/ wwm,be(4),dc(5),deta,almpt,ptdif,ptndi
15782 common /qgarr10/ am(7),ammu
15783 common /qgarr11/ b10
15784 common /qgarr36/ epjet(4,njmax),ipjet(njmax),njtot
15785 common /qgarr43/ moniou
15786 common /qgdebug/ debug
15787 external qgran
15788
15789 if(debug.ge.2)write (moniou,201)njtot
15790 201 format(2x,'qgxjet: total number of jets njtot=',i4)
15791
15792 nj0=1
15793 njet0=0
15794 nrej=0
15795
15796 1 njet=njet0
15797 do i=1,4
15798 ept(i)=epjet(i,nj0)
15799 epj(i,1,njet+1)=ept(i)
15800 enddo
15801 iq1=ipjet(nj0)
15802 ipj(1,njet+1)=iq1
15803
15804 if(iabs(iq1).le.2)then
15805 am1=am(1)
15806 if(iq1.gt.0)then
15807 jq=1
15808 else
15809 jq=2
15810 endif
15811 elseif(iabs(iq1).eq.4)then
15812 am1=am(3)
15813 if(iq1.gt.0)then
15814 jq=1
15815 else
15816 jq=2
15817 endif
15818 else
15819 am1=am(2)
15820 if(iq1.gt.0)then
15821 jq=2
15822 else
15823 jq=1
15824 endif
15825 endif
15826
15827 ij=nj0
15828 2 ij=ij+1
15829 njet=njet+1
15830 iq2=ipjet(ij)
15831
15832 if(iq2.eq.0)then
15833 aks=qgran(b10)
15834 do i=1,4
15835 epi=epjet(i,ij)*aks
15836 epj(i,2,njet)=epi
15837 ept(i)=ept(i)+epi
15838 enddo
15839 if(qgran(b10).lt.dc(2))then
15840 ipj(2,njet)=4*(2*jq-3)
15841 amj=am(3)
15842 else
15843 ipj(2,njet)=int(1.5d0+qgran(b10))*(2*jq-3)
15844 amj=am(1)
15845 endif
15846
15847 if(qgnrm(ept).gt.(am1+amj)**2)then
15848 if(debug.ge.3)write (moniou,211)njet,ipj(1,njet),ipj(2,njet)
15849 * ,qgnrm(ept),ept
15850
15851 ipj(1,njet+1)=-ipj(2,njet)
15852 do i=1,4
15853 ept(i)=epjet(i,ij)-epj(i,2,njet)
15854 epj(i,1,njet+1)=ept(i)
15855 enddo
15856 am1=amj
15857 goto 2
15858 elseif(nrej.lt.100000)then
15859 nrej=nrej+1
15860 goto 1
15861 else
15862 3 continue
15863 do i=1,4
15864 ept(i)=epjet(i,ij)+epjet(i,ij-1)+epjet(i,ij+1)
15865 ep(i)=epjet(i,ij-1)
15866 ept1(i)=ept(i)
15867 enddo
15868 ww=qgnrm(ept1)
15869 if(ww.le.0.)then
15870 if(ij.gt.nj0+1)then
15871 ij=ij-1
15872 goto 3
15873 else
15874 ij=ij+1
15875 goto 3
15876 endif
15877 endif
15878 ipjet(ij)=ipjet(ij+1)
15879 sww=sqrt(ww)
15880 call qgdeft(ww,ept1,ey)
15881 call qgtran(ep,ey,-1)
15882 call qgdefr(ep,s0x,c0x,s0,c0)
15883 ep(1)=.5d0*sww
15884 ep(2)=.5d0*sww
15885 ep(3)=0.d0
15886 ep(4)=0.d0
15887 call qgrota(ep,s0x,c0x,s0,c0)
15888 call qgtran(ep,ey,1)
15889 do i=1,4
15890 epjet(i,ij-1)=ep(i)
15891 epjet(i,ij)=ept(i)-ep(i)
15892 enddo
15893
15894 if(njtot.gt.ij+1)then
15895 do j=ij+1,njtot-1
15896 ipjet(j)=ipjet(j+1)
15897 do i=1,4
15898 epjet(i,j)=epjet(i,j+1)
15899 enddo
15900 enddo
15901 endif
15902 nrej=0
15903 njtot=njtot-1
15904 goto 1
15905 endif
15906
15907 else
15908 ipj(2,njet)=iq2
15909 do i=1,4
15910 epi=epjet(i,ij)
15911 epj(i,2,njet)=epi
15912 ept(i)=ept(i)+epi
15913 enddo
15914
15915 if(iabs(iq2).le.2)then
15916 am2=am(1)
15917 elseif(iabs(iq2).eq.4)then
15918 am2=am(3)
15919 else
15920 am2=am(2)
15921 endif
15922
15923 if(qgnrm(ept).gt.(am1+am2)**2)then
15924 if(debug.ge.3)write (moniou,211)njet,ipj(1,njet),ipj(2,njet)
15925 * ,qgnrm(ept),ept
15926
15927 nj0=ij+1
15928 njet0=njet
15929 nrej=0
15930 if(ij.lt.njtot)then
15931 goto 1
15932 else
15933 goto 5
15934 endif
15935 elseif(nrej.lt.100000)then
15936 nrej=nrej+1
15937 goto 1
15938 else
15939 4 continue
15940 do i=1,4
15941 ept(i)=epjet(i,ij)+epjet(i,ij-1)+epjet(i,ij-2)
15942 ep(i)=epjet(i,ij-2)
15943 ept1(i)=ept(i)
15944 enddo
15945 ww=qgnrm(ept1)
15946 if(ww.lt.0.d0)then
15947 ij=ij-1
15948 goto 4
15949 endif
15950 ipjet(ij-1)=ipjet(ij)
15951 sww=sqrt(ww)
15952 call qgdeft(ww,ept1,ey)
15953 call qgtran(ep,ey,-1)
15954 call qgdefr(ep,s0x,c0x,s0,c0)
15955 ep(1)=.5d0*sww
15956 ep(2)=.5d0*sww
15957 ep(3)=0.d0
15958 ep(4)=0.d0
15959 call qgrota(ep,s0x,c0x,s0,c0)
15960 call qgtran(ep,ey,1)
15961 do i=1,4
15962 epjet(i,ij-2)=ep(i)
15963 epjet(i,ij-1)=ept(i)-ep(i)
15964 enddo
15965
15966 if(ij.lt.njtot)then
15967 do j=ij,njtot-1
15968 ipjet(j)=ipjet(j+1)
15969 do i=1,4
15970 epjet(i,j)=epjet(i,j+1)
15971 enddo
15972 enddo
15973 endif
15974
15975 nrej=0
15976 njtot=njtot-1
15977 goto 1
15978 endif
15979 endif
15980
15981 5 continue
15982 do ij=1,njet
15983 do i=1,4
15984 ep(i)=epj(i,1,ij)
15985 ept(i)=ep(i)+epj(i,2,ij)
15986 enddo
15987
15988 ww=qgnrm(ept)
15989
15990 if(debug.ge.3)write (moniou,208)
15991 * ij,njet,ww,ipj(1,ij),ipj(2,ij)
15992
15993 sww=dsqrt(ww)
15994 call qgdeft(ww,ept,ey)
15995 call qgtran(ep,ey,-1)
15996 call qgdefr(ep,s0x,c0x,s0,c0)
15997 call qggene(sww,sww,ey,s0x,c0x,s0,c0,ipj(1,ij),ipj(2,ij))
15998 enddo
15999
16000 if(debug.ge.3)write (moniou,202)
16001 202 format(2x,'qgxjet - end')
16002 208 format(2x,'qgxjet: ij=',i2,2x,'njet=',i3,2x,'ww=',e10.3
16003 *,2x,'ic=',2i3)
16004 211 format(2x,'qgxjet: njet=',i3,2x,'ic=',2i2,2x,'mass=',e10.3
16005 *,2x,'ep=',4e10.3)
16006 return
16007 end
16008
16009
16010 double precision function qgrot(b,s)
16011
16012
16013
16014 implicit double precision (a-h,o-z)
16015 integer debug
16016 common /arr8/ x2(4),a2
16017 common /qgarr43/ moniou
16018 common /qgdebug/ debug
16019
16020 if(debug.ge.2)write (moniou,201)b,s
16021
16022 qgrot=0.d0
16023 do i=1,4
16024 sb1=b**2+s**2-2.*b*s*(2.*x2(i)-1.)
16025 sb2=b**2+s**2-2.*b*s*(1.-2.*x2(i))
16026 qgrot=qgrot+(qgt(sb1)+qgt(sb2))
16027 enddo
16028 qgrot=qgrot*a2
16029
16030 if(debug.ge.2)write (moniou,202)qgrot
16031 201 format(2x,'qgrot - axial angle integration of the ',
16032 *'nuclear profile function'/4x,
16033 *'impact parameter b=',e10.3,2x,'nucleon coordinate s=',e10.3)
16034 202 format(2x,'qgrot=',e10.3)
16035 return
16036 end
16037
16038
16039 subroutine qgstr(wpi0,wmi0,wp0,wm0,ic10,ic120,ic210,ic20,jp,jt)
16040
16041
16042
16043
16044
16045 implicit double precision (a-h,o-z)
16046 integer debug
16047 dimension ey(3)
16048 common /qgarr6/ pi,bm,amws
16049 common /qgarr8/ wwm,be(4),dc(5),deta,almpt,ptdif,ptndi
16050 common /qgarr10/ am(7),ammu
16051 common /qgarr11/ b10
16052 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
16053 common /qgarr43/ moniou
16054 common /qgdebug/ debug
16055 EXTERNAL qgran
16056
16057 if(debug.ge.2)write (moniou,201)wpi0,wmi0,wp0,wm0
16058
16059 do i=1,3
16060 ey(i)=1.d0
16061 enddo
16062 wpi=wpi0
16063 wmi=wmi0
16064
16065
16066 if(ic10.eq.0)then
16067 if(qgran(b10).lt.dc(2))then
16068 ic1=4
16069 ic12=-4
16070 else
16071 ic1=int(1.5+qgran(b10))
16072 ic12=-ic1
16073 endif
16074 elseif(ic10.gt.0)then
16075 ic1=ic10
16076 ic12=ic120
16077 else
16078 ic1=ic120
16079 ic12=ic10
16080 endif
16081
16082 if(ic20.eq.0)then
16083 if(qgran(b10).lt.dc(2))then
16084 ic2=4
16085 ic21=-4
16086 else
16087 ic2=int(1.5+qgran(b10))
16088 ic21=-ic2
16089 endif
16090 elseif(ic20.gt.0)then
16091 ic2=ic20
16092 ic21=ic210
16093 else
16094 ic2=ic210
16095 ic21=ic20
16096 endif
16097
16098
16099 if(jp.eq.0)then
16100 wp1=wpi*cos(pi*qgran(b10))**2
16101 else
16102 1 xp=.5d0*qgran(b10)**2
16103 if(qgran(b10).gt.(2.d0*(1.d0-xp))**(-.5d0))goto 1
16104 wp1=wpi*xp
16105 if(qgran(b10).lt..5d0)wp1=wpi-wp1
16106 endif
16107 if(jt.eq.0)then
16108 wm1=wmi*cos(pi*qgran(b10))**2
16109 else
16110 2 xm=.5d0*qgran(b10)**2
16111 if(qgran(b10).gt.(2.d0*(1.d0-xm))**(-.5d0))goto 2
16112 wm1=wmi*xm
16113 if(qgran(b10).lt..5d0)wm1=wmi-wm1
16114 endif
16115 wpi=wpi-wp1
16116 wmi=wmi-wm1
16117
16118 sm1=wp1*wm1
16119 sm2=wpi*wmi
16120
16121
16122 if(iabs(ic1).le.2)then
16123 am1=am(1)
16124 elseif(iabs(ic1).eq.3)then
16125 am1=am(2)
16126 elseif(iabs(ic1).eq.4)then
16127 am1=am(3)
16128 else
16129 am1=0.d0
16130 stop 'should not happen in qgstr 1 !'
16131 endif
16132 if(iabs(ic2).le.2)then
16133 am2=am(1)
16134 elseif(iabs(ic2).eq.3)then
16135 am2=am(2)
16136 elseif(iabs(ic2).eq.4)then
16137 am2=am(3)
16138 else
16139 am2=0.d0
16140 stop 'should not happen in qgstr 2 !'
16141 endif
16142 if(iabs(ic12).le.2)then
16143 am12=am(1)
16144 elseif(iabs(ic12).eq.3)then
16145 am12=am(2)
16146 elseif(iabs(ic12).eq.4)then
16147 am12=am(3)
16148 else
16149 am12=0.d0
16150 stop 'should not happen in qgstr 3 !'
16151 endif
16152 if(iabs(ic21).le.2)then
16153 am21=am(1)
16154 elseif(iabs(ic21).eq.3)then
16155 am21=am(2)
16156 elseif(iabs(ic21).eq.4)then
16157 am21=am(3)
16158 else
16159 am21=0.d0
16160 stop 'should not happen in qgstr 4 !'
16161 endif
16162
16163
16164
16165 if(sm1.gt.am1+am21.and.sm2.gt.am2+am12)then
16166
16167 call qggene(wp1,wm1,ey,0.d0,1.d0,0.d0,1.d0,ic1,ic21)
16168 call qggene(wpi,wmi,ey,0.d0,1.d0,0.d0,1.d0,ic12,ic2)
16169 elseif((wpi+wp1)*(wmi+wm1).gt.am1+am21)then
16170 call qggene(wp1+wpi,wm1+wmi,ey,0.d0,1.d0,0.d0,1.d0,ic1,ic21)
16171 elseif((wpi+wp1)*(wmi+wm1).gt.am2+am12)then
16172 call qggene(wp1+wpi,wm1+wmi,ey,0.d0,1.d0,0.d0,1.d0,ic12,ic2)
16173 else
16174 wp0=wp0+wp1+wpi
16175 wm0=wm0+wm1+wmi
16176 endif
16177
16178 if(debug.ge.3)write (moniou,202)wp0,wm0
16179 201 format(2x,'qgstr: wpi0=',e10.3,2x,'wmi0=',e10.3
16180 *,2x,'wp0=',e10.3,2x,'wm0=',e10.3)
16181 202 format(2x,'qgstr - returned light cone momenta:'
16182 *,2x,'wp0=',e10.3,2x,'wm0=',e10.3)
16183 return
16184 end
16185
16186
16187 double precision function qgt(b)
16188
16189
16190
16191 implicit double precision (a-h,o-z)
16192 integer debug
16193 common /qgarr5/ rnuc(2),wsnuc(2),wbnuc(2),anorm
16194 *,cr1(2),cr2(2),cr3(2)
16195 common /qgarr6/ pi,bm,amws
16196 common /arr3/ x1(7),a1(7)
16197 common /qgarr43/ moniou
16198 common /qgdebug/ debug
16199
16200 if(debug.ge.2)write (moniou,201)b
16201
16202 qgt=0.
16203 zm=rnuc(2)**2-b
16204 if(zm.gt.4.*b)then
16205 zm=dsqrt(zm)
16206 else
16207 zm=2.*dsqrt(b)
16208 endif
16209
16210 do i=1,7
16211 do m=1,2
16212 z1=zm*(.5d0+x1(i)*(m-1.5d0))
16213 r=dsqrt(b+z1**2)
16214 quq=(r-rnuc(2))/wsnuc(2)
16215 if (quq.lt.85.)qgt=qgt+a1(i)/(1.+exp(quq))
16216 * *(1.d0+wbnuc(2)*(r/rnuc(2))**2)
16217 enddo
16218 enddo
16219 qgt=qgt*zm*0.5d0
16220
16221 dt=0.
16222 do i=1,7
16223 do m=1,2
16224 z1=zm-wsnuc(2)*log(.5d0+x1(i)*(m-1.5d0))
16225 r=dsqrt(b+z1**2)
16226 quq=(r-rnuc(2)-z1+zm)/wsnuc(2)
16227 if (quq.lt.85.)dt=dt+a1(i)/(exp((zm-z1)/wsnuc(2))+exp(quq))
16228 * *(1.d0+wbnuc(2)*(r/rnuc(2))**2)
16229 enddo
16230 enddo
16231 qgt=qgt+dt*wsnuc(2)/2.d0
16232
16233 if(debug.ge.3)write (moniou,202)qgt
16234 201 format(2x,'qgt - nuclear profile function value at impact'
16235 *,' parameter squared b=',e10.3)
16236 202 format(2x,'qgt=',e10.3)
16237 return
16238 end
16239
16240
16241 block data qgdata
16242
16243
16244
16245 implicit double precision (a-h,o-z)
16246 common /arr1/ trnuc(56),twsnuc(56),twbnuc(56)
16247 common /arr3/ x1(7),a1(7)
16248 common /arr4/ x4(2),a4(2)
16249 common /arr5/ x5(2),a5(2)
16250 common /arr8/ x2(4),a2
16251 common /arr9/ x9(3),a9(3)
16252 data x1/.9862838d0,.9284349d0,.8272013d0,.6872929d0,.5152486d0,
16253 *.3191124d0,.1080549d0/
16254 data a1/.03511946d0,.08015809d0,.1215186d0,.1572032d0,
16255 *.1855384d0,.2051985d0,.2152639d0/
16256 data x2/.00960736d0,.0842652d0,.222215d0,.402455d0/
16257 data a2/.392699d0/
16258 data x4/ 0.339981,0.861136/
16259 data a4/ 0.652145,0.347855/
16260 data x5/.585786d0,3.41421d0/
16261 data a5/.853553d0,.146447d0/
16262 data x9/.93247d0,.661209d0,.238619d0/
16263 data a9/.171324d0,.360762d0,.467914d0/
16264 data trnuc/0.69d0,1.71d0,1.53d0,1.37d0,1.37d0,2.09d0,1.95d0
16265 *,1.95d0,2.06d0,1.76d0,1.67d0,1.74d0,1.66d0,2.57d0,2.334d0
16266 *,2.608d0,2.201d0,2.331d0,2.58d0,2.791d0,2.791d0,2.782d0,2.74d0
16267 *,3.192d0,3.22d0,3.05d0,3.07d0,3.34d0,3.338d0,3.252d0
16268 *,3.369d0,3.244d0,3.244d0,3.313d0,3.476d0,3.54d0,3.554d0
16269 *,3.554d0,3.743d0,3.73d0,3.744d0,3.759d0,3.774d0,3.788d0
16270 *,3.802d0,3.815d0,3.829d0,3.843d0,3.855d0,3.941d0
16271 *,3.94d0,3.984d0,4.d0,4.074d0,3.89d0,4.111d0/
16272 data twsnuc/0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0
16273 *,0.55d0,0.55d0,0.56d0,0.56d0,0.5052d0,0.498d0,0.513d0
16274 *,0.55d0,0.55d0,0.567d0,0.698d0,0.698d0,0.549d0,0.55d0
16275 *,0.604d0,0.58d0,0.523d0,0.519d0,0.58d0,0.547d0,0.553d0
16276 *,0.582d0,0.55d0,0.55d0,0.7d0,0.599d0,0.507d0,0.588d0
16277 *,0.588d0,0.585d0,0.62d0,0.55d0,0.55d0,0.55d0,0.55d0
16278 *,0.55d0,0.55d0,0.55d0,0.588d0,0.588d0
16279 *,0.566d0,0.505d0,0.542d0,0.557d0,0.536d0,0.567d0,0.558d0/
16280 data twbnuc/0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0
16281 *,0.d0,0.d0,0.d0,0.d0,-0.18d0,0.139d0,-0.051d0,0.d0,0.d0
16282 *,0.d0,-0.168d0,0.d0,0.d0,0.d0,-0.249d0,-0.236d0,0.d0,0.d0
16283 *,0.233d0,-0.203d0,-0.078d0,-0.173d0,0.d0,0.d0,0.d0,-0.1d0
16284 *,0.d0,-0.13d0,-0.13d0,-0.201d0,-0.19d0,0.d0,0.d0,0.d0,0.d0
16285 *,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0
16286 *,0.d0,0.d0/
16287 end
16288
16289
16290 real function qggamfun(x)
16291
16292
16293
16294 dimension c(13)
16295 data c
16296 1/ 0.00053 96989 58808, 0.00261 93072 82746, 0.02044 96308 23590,
16297 2 0.07309 48364 14370, 0.27964 36915 78538, 0.55338 76923 85769,
16298 3 0.99999 99999 99998,-0.00083 27247 08684, 0.00469 86580 79622,
16299 4 0.02252 38347 47260,-0.17044 79328 74746,-0.05681 03350 86194,
16300 5 1.13060 33572 86556/
16301 qggamfun=0
16302 z=x
16303 if(x .gt. 0.0) goto1
16304 if(x .eq. aint(x)) goto5
16305 z=1.0-z
16306 1 f=1.0/z
16307 if(z .le. 1.0) goto4
16308 f=1.0
16309 2 continue
16310 if(z .lt. 2.0) goto3
16311 z=z-1.0
16312 f=f*z
16313 goto2
16314 3 z=z-1.0
16315 4 qggamfun=
16316 1 f*((((((c(1)*z+c(2))*z+c(3))*z+c(4))*z+c(5))*z+c(6))*z+c(7))/
16317 2 ((((((c(8)*z+c(9))*z+c(10))*z+c(11))*z+c(12))*z+c(13))*z+1.0)
16318 if(x .gt. 0.0) return
16319 qggamfun=3.141592653589793/(sin(3.141592653589793*x)*qggamfun)
16320 return
16321 5 write(*,10)x
16322 10 format(1x,'argument of gamma fctn = ',e20.5)
16323 stop
16324 end
16325
16326
16327 subroutine qgcrossc(niter,gtot,gprod,gabs,gdd,gqel,gcoh)
16328
16329
16330
16331
16332
16333
16334
16335
16336
16337
16338
16339 implicit double precision (a-h,o-z)
16340 parameter(iapmax=208)
16341 dimension wabs(28),wdd(28),wqel(28),wcoh(28)
16342 *,wprod(28),b0(28),ai(28),xa(iapmax,3),xb(iapmax,3)
16343 common /qgarr1/ ia(2),icz,icp
16344 common /qgarr5/ rnuc(2),wsnuc(2),wbnuc(2),anorm
16345 *,cr1(2),cr2(2),cr3(2)
16346 common /qgarr6/ pi,bm,amws
16347 common /qgarr11/ b10
16348 common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
16349 common /arr3/ x1(7),a1(7)
16350 EXTERNAL qgran
16351
16352 e1=exp(-1.d0)
16353
16354 do i=1,7
16355 b0(15-i)=bm*sqrt((1.d0+x1(i))/2.d0)
16356 b0(i)=bm*sqrt((1.d0-x1(i))/2.d0)
16357 ai(i)=a1(i)*bm**2*5.d0*pi
16358 ai(15-i)=ai(i)
16359 enddo
16360
16361 do i=1,7
16362 tp=(1.d0+x1(i))/2.d0
16363 tm=(1.d0-x1(i))/2.d0
16364 b0(14+i)=bm-log(tp)*max(wsnuc(1),wsnuc(2))
16365 b0(29-i)=bm-log(tm)*max(wsnuc(1),wsnuc(2))
16366 ai(14+i)=a1(i)*b0(14+i)/tp*10.d0*max(wsnuc(1),wsnuc(2))*pi
16367 ai(29-i)=a1(i)*b0(29-i)/tm*10.d0*max(wsnuc(1),wsnuc(2))*pi
16368 enddo
16369
16370 do i=1,28
16371 wabs(i)=0.
16372 wdd(i)=0.
16373 wqel(i)=0.
16374 wcoh(i)=0.
16375 enddo
16376
16377 do nc=1,niter
16378 do i=1,ia(2)
16379 iddt(i)=1+int(qgran(b10)+cc(2,2))
16380 enddo
16381
16382 if(ia(1).eq.1)then
16383 xa(1,1)=0.d0
16384 xa(1,2)=0.d0
16385 xa(1,3)=0.d0
16386 else
16387 call qggea(ia(1),xa,1)
16388 endif
16389 if(ia(2).eq.1)then
16390 xb(1,1)=0.d0
16391 xb(1,2)=0.d0
16392 xb(1,3)=0.d0
16393 else
16394 call qggea(ia(2),xb,2)
16395 endif
16396
16397 do i=1,28
16398 call qggcr(b0(i),gabs,gdd,gqel,gcoh,xa,xb,ia(1))
16399 wabs(i)=wabs(i)+gabs
16400 wdd(i)=wdd(i)+gdd
16401 wqel(i)=wqel(i)+gqel
16402 wcoh(i)=wcoh(i)+gcoh
16403 enddo
16404 enddo
16405
16406 gabs=0.
16407 gdd=0.
16408 gqel=0.
16409 gcoh=0.
16410 do i=1,28
16411 wabs(i)=wabs(i)/niter
16412 wdd(i)=wdd(i)/niter
16413 wqel(i)=wqel(i)/niter
16414 wcoh(i)=wcoh(i)/niter
16415 wprod(i)=wabs(i)+wdd(i)
16416 gabs=gabs+ai(i)*wabs(i)
16417 gdd=gdd+ai(i)*wdd(i)
16418 gqel=gqel+ai(i)*wqel(i)
16419 gcoh=gcoh+ai(i)*wcoh(i)
16420 enddo
16421 gprod=gabs+gdd
16422 gtot=gprod+gqel+gcoh
16423 return
16424 end
16425
16426
16427 subroutine qggcr(b,gabs,gdd,gqel,gcoh,xa,xb,ia)
16428
16429 implicit double precision (a-h,o-z)
16430 parameter(iapmax=208)
16431 dimension xa(iapmax,3),xb(iapmax,3),vabs(2)
16432
16433 gabs=1.
16434 gdd=1.
16435 gqel=1.
16436 gcoh=1.
16437 do n=1,ia
16438 call qgv(xa(n,1)+b,xa(n,2),xb,vin,vdd,vabs)
16439 gabs=gabs*(vdd-vin+1.d0) !prod_n^A [sum_i c_i exp(-2chi_i(n))]
16440 gdd=gdd*(1.-vin) !prod_n^A [sum_i c_i exp(-chi_i(n))]^2
16441 gqel=gqel*(2.d0*dsqrt(1.d0-vin)-1.d0)
16442 !prod_n^A [sum_i c_i exp(-chi_i(n)) - 1]
16443 gcoh=gcoh*dsqrt(1.d0-vin)
16444 enddo
16445 gcoh=1.-2.*gcoh+gqel
16446 gqel=gdd-gqel
16447 gdd=gabs-gdd
16448 gabs=1.-gabs
16449 return
16450 end
16451
16452
16453 double precision function qgsect(e0n,icz,iap,iat)
16454
16455
16456
16457
16458
16459
16460
16461 implicit double precision (a-h,o-z)
16462 integer debug
16463 dimension wk(3),wa(3),wb(3)
16464 common /qgarr47/ gsect(10,5,6)
16465 common /qgarr48/ qgsasect(10,6,6)
16466 common /qgarr43/ moniou
16467 common /qgdebug/ debug
16468
16469 if(debug.ge.3)write (moniou,201)e0n,icz,iap,iat
16470 qgsect=0.d0
16471 ye=dlog10(e0n)
16472 if(ye.lt.1.d0)ye=1.d0
16473 je=int(ye)
16474 if(je.gt.8)je=8
16475
16476 wk(2)=ye-je
16477 wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
16478 wk(1)=1.d0-wk(2)+wk(3)
16479 wk(2)=wk(2)-2.d0*wk(3)
16480
16481 yb=iat
16482 yb=dlog(yb)/1.38629d0+1.d0
16483 jb=min(int(yb),2)
16484 wb(2)=yb-jb
16485 wb(3)=wb(2)*(wb(2)-1.d0)*.5d0
16486 wb(1)=1.d0-wb(2)+wb(3)
16487 wb(2)=wb(2)-2.d0*wb(3)
16488
16489 if(iap.eq.1)then
16490 if(iat.eq.14)then
16491 do i=1,3
16492 qgsect=qgsect+gsect(je+i-1,icz,5)*wk(i)
16493 enddo
16494 elseif(iat.eq.40)then
16495 do i=1,3
16496 qgsect=qgsect+gsect(je+i-1,icz,6)*wk(i)
16497 enddo
16498 else
16499 do i=1,3
16500 do l=1,3
16501 qgsect=qgsect+gsect(je+i-1,icz,jb+l-1)*wk(i)*wb(l)
16502 enddo
16503 enddo
16504 endif
16505 else
16506 ya=iap
16507 ya=dlog(ya/2.d0)/.69315d0+1.d0
16508 ja=min(int(ya),4)
16509 wa(2)=ya-ja
16510 wa(3)=wa(2)*(wa(2)-1.d0)*.5d0
16511 wa(1)=1.d0-wa(2)+wa(3)
16512 wa(2)=wa(2)-2.d0*wa(3)
16513 if(iat.eq.14)then
16514 do i=1,3
16515 do m=1,3
16516 qgsect=qgsect+qgsasect(je+i-1,ja+m-1,5)*wk(i)*wa(m)
16517 enddo
16518 enddo
16519 elseif(iat.eq.40)then
16520 do i=1,3
16521 do m=1,3
16522 qgsect=qgsect+qgsasect(je+i-1,ja+m-1,6)*wk(i)*wa(m)
16523 enddo
16524 enddo
16525 else
16526 do i=1,3
16527 do m=1,3
16528 do l=1,3
16529 qgsect=qgsect+qgsasect(je+i-1,ja+m-1,jb+l-1)*wk(i)*wa(m)*wb(l)
16530 enddo
16531 enddo
16532 enddo
16533 endif
16534 endif
16535 qgsect=exp(qgsect)
16536 if(debug.ge.4)write (moniou,202)
16537
16538 201 format(2x,'qgsect - nucleus-nucleus production cross section'
16539 */4x,'lab. energy per nucleon - ',e10.3,2x,'hadron class - ',i2
16540 */4x,'proj. mass N - ',i3,2x,'targ. mass N - ',i3)
16541 202 format(2x,'qgsect=',e10.3)
16542 return
16543 end
16544
16545
16546 subroutine qgreg(ep0,ic)
16547
16548
16549
16550
16551
16552 implicit double precision (a-h,o-z)
16553 integer debug
16554 parameter(nptmax=95000)
16555 dimension ep(4),ep0(4),ep1(4),ep2(4),ep3(4)
16556 common /qgarr4/ ey0(3)
16557 common /qgarr10/ am0,amn,amk,amc,amlamc,amlam,ameta,ammu
16558 common /qgarr11/ b10
16559 common /qgarr12/ nsh
16560 common /qgarr14/ esp(4,nptmax),ich(nptmax)
16561 common /qgarr21/ dmmin(3),wex(3),dmres(3),wdres(3)
16562 common /qgarr43/ moniou
16563 common /qgdebug/ debug
16564 external qgran
16565
16566 if(debug.ge.3)write (moniou,201)ic,ep0,nsh
16567 nsh=nsh+1
16568
16569 nstprev = nsh
16570
16571 if(nsh.gt.nptmax)stop'increase nptmax!!!'
16572 iab=iabs(ic)
16573 do i=1,4
16574 ep(i)=ep0(i)
16575 enddo
16576
16577
16578
16579 if(iab.eq.7.or.iab.eq.8)then !delta++(-)
16580 call qgdec2(ep,ep1,ep2,dmmin(2)**2,amn**2,am0**2)
16581 ich(nsh)=ic-5*ic/iab
16582 do i=1,4
16583 esp(i,nsh)=ep1(i)
16584 ep(i)=ep2(i)
16585 enddo
16586 nsh=nsh+1
16587 ich(nsh)=15*ic/iab-2*ic
16588
16589
16590
16591
16592
16593
16594
16595
16596
16597
16598
16599 elseif(iab.eq.11)then !pi* -> rho + pi
16600 am2=qgnrm(ep)
16601 call qgdec2(ep,ep1,ep2,am2,dmmin(1)**2,am0**2)
16602
16603 if(qgran(b10).lt..5d0)then !rho0 + pi+/-
16604 ich(nsh)=-10
16605 ich(nsh+1)=ic/iab
16606
16607
16608 do i=1,4
16609 esp(i,nsh)=ep1(i)
16610 ep(i)=ep2(i)
16611 enddo
16612 nsh=nsh+1
16613 else !rho+/- + pi0 -> pi+/- + 2 pi0
16614 call qgdec2(ep1,ep3,ep,dmmin(1)**2,am0**2,am0**2)
16615 ich(nsh)=0
16616 ich(nsh+1)=ic/iab
16617 ich(nsh+2)=0
16618 do i=1,4
16619 esp(i,nsh)=ep2(i)
16620 esp(i,nsh+1)=ep3(i)
16621 enddo
16622 nsh=nsh+2
16623 endif
16624
16625
16626
16627
16628
16629
16630 elseif(iab.eq.12.or.iab.eq.13)then !N*
16631 am2=qgnrm(ep)
16632 if(6.d0*qgran(b10).lt.1.d0)then !delta + pi
16633 call qgdec2(ep,ep1,ep2,am2,dmmin(2)**2,am0**2)
16634 call qgdec2(ep1,ep3,ep,dmmin(2)**2,amn**2,am0**2)
16635 ich(nsh)=2*ic-25*ic/iab
16636 ich(nsh+1)=ic-10*ic/iab
16637 ich(nsh+2)=-ich(nsh)
16638 do i=1,4
16639 esp(i,nsh)=ep2(i)
16640 esp(i,nsh+1)=ep3(i)
16641 enddo
16642 nsh=nsh+2
16643 else !N + pi
16644 call qgdec2(ep,ep1,ep2,am2,amn**2,am0**2)
16645 do i=1,4
16646 esp(i,nsh)=ep1(i)
16647 ep(i)=ep2(i)
16648 enddo
16649 if(qgran(b10).lt..4d0)then
16650 ich(nsh)=ic-10*ic/iab
16651 ich(nsh+1)=0
16652 else
16653 ich(nsh)=15*ic/iab-ic
16654 ich(nsh+1)=25*ic/iab-2*ic
16655 endif
16656 nsh=nsh+1
16657 endif
16658
16659 elseif(iab.eq.14.or.iab.eq.15)then !K1
16660 am2=qgnrm(ep)
16661 if(dsqrt(am2).gt.dmmin(1)+amk)then !rho + K
16662 call qgdec2(ep,ep1,ep2,am2,dmmin(1)**2,amk**2)
16663
16664 if(3.d0*qgran(b10).lt.1.d0)then !rho0
16665 ich(nsh)=ic-10*ic/iab
16666 ich(nsh+1)=-10
16667
16668
16669 do i=1,4
16670 esp(i,nsh)=ep2(i)
16671 ep(i)=ep1(i)
16672 enddo
16673 nsh=nsh+1
16674 else !rho+/-
16675 call qgdec2(ep1,ep3,ep,dmmin(1)**2,am0**2,am0**2)
16676 ich(nsh)=19*ic/iab-ic
16677 ich(nsh+1)=29*ic/iab-2*ic
16678 ich(nsh+2)=0
16679 do i=1,4
16680 esp(i,nsh)=ep2(i)
16681 esp(i,nsh+1)=ep3(i)
16682 enddo
16683 nsh=nsh+2
16684 endif
16685 else !K* + pi
16686 call qgdec2(ep,ep1,ep2,am2,dmmin(3)**2,am0**2)
16687 call qgdec2(ep1,ep3,ep,dmmin(3)**2,amk**2,am0**2)
16688 if(3.d0*qgran(b10).lt.1.d0)then
16689 ich(nsh)=0
16690 if(3.d0*qgran(b10).lt.1.d0)then
16691 ich(nsh+1)=ic-10*ic/iab
16692 ich(nsh+2)=0
16693 else
16694 ich(nsh+1)=19*ic/iab-ic
16695 ich(nsh+2)=29*ic/iab-2*ic
16696 endif
16697 else
16698 ich(nsh)=29*ic/iab-2*ic
16699 if(3.d0*qgran(b10).lt.1.d0)then
16700 ich(nsh+1)=19*ic/iab-ic
16701 ich(nsh+2)=0
16702 else
16703 ich(nsh+1)=ic-10*ic/iab
16704 ich(nsh+2)=2*ic-29*ic/iab
16705 endif
16706 endif
16707 do i=1,4
16708 esp(i,nsh)=ep2(i)
16709 esp(i,nsh+1)=ep3(i)
16710 enddo
16711 nsh=nsh+2
16712 endif
16713
16714
16715
16716
16717
16718
16719 elseif(iab.eq.5)then !K0,K0~
16720 ich(nsh)=10*int(.5d0+qgran(b10))-5
16721
16722
16723
16724
16725
16726
16727
16728
16729
16730
16731
16732
16733
16734 else
16735 ich(nsh)=ic
16736 endif
16737
16738 do i=1,4
16739 esp(i,nsh)=ep(i)
16740 enddo
16741
16742 do n=nstprev,nsh
16743 do i=1,4
16744 ep(i)=esp(i,n)
16745 enddo
16746 call qgtran(ep,ey0,1)
16747 do i=1,4
16748 esp(i,n)=ep(i)
16749 enddo
16750 enddo
16751
16752 if(debug.ge.4)write (moniou,202)
16753
16754 201 format(2x,'qgreg: ic=',i2,2x,'c.m. 4-momentum:',2x,4(e10.3,1x)/
16755 * 4x,'number of particles in the storage: ',i5)
16756 202 format(2x,'qgreg - end')
16757 return
16758 end
16759
16760
16761 subroutine qgdec2(ep,ep1,ep2,ww,a,b)
16762
16763 implicit double precision (a-h,o-z)
16764 integer debug
16765 dimension ep(4),ep1(4),ep2(4),ey(3)
16766 common /qgarr11/ b10
16767 common /qgarr43/ moniou
16768 common /qgdebug/ debug
16769 EXTERNAL qgran
16770
16771 if(debug.ge.2)write (moniou,201)ep,ww,a,b
16772 201 format(2x,'qgdec2: 4-momentum:',2x,4(e10.3,1x)
16773 */4x,'ww=',e10.3,2x,'a=',e10.3,2x,'b=',e10.3)
16774
16775 pl=qglam(ww,a,b)
16776 ep1(1)=dsqrt(pl+a)
16777 ep2(1)=dsqrt(pl+b)
16778 pl=dsqrt(pl)
16779 cosz=2.d0*qgran(b10)-1.d0
16780 pt=pl*dsqrt(1.d0-cosz**2)
16781 ep1(2)=pl*cosz
16782 call qgcs(c,s)
16783 ep1(3)=pt*c
16784 ep1(4)=pt*s
16785 do i=2,4
16786 ep2(i)=-ep1(i)
16787 enddo
16788 call qgdeft(ww,ep,ey)
16789 call qgtran(ep1,ey,1)
16790 call qgtran(ep2,ey,1)
16791 if(debug.ge.3)write (moniou,203)
16792 203 format(2x,'qgdec2 - end')
16793 return
16794 end
16795
16796
16797 double precision function qggrv(x,qqs,icq,iq)
16798
16799
16800
16801 implicit double precision (a-h,o-z)
16802 common /qgarr18/ alm,qt0,qtf,betp,dgqq
16803 common /qgarr25/ ahv(3)
16804
16805 qggrv=0.
16806 if(x.gt..99999d0.and.(qqs.ne.qt0.or.iq.ne.1.and.iq.ne.2))return
16807
16808 if(icq.eq.2)then
16809 sq=dlog(dlog(qqs/.232d0**2)/dlog(.23d0/.232d0**2))
16810 if(iq.eq.0)then !gluon
16811 alg=.524d0
16812 betg=1.088d0
16813 aag=1.742d0-.93d0*sq
16814 bbg=-.399d0*sq**2
16815 ag=7.486d0-2.185d0*sq
16816 bg=16.69d0-22.74d0*sq+5.779d0*sq*sq
16817 cg=-25.59d0+29.71d0*sq-7.296d0*sq*sq
16818 dg=2.792d0+2.215d0*sq+.422d0*sq*sq-.104d0*sq*sq*sq
16819 eg=.807d0+2.005d0*sq
16820 eeg=3.841d0+.361d0*sq
16821 qggrv=(1.d0-x)**dg*(x**aag*(ag+bg*x+cg*x**2)*log(1.d0/x)**bbg
16822 * +sq**alg*exp(-eg+sqrt(eeg*sq**betg*log(1.d0/x))))
16823 elseif(iq.eq.1.or.iq.eq.2)then !u_v or d_v
16824 aau=.59d0-.024d0*sq
16825 bbu=.131d0+.063d0*sq
16826 auu=2.284d0+.802d0*sq+.055d0*sq*sq
16827 au=-.449d0-.138d0*sq-.076d0*sq*sq
16828 bu=.213d0+2.669d0*sq-.728d0*sq*sq
16829 cu=8.854d0-9.135d0*sq+1.979d0*sq*sq
16830 du=2.997d0+.753d0*sq-.076d0*sq*sq
16831 uv=auu*x**aau*(1.d0+au*x**bbu+bu*x+cu*x**1.5d0)
16832 if(qqs.ne.qt0)uv=uv*(1.d0-x)**du
16833
16834 aad=.376d0
16835 bbd=.486d0+.062d0*sq
16836 add=.371d0+.083d0*sq+.039d0*sq*sq
16837 ad=-.509d0+3.31d0*sq-1.248d0*sq*sq
16838 bd=12.41d0-10.52d0*sq+2.267d0*sq*sq
16839 ccd=6.373d0-6.208d0*sq+1.418d0*sq*sq
16840 dd=3.691d0+.799d0*sq-.071d0*sq*sq
16841 dv=add*x**aad*(1.d0+ad*x**bbd+bd*x+ccd*x**1.5d0)
16842 if(qqs.ne.qt0)then
16843 dv=dv*(1.d0-x)**dd
16844 elseif(x.gt..99999d0)then
16845 dv=0.d0
16846 else
16847 dv=dv*(1.d0-x)**(dd-ahv(2))
16848 endif
16849 if(iq.eq.1)then !u_v
16850 qggrv=uv
16851 elseif(iq.eq.2)then !d_v
16852 qggrv=dv
16853 endif
16854
16855 elseif(iq.eq.-3)then !s_sea
16856 als=.914
16857 bets=.577
16858 aas=1.798-.596*sq
16859 as=-5.548+3.669*sqrt(sq)-.616*sq
16860 bs=18.92-16.73*sqrt(sq)+5.168*sq
16861 ds=6.379-.35*sq+.142*sq*sq
16862 es=3.981+1.638*sq
16863 ees=6.402
16864 qggrv=(1.-x)**ds*sq**als/log(1./x)**aas*(1.+as*sqrt(x)
16865 * +bs*x)*exp(-es+sqrt(ees*sq**bets*log(1./x)))
16866 elseif(iabs(iq).lt.3)then !u_sea or d_sea
16867 aadel=.409-.005*sq
16868 bbdel=.799+.071*sq
16869 addel=.082+.014*sq+.008*sq*sq
16870 adel=-38.07+36.13*sq-.656*sq*sq
16871 bdel=90.31-74.15*sq+7.645*sq*sq
16872 ccdel=0.
16873 ddel=7.486+1.217*sq-.159*sq*sq
16874 delv=addel*x**aadel*(1.-x)**ddel
16875 * *(1.+adel*x**bbdel+bdel*x+ccdel*x**1.5)
16876
16877 alud=1.451
16878 betud=.271
16879 aaud=.41-.232*sq
16880 bbud=.534-.457*sq
16881 aud=.89-.14*sq
16882 bud=-.981
16883 cud=.32+.683*sq
16884 dud=4.752+1.164*sq+.286*sq*sq
16885 eud=4.119+1.713*sq
16886 eeud=.682+2.978*sq
16887 udsea=(1.-x)**dud*(x**aaud*(aud+bud*x+cud*x**2)
16888 * *log(1./x)**bbud+sq**alud*exp(-eud+sqrt(eeud*sq**betud
16889 * *log(1./x))))
16890
16891 if(iq.eq.-1)then !u_sea
16892 qggrv=(udsea-delv)/2.
16893 elseif(iq.eq.-2)then !d_sea
16894 qggrv=(udsea+delv)/2.
16895 endif
16896 else
16897 qggrv=0.
16898 endif
16899
16900 elseif(icq.eq.1.or.icq.eq.3)then
16901 sq=dlog(dlog(qqs/.204d0**2)/dlog(.26d0/.204d0**2))
16902 if(iq.eq.1.or.iq.eq.2)then
16903 aapi=.517-.02*sq
16904 api=-.037-.578*sq
16905 bpi=.241+.251*sq
16906 dpi=.383+.624*sq
16907 anorm=1.212+.498*sq+.009*sq**2
16908 qggrv=.5*anorm*x**aapi*(1.+api*sqrt(x)+bpi*x)
16909 if(qqs.ne.qt0)qggrv=qggrv*(1.d0-x)**dpi
16910 elseif(iq.eq.0)then
16911 alfpi=.504
16912 betpi=.226
16913 aapi=2.251-1.339*sqrt(sq)
16914 api=2.668-1.265*sq+.156*sq**2
16915 bbpi=0.
16916 bpi=-1.839+.386*sq
16917 cpi=-1.014+.92*sq-.101*sq**2
16918 dpi=-.077+1.466*sq
16919 epi=1.245+1.833*sq
16920 eppi=.51+3.844*sq
16921 qggrv=(1.-x)**dpi*(x**aapi*(api+bpi*sqrt(x)+cpi*x)*
16922 * log(1./x)**bbpi+sq**alfpi*
16923 * exp(-epi+sqrt(eppi*sq**betpi*log(1./x))))
16924 elseif(iq.eq.-3)then
16925 alfpi=.823
16926 betpi=.65
16927 aapi=1.036-.709*sq
16928 api=-1.245+.713*sq
16929 bpi=5.58-1.281*sq
16930 dpi=2.746-.191*sq
16931 epi=5.101+1.294*sq
16932 eppi=4.854-.437*sq
16933 qggrv=sq**alfpi/log(1./x)**aapi*(1.-x)**dpi*
16934 * (1.+api*sqrt(x)+bpi*x)*
16935 * exp(-epi+sqrt(eppi*sq**betpi*log(1./x)))
16936 elseif(iabs(iq).lt.3)then
16937 alfpi=1.147
16938 betpi=1.241
16939 aapi=.309-.134*sqrt(sq)
16940 api=.219-.054*sq
16941 bbpi=.893-.264*sqrt(sq)
16942 bpi=-.593+.24*sq
16943 cpi=1.1-.452*sq
16944 dpi=3.526+.491*sq
16945 epi=4.521+1.583*sq
16946 eppi=3.102
16947 qggrv=(1.-x)**dpi*(x**aapi*(api+bpi*sqrt(x)+cpi*x)*
16948 * log(1./x)**bbpi+sq**alfpi*
16949 * exp(-epi+sqrt(eppi*sq**betpi*log(1./x))))
16950 else
16951 qggrv=0.
16952 endif
16953 else
16954 qggrv=0.
16955 endif
16956 return
16957 end
16958
16959
16960 double precision function qgev(q1,qj,qq,xx,j,l)
16961
16962
16963
16964 implicit double precision (a-h,o-z)
16965 common /qgarr18/ alm,qt0,qtf,betp,dgqq
16966 common /qgarr51/ epsxmn
16967 common /arr3/ x1(7),a1(7)
16968
16969 qgev=0.d0
16970 zmax=1.d0-epsxmn
16971 zmin=xx/zmax
16972 if(zmin.ge.zmax)return
16973
16974 if(qj.eq.qq)then
16975 do i1=1,7
16976 do m1=1,2
16977 qi=q1*(qq/q1)**(.5d0+x1(i1)*(m1-1.5d0))
16978
16979 fz1=0.d0
16980 fz2=0.d0
16981 fz3=0.d0
16982 zmin1=max(.2d0,zmin)
16983 zmax1=min(.2d0,zmax)
16984 zmax1=min(5.d0*xx,zmax1)
16985 zmax2=min(zmin1,zmax)
16986 zmin2=max(zmax1,zmin)
16987
16988 if(zmax1.gt.zmin)then
16989 do i=1,7
16990 do m=1,2
16991 z=xx+(zmin-xx)*((zmax1-xx)/(zmin-xx))**(.5d0+(m-1.5d0)*x1(i))
16992 do k=1,2
16993 if(j.ne.3.or.k.ne.1)then
16994 fz1=fz1+a1(i)*qgevi(q1,qi,xx/z,j,k)*qgfap(z,k,l)*(1.d0-xx/z)
16995 endif
16996 enddo
16997 enddo
16998 enddo
16999 fz1=fz1*dlog((zmax1-xx)/(zmin-xx))
17000 endif
17001 if(zmin1.lt.zmax)then
17002 do i=1,7
17003 do m=1,2
17004 z=1.d0-(1.d0-zmax)*((1.d0-zmin1)/(1.d0-zmax))
17005 * **(.5d0+x1(i)*(m-1.5d0))
17006 do k=1,2
17007 if(j.ne.3.or.k.ne.1)then
17008 fz2=fz2+a1(i)*qgevi(q1,qi,xx/z,j,k)*qgfap(z,k,l)
17009 * *(1.d0/z-1.d0)
17010 endif
17011 enddo
17012 enddo
17013 enddo
17014 fz2=fz2*dlog((1.d0-zmin1)/(1.d0-zmax))
17015 endif
17016 if(zmax2.gt.zmin2)then
17017 do i=1,7
17018 do m=1,2
17019 z=zmin2*(zmax2/zmin2)**(.5d0+x1(i)*(m-1.5d0))
17020 do k=1,2
17021 if(j.ne.3.or.k.ne.1)then
17022 fz3=fz3+a1(i)*qgevi(q1,qi,xx/z,j,k)*qgfap(z,k,l)
17023 endif
17024 enddo
17025 enddo
17026 enddo
17027 fz3=fz3*dlog(zmax2/zmin2)
17028 endif
17029 qgev=qgev+a1(i1)*(fz1+fz2+fz3)/qgsudx(qi,l)*qgalf(qi/alm)
17030 enddo
17031 enddo
17032 qgev=qgev*dlog(qq/q1)/4.d0*qgsudx(qq,l)
17033
17034 else
17035 fz1=0.d0
17036 fz2=0.d0
17037 fz3=0.d0
17038 zmin1=max(.2d0,zmin)
17039 zmax1=min(.2d0,zmax)
17040 zmax1=min(5.d0*xx,zmax1)
17041 zmax2=min(zmin1,zmax)
17042 zmin2=max(zmax1,zmin)
17043
17044 if(zmax1.gt.zmin)then
17045 do i=1,7
17046 do m=1,2
17047 z=xx+(zmin-xx)*((zmax1-xx)/(zmin-xx))**(.5d0+(m-1.5d0)*x1(i))
17048 do k=1,2
17049 if(j.ne.3)then
17050 fz1=fz1+a1(i)*qgevi(q1,qj,xx/z,j,k)*qgevi(qj,qq,z,k,l)
17051 * *(1.d0-xx/z)
17052 elseif(k.ne.1)then
17053 fz1=fz1+a1(i)*qgevi(q1,qj,xx/z,3,2)*qgevi(qj,qq,z,3,2)
17054 * *(1.d0-xx/z)
17055 endif
17056 enddo
17057 enddo
17058 enddo
17059 fz1=fz1*dlog((zmax1-xx)/(zmin-xx))
17060 endif
17061 if(zmin1.lt.zmax)then
17062 do i=1,7
17063 do m=1,2
17064 z=1.d0-(1.d0-zmax)*((1.d0-zmin1)/(1.d0-zmax))
17065 * **(.5d0+x1(i)*(m-1.5d0))
17066 do k=1,2
17067 if(j.ne.3)then
17068 fz2=fz2+a1(i)*qgevi(q1,qj,xx/z,j,k)*qgevi(qj,qq,z,k,l)
17069 * *(1.d0/z-1.d0)
17070 elseif(k.ne.1)then
17071 fz2=fz2+a1(i)*qgevi(q1,qj,xx/z,3,2)*qgevi(qj,qq,z,3,2)
17072 * *(1.d0/z-1.d0)
17073 endif
17074 enddo
17075 enddo
17076 enddo
17077 fz2=fz2*dlog((1.d0-zmin1)/(1.d0-zmax))
17078 endif
17079 if(zmax2.gt.zmin2)then
17080 do i=1,7
17081 do m=1,2
17082 z=zmin2*(zmax2/zmin2)**(.5d0+x1(i)*(m-1.5d0))
17083 do k=1,2
17084 if(j.ne.3)then
17085 fz2=fz2+a1(i)*qgevi(q1,qj,xx/z,j,k)*qgevi(qj,qq,z,k,l)
17086 elseif(k.ne.1)then
17087 fz2=fz2+a1(i)*qgevi(q1,qj,xx/z,3,2)*qgevi(qj,qq,z,3,2)
17088 endif
17089 enddo
17090 enddo
17091 enddo
17092 fz3=fz3*dlog(zmax2/zmin2)
17093 endif
17094 qgev=(fz1+fz2+fz3)/2.d0
17095 endif
17096 return
17097 end
17098
17099
17100 double precision function qgevi(q1,qq,xx,m,l)
17101
17102
17103
17104 implicit double precision (a-h,o-z)
17105 dimension wi(3),wj(3),wk(3)
17106 common /qgarr18/ alm,qt0,qtf,betp,dgqq
17107 common /qgarr20/ spmax
17108 common /qgarr51/ epsxmn
17109 common /qgarr52/ evk(40,40,100,3,2)
17110
17111 qgevi=0.d0
17112 if(q1.ge..9999d0*spmax)goto 1
17113
17114 if(xx.le..1d0)then
17115 yx=37.d0-dlog(.1d0/xx)/dlog(.1d0*spmax)*36.d0
17116 k=max(1,int(yx))
17117 k=min(k,35)
17118 elseif(xx.le..9d0)then
17119 yx=(xx-.1d0)*40.d0+37.d0
17120 k=max(37,int(yx))
17121 k=min(k,67)
17122 else
17123 yx=dlog(10.d0*(1.d0-xx))/log(10.d0*epsxmn)*31.d0+69.d0
17124 k=max(69,int(yx))
17125 k=min(k,98)
17126 endif
17127 wk(2)=yx-k
17128 wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
17129 wk(1)=1.d0-wk(2)+wk(3)
17130 wk(2)=wk(2)-2.d0*wk(3)
17131
17132 qli=log(q1)/dlog(spmax)*39.d0+1.d0
17133 qlj=log(qq/q1)/dlog(spmax/q1)*39.d0+1.d0
17134 i=max(1,int(1.0001d0*qli))
17135 i=min(i,38)
17136 wi(2)=qli-i
17137 wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
17138 wi(1)=1.d0-wi(2)+wi(3)
17139 wi(2)=wi(2)-2.d0*wi(3)
17140
17141 j=max(1,int(1.0001d0*qlj))
17142 j=min(j,38)
17143 wj(2)=qlj-j
17144 wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
17145 wj(1)=1.d0-wj(2)+wj(3)
17146 wj(2)=wj(2)-2.d0*wj(3)
17147
17148 do i1=1,3
17149 do j1=1,3
17150 do k1=1,3
17151 k2=k+k1-1
17152 qgevi=qgevi+evk(i+i1-1,j+j1-1,k2,m,l)*wi(i1)*wj(j1)*wk(k1)
17153 enddo
17154 enddo
17155 enddo
17156 1 qgevi=exp(qgevi)*qgfap(xx,m,l)
17157 if(m.eq.1.and.l.eq.1.or.m.ne.1.and.l.ne.1)then
17158 qgevi=qgevi/4.5d0/qgsudx(q1,m)*qgsudx(qq,m)
17159 * *dlog(dlog(qq/alm)/dlog(q1/alm))
17160 else
17161 qgevi=qgevi*.3d0/(dlog(epsxmn)+.75d0)
17162 * *(qgsudx(qq,1)/qgsudx(q1,1)-qgsudx(qq,2)/qgsudx(q1,2))
17163 endif
17164 return
17165 end
17166
17167
17168 double precision function qgpdf(xx,qq,icz,jj)
17169
17170
17171
17172
17173
17174
17175
17176 implicit double precision (a-h,o-z)
17177 common /qgarr6/ pi,bm,amws
17178 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
17179 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
17180 common /qgarr18/ alm,qt0,qtf,betp,dgqq
17181 common /qgarr25/ ahv(3)
17182 common /qgarr51/ epsxmn
17183 common /arr3/ x1(7),a1(7)
17184
17185 if(jj.eq.0)then
17186 qgpdf=qggpdf(xx,icz)
17187 elseif(jj.eq.1.or.jj.eq.2)then
17188 qgpdf=qggrv(xx,qt0,icz,jj)*(1.d0-xx)**ahv(icz)
17189 else
17190 qgpdf=qgspdf(xx,icz)
17191 endif
17192 qgpdf=qgpdf*qgsudx(qq,iabs(jj)+1)/qgsudx(qt0,iabs(jj)+1)
17193
17194 xmin=xx/(1.d0-epsxmn)
17195 if(xmin.lt.1.d0.and.qq.gt.qt0)then
17196 dpd1=0.d0
17197 dpd2=0.d0
17198 xm=max(xmin,.3d0)
17199 do i=1,7 !numerical integration over zx
17200 do m=1,2
17201 zx=1.d0-(1.d0-xm)*(.5d0+(m-1.5d0)*x1(i))**.25d0
17202 z=xx/zx
17203
17204 gl=qggpdf(zx,icz)
17205 uv=qggrv(zx,qt0,icz,1)*(1.d0-zx)**ahv(icz)
17206 dv=qggrv(zx,qt0,icz,2)*(1.d0-zx)**ahv(icz)
17207 sea=qgspdf(zx,icz)
17208 if(jj.eq.0)then
17209 fz=qgevi(qt0,qq,z,1,1)*gl+qgevi(qt0,qq,z,2,1)*(uv+dv+sea)
17210 elseif(jj.eq.1)then
17211 fz=qgevi(qt0,qq,z,3,2)*uv
17212 elseif(jj.eq.2)then
17213 fz=qgevi(qt0,qq,z,3,2)*dv
17214 else
17215 akns=qgevi(qt0,qq,z,3,2) !nonsinglet contribution
17216 aks=(qgevi(qt0,qq,z,2,2)-akns) !singlet contribution
17217 fz=(qgevi(qt0,qq,z,1,2)*gl+aks*(uv+dv+sea)+akns*sea)
17218 endif
17219 dpd1=dpd1+a1(i)*fz/zx**2/(1.d0-zx)**3
17220 enddo
17221 enddo
17222 dpd1=dpd1*(1.d0-xm)**4/8.d0*xx
17223
17224 if(xm.gt.xmin)then
17225 do i=1,7 !numerical integration
17226 do m=1,2
17227 zx=xx+(xm-xx)*((xmin-xx)/(xm-xx))**(.5d0-(m-1.5d0)*x1(i))
17228 z=xx/zx
17229
17230 gl=qggpdf(zx,icz)
17231 uv=qggrv(zx,qt0,icz,1)*(1.d0-zx)**ahv(icz)
17232 dv=qggrv(zx,qt0,icz,2)*(1.d0-zx)**ahv(icz)
17233 sea=qgspdf(zx,icz)
17234 if(jj.eq.0)then
17235 fz=qgevi(qt0,qq,z,1,1)*gl+qgevi(qt0,qq,z,2,1)*(uv+dv+sea)
17236 elseif(jj.eq.1)then
17237 fz=qgevi(qt0,qq,z,3,2)*uv
17238 elseif(jj.eq.2)then
17239 fz=qgevi(qt0,qq,z,3,2)*dv
17240 else
17241 akns=qgevi(qt0,qq,z,3,2) !nonsinglet contribution
17242 aks=(qgevi(qt0,qq,z,2,2)-akns) !singlet contribution
17243 fz=(qgevi(qt0,qq,z,1,2)*gl+aks*(uv+dv+sea)+akns*sea)
17244 endif
17245 dpd2=dpd2+a1(i)*fz*(1.d0-xx/zx)/zx
17246 enddo
17247 enddo
17248 dpd2=dpd2*dlog((xm-xx)/(xmin-xx))*.5d0*xx
17249 endif
17250 qgpdf=qgpdf+dpd2+dpd1
17251 endif
17252 return
17253 end
17254
17255
17256 double precision function qgpdfd(xx,xpomr,qq,icz)
17257
17258
17259
17260
17261
17262
17263
17264 implicit double precision (a-h,o-z)
17265 common /qgarr6/ pi,bm,amws
17266 common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
17267 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
17268 common /qgarr18/ alm,qt0,qtf,betp,dgqq
17269 common /qgarr25/ ahv(3)
17270 common /qgarr51/ epsxmn
17271 common /arr3/ x1(7),a1(7)
17272
17273 qgpdfd=(qgdpdf(xx,xpomr,icz,1)+qgdpdf(xx,xpomr,icz,2))
17274 **qgsudx(qq,2)/qgsudx(qt0,2)
17275 xmin=xx/(1.d0-epsxmn)
17276 if(xmin.lt.xpomr.and.qq.gt.qt0)then
17277 dpd1=0.d0
17278 dpd2=0.d0
17279 xm=max(xmin,.3d0)
17280 if(xm.lt.xpomr)then
17281 do i=1,7 !numerical integration over zx
17282 do m=1,2
17283 zx=1.d0-(1.d0-xm)*(1.d0-(.5d0+(m-1.5d0)*x1(i))
17284 * *(1.d0-((1.d0-xpomr)/(1.d0-xm))**4))**.25d0
17285 z=xx/zx
17286
17287 glu=(qgdgdf(zx,xpomr,icz,1)+qgdgdf(zx,xpomr,icz,2))/4.5d0
17288 sea=qgdpdf(zx,xpomr,icz,1)+qgdpdf(zx,xpomr,icz,2)
17289 fz=qgevi(qt0,qq,z,1,2)*glu+qgevi(qt0,qq,z,2,2)*sea
17290 dpd1=dpd1+a1(i)*fz/zx**2/(1.d0-zx)**3
17291 enddo
17292 enddo
17293 dpd1=dpd1*((1.d0-xm)**4-(1.d0-xpomr)**4)/8.d0*xx
17294 endif
17295
17296 xm=min(xm,xpomr)
17297 if(xm.gt.xmin)then
17298 do i=1,7 !numerical integration
17299 do m=1,2
17300 zx=xx+(xm-xx)*((xmin-xx)/(xm-xx))**(.5d0-(m-1.5d0)*x1(i))
17301 z=xx/zx
17302
17303 glu=(qgdgdf(zx,xpomr,icz,1)+qgdgdf(zx,xpomr,icz,2))/4.5d0
17304 sea=qgdpdf(zx,xpomr,icz,1)+qgdpdf(zx,xpomr,icz,2)
17305 fz=qgevi(qt0,qq,z,1,2)*glu+qgevi(qt0,qq,z,2,2)*sea
17306 dpd2=dpd2+a1(i)*fz*(1.d0-xx/zx)/zx
17307 enddo
17308 enddo
17309 dpd2=dpd2*dlog((xm-xx)/(xmin-xx))*.5d0*xx
17310 endif
17311 qgpdfd=qgpdfd+dpd2+dpd1
17312 endif
17313 return
17314 end
17315
17316
17317 double precision function qgf2c(xx,qq,icz)
17318
17319
17320
17321
17322
17323
17324 implicit double precision (a-h,o-z)
17325 common /arr3/ x1(7),a1(7)
17326
17327 qgf2c=0.d0
17328 qcmass=1.3d0
17329 s2min=4.*qcmass**2+qq
17330 xmin=s2min*xx/qq
17331
17332 if(xmin.lt.1.d0)then
17333 do i=1,7 !numerical integration over z1
17334 do m=1,2
17335 z1=xmin**(.5d0+x1(i)*(m-1.5d0))
17336 sdc=qgdbor(qq,xx/z1,qcmass**2)
17337 glu=qgpdf(z1,s2min-qq,icz,0)
17338 qgf2c=qgf2c+a1(i)*sdc*glu
17339 enddo
17340 enddo
17341 qgf2c=-qgf2c*dlog(xmin)*.5d0
17342 endif
17343 return
17344 end
17345
17346
17347 double precision function qgf2cd(xx,xpomr,qq,icz)
17348
17349
17350
17351
17352
17353
17354 implicit double precision (a-h,o-z)
17355 common /arr3/ x1(7),a1(7)
17356
17357 qgf2cd=0.d0
17358 qcmass=1.3d0
17359 s2min=4.*qcmass**2+qq
17360 xmin=s2min*xx/qq
17361
17362 if(xmin.lt.xpomr)then
17363 do i=1,7 !numerical integration over z1
17364 do m=1,2
17365 z1=xpomr*(xmin/xpomr)**(.5d0+x1(i)*(m-1.5d0))
17366 sdc=qgdbor(qq,xx/z1,qcmass**2)
17367 glu=qgdgdf(z1,xpomr,icz,1)+qgdgdf(z1,xpomr,icz,2)
17368 qgf2cd=qgf2cd+a1(i)*sdc*glu
17369 enddo
17370 enddo
17371 qgf2cd=qgf2cd*dlog(xpomr/xmin)*.5d0
17372 endif
17373 return
17374 end
17375
17376
17377 double precision function qgdbor(qq,zz,q2mass)
17378
17379
17380
17381
17382
17383 implicit double precision (a-h,o-z)
17384 common /qgarr18/ alm,qt0,qtf,betp,dgqq
17385
17386 qgdbor=0.
17387 qtq=4.d0*q2mass*zz/qq/(1.d0-zz)
17388 if(qtq.ge.1.d0)return
17389 bet=dsqrt(1.d0-qtq)
17390
17391 qgdbor=qgalf(4.d0*q2mass/alm)/2.25d0*zz
17392 **(dlog((1.d0+bet)/(1.d0-bet))*(1.d0-2.d0*zz*(1.d0-zz)
17393 *-8.d0*(zz*q2mass/qq)**2+4.d0*zz*(1.d0-3.d0*zz)*q2mass/qq)
17394 *+bet*(-1.d0-4.d0*zz*(1.d0-zz)*q2mass/qq+8.d0*zz*(1.d0-zz)))
17395 return
17396 end
17397
17398
17399 double precision function qgjeto(qi,qj,s,iq1,iq2)
17400
17401
17402
17403
17404
17405
17406 implicit double precision (a-h,o-z)
17407 integer debug
17408 common /qgarr6/ pi,bm,amws
17409 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
17410 common /qgarr18/ alm,qt0,qtf,betp,dgqq
17411 common /qgarr26/ factk,fqscal
17412 common /qgarr43/ moniou
17413 common /qgarr51/ epsxmn
17414 common /qgdebug/ debug
17415 common /arr3/ x1(7),a1(7)
17416
17417 if(debug.ge.2)write (moniou,201)qi,qj,s,iq1,iq2
17418
17419 qgjeto=0.d0
17420 qq=max(qi,qj)
17421
17422 zmin=qq*fqscal*4.d0/s
17423 zmax=1.d0-epsxmn
17424 if(zmin.ge.zmax)return
17425
17426 dpx1=0.d0
17427 zmin1=min(.2d0,1.d0-zmin)
17428 do i1=1,7
17429 do m1=1,2
17430 z=1.d0-epsxmn*(zmin1/epsxmn)**(.5d0+x1(i1)*(m1-1.5d0))
17431
17432 si=z*s
17433 fb=qgjeti(qi,qj,si,z,1.d0,iq1,iq2,1)
17434 dpx1=dpx1+a1(i1)*fb*(1.d0-z)
17435 enddo
17436 enddo
17437 dpx1=dpx1*dlog(zmin1/epsxmn)
17438
17439 dpx2=0.d0
17440 if(zmin.lt..8d0)then
17441 zmin1=zmin**(-delh)
17442 zmax1=.8d0**(-delh)
17443 do i1=1,7
17444 do m1=1,2
17445 z=(.5d0*(zmax1+zmin1+(zmax1-zmin1)*x1(i1)*(2*m1-3)))
17446 * **(-1.d0/delh)
17447
17448 si=z*s
17449 fb=qgjeti(qi,qj,si,z,1.d0,iq1,iq2,1)
17450 dpx2=dpx2+a1(i1)*fb*z**(1.d0+delh)
17451 enddo
17452 enddo
17453 dpx2=dpx2*(zmin1-zmax1)/delh
17454 endif
17455 qgjeto=(dpx1+dpx2)/qgsudx(qj,iabs(iq2)+1)*pi**3
17456
17457 if(debug.ge.3)write (moniou,202)qgjeto
17458 201 format(2x,'qgjeto: qi=',e10.3,2x,'qj=',e10.3,2x,
17459 *'s= ',e10.3,2x,'iq1= ',i1,2x,'iq2= ',i1)
17460 202 format(2x,'qgjeto=',e10.3)
17461 return
17462 end
17463
17464
17465 double precision function qgjett(qi,qj,s,iq1,iq2)
17466
17467
17468
17469
17470
17471
17472 implicit double precision (a-h,o-z)
17473 integer debug
17474 common /qgarr6/ pi,bm,amws
17475 common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
17476 common /qgarr18/ alm,qt0,qtf,betp,dgqq
17477 common /qgarr26/ factk,fqscal
17478 common /qgarr43/ moniou
17479 common /qgarr51/ epsxmn
17480 common /qgdebug/ debug
17481 common /arr3/ x1(7),a1(7)
17482
17483 if(debug.ge.2)write (moniou,201)qi,qj,s,iq1,iq2
17484
17485 qgjett=0.d0
17486 qq=max(qi,qj)
17487
17488 zmin=qq*fqscal*4.d0/s
17489 zmax=(1.d0-epsxmn)**2
17490 if(zmin.ge.zmax)return
17491 zmin1=zmin**(-delh)
17492 zmax1=zmax**(-delh)
17493 do i1=1,7
17494 do m1=1,2
17495 z=(.5d0*(zmax1+zmin1+(zmax1-zmin1)*x1(i1)*(2*m1-3)))
17496 * **(-1.d0/delh)
17497
17498 si=z*s
17499 fb1=0.d0
17500 zmin2=min(.2d0,1.d0-dsqrt(z))
17501 do i2=1,7
17502 do m2=1,2
17503 z1=1.d0-epsxmn*(zmin2/epsxmn)**(.5d0+x1(i2)*(m2-1.5d0))
17504 z2=z/z1
17505
17506 fb1=fb1+a1(i2)*(qgjeti(qi,qj,si,z1,z2,iq1,iq2,2)
17507 * +qgjeti(qi,qj,si,z2,z1,iq1,iq2,2))*(1.d0/z1-1.d0)
17508 enddo
17509 enddo
17510 fb1=fb1*dlog(zmin2/epsxmn)
17511
17512 fb2=0.d0
17513 if(z.lt..64d0)then
17514 do i2=1,7
17515 do m2=1,2
17516 z1=.8d0*(dsqrt(z)/.8d0)**(.5d0+x1(i2)*(m2-1.5d0))
17517 z2=z/z1
17518
17519 fb2=fb2+a1(i2)*(qgjeti(qi,qj,si,z1,z2,iq1,iq2,2)
17520 * +qgjeti(qi,qj,si,z2,z1,iq1,iq2,2))
17521 enddo
17522 enddo
17523 fb2=fb2*dlog(.64d0/z)/2.d0
17524 endif
17525
17526 qgjett=qgjett+a1(i1)*(fb1+fb2)*z**(1.d0+delh)
17527 enddo
17528 enddo
17529 qgjett=qgjett*(zmin1-zmax1)/delh*pi**3/2.d0
17530
17531 if(debug.ge.3)write (moniou,202)qgjett
17532 201 format(2x,'qgjett: qi=',e10.3,2x,'qj=',e10.3,2x,
17533 *'s= ',e10.3,2x,'iq1= ',i1,2x,'iq2= ',i1)
17534 202 format(2x,'qgjett=',e10.3)
17535 return
17536 end
17537
17538
17539 double precision function qgjeti(qi,qj,si,z1,z2,iq1,iq2,jj)
17540 implicit double precision (a-h,o-z)
17541 integer debug
17542 common /qgarr18/ alm,qt0,qtf,betp,dgqq
17543 common /qgarr26/ factk,fqscal
17544 common /qgarr43/ moniou
17545 common /qgarr51/ epsxmn
17546 common /qgdebug/ debug
17547 common /arr3/ x1(7),a1(7)
17548
17549 qgjeti=0.d0
17550 qq=max(qi,qj)
17551 tmin=qq*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qq*fqscal/si)))
17552 if(tmin.ge.si/2.d0)return
17553 do i=1,7
17554 do m=1,2
17555 t=2.d0*tmin/(1.d0+2.d0*tmin/si
17556 * -x1(i)*(2*m-3)*(1.d0-2.d0*tmin/si))
17557 qt=t*(1.d0-t/si)
17558
17559 fb=0.d0
17560 if(jj.eq.1)then
17561 do iql=1,2
17562 iq=2*iql-2
17563 dfb=0.d0
17564 do n=1,3
17565 dfb=dfb+qgfbor(si,t,iq,iq2,n)+qgfbor(si,si-t,iq,iq2,n)
17566 enddo
17567 if(iq.eq.iq2)dfb=dfb/2.d0
17568 fb=fb+dfb*qgevi(qi,qt/fqscal,z1,iabs(iq1)+1,iql)
17569 enddo
17570 fb=fb*qgsudx(qt/fqscal,iabs(iq2)+1)
17571 else
17572 do iql=1,2
17573 iq=2*iql-2
17574 do iqr=1,2
17575 dfb=0.d0
17576 do n=1,3
17577 dfb=dfb+qgfbor(si,t,iq,iqr-1,n)+qgfbor(si,si-t,iq,iqr-1,n)
17578 enddo
17579 if(iq.eq.iqr-1)dfb=dfb/2.d0
17580 fb=fb+dfb*qgevi(qi,qt/fqscal,z1,iabs(iq1)+1,iql)
17581 * *qgevi(qj,qt/fqscal,z2,iabs(iq2)+1,iqr)
17582 enddo
17583 enddo
17584 endif
17585
17586 qgjeti=qgjeti+a1(i)*fb*qgalf(qt/fqscal/alm)**2*t**2
17587 enddo
17588 enddo
17589 qgjeti=qgjeti*(1.d0/tmin-2.d0/si)/si**2
17590 return
17591 end
17592
17593
17594 double precision function qgptj(s,pt,y0,sigin)
17595 implicit double precision (a-h,o-z)
17596 integer debug
17597 common /qgarr6/ pi,bm,amws
17598 common /qgarr18/ alm,qt0,qtf,betp,dgqq
17599 common /qgarr26/ factk,fqscal
17600 common /qgarr43/ moniou
17601 common /qgarr51/ epsxmn
17602 common /qgdebug/ debug
17603 common /arr3/ x1(7),a1(7)
17604
17605 qgptj=0.d0
17606 zmin=4.d0*pt**2/s
17607 xt=2.d0*pt*exp(y0)/dsqrt(s)
17608 zmax=min(1.d0,xt**2/(2.d0*xt-zmin))
17609 if(zmax.le.zmin)return
17610
17611 qq=pt**2/fqscal
17612 do i1=1,7
17613 do m1=1,2
17614 z=zmax*(zmin/zmax)**(.5d0+x1(i1)*(m1-1.5d0))
17615 si=z*s
17616 t=2.d0*pt**2/(1.d0+dsqrt(max(0.d0,1.d0-zmin/z)))
17617
17618 xmax=min(1.d0,xt/(1.d0+dsqrt(max(0.d0,1.d0-zmin/z))))
17619 xmin=max(z,xmax*exp(-2.d0*y0))
17620 do i2=1,7
17621 do m2=1,2
17622 xp=xmax*(xmin/xmax)**(.5d0+x1(i2)*(m2-1.5d0))
17623 xm=z/xp
17624
17625 glu1=qgpdf(xp,qq,2,0)
17626 glu2=qgpdf(xm,qq,2,0)
17627 seav2=qgpdf(xm,qq,2,-1)+qgpdf(xm,qq,2,1)+qgpdf(xm,qq,2,2)
17628
17629 qgptj=qgptj+a1(i1)*a1(i2)*(qgptjb(si,pt**2,t,1)*glu1*glu2
17630 * +qgptjb(si,pt**2,t,2)*glu1*seav2)
17631 * *dlog(xmax/xmin)/(1.d0-2.d0*t/si)
17632 enddo
17633 enddo
17634 enddo
17635 enddo
17636 qgptj=qgptj*dlog(zmax/zmin)*pi**3*.39d0/sigin *2. !2 jets
17637 return
17638 end
17639
17640
17641 double precision function qgptjb(si,qt,t,jj)
17642 implicit double precision (a-h,o-z)
17643 integer debug
17644 common /qgarr18/ alm,qt0,qtf,betp,dgqq
17645 common /qgarr26/ factk,fqscal
17646 common /qgarr43/ moniou
17647 common /qgdebug/ debug
17648
17649 if(jj.eq.1)then
17650 qgptjb=qgfbor(si,t,0,0,1)
17651 else !if(jj.eq.2)then
17652 qgptjb=qgfbor(si,t,0,1,1)
17653 endif
17654 qgptjb=qgptjb*qgalf(qt/fqscal/alm)**2/si**2
17655 return
17656 end