Subroutine tnoff (jj1,jj2,kappap,kappa,ekap0,kp,k,cthnuc) c *** see RH Landau, Program lpott, 1981 c Subroutine tnoff(k*,k,k0) calculates the off-shell pi-n amplitude c in pi-n c.m. from on shell ampltd-calc with tpicm c tlpt(kp,k,ko) = tcl(lt) *g*gp/go2/2/pi/pi...n.b.2pi2 c this sub also folds the t*s (all energies at once) and re-stor c c nifty(4)= 0 sig=1, constant off-shell with on shell valus c 1 nlsp form off shell c 6 local laplacian form ,genrlzed to d $ f waves c nifty(8)= 0, no Fermi folding c =1, Fermi smear(folding) input t matrices c c negative ke can be handled,but only for nlsp case Implicit Real*8(a-h,i,k,m,o-z) Integer ix Complex*16 zi,zsig(14),nsig(14),ddinv Dimension nifty(20), bnuc(20), bnucf(20), bn(16), bnf(16), retij 1(14), imtij(14), rt(14), it(14), gin(14,100), g(14), kapg(100), 2 denom(14,25), ecmden(25), sigl(14) Common /sec2/ bnuc,bn,bnucf,bnf,retij,imtij,hbarc,pi,mpi,mn,nz,nes 1,nwaves,nifty,na Common /nlspfl/ gin,kapg,denom,ecmden,fmn,rew(14,100),aimw(14,100) 1,akapd(100),nkapgs,necms Common /enpaul/ pf,ak,akd,cskkd,xi,e,xon Common /enqav/ xip Common /twob/ t2body(17,17,2,14) c data sigl/2*1.,3*-1.,1.,-1.,1.,5*-1.,1./,ix/0/ If (ix.ne.0) GoTo 10 c intialize ix = 1 mnpi = mn+mpi mnpi2 = mnpi**2 mnpi10 = mnpi+10. mnmpi2 = (mn-mpi)**2 twopi2 = 2.*pi*pi hbarth = 197.33 pf = 150./hbarth xi = mn/mnpi zi = (0.,1.) kappa0 = 1.e-06 10 Continue If (ekap0.lt.mnpi10) GoTo 30 s = ekap0*ekap0 If (s.ne.0.) kappa0 = Sqrt((s-mnpi2)*(s-mnmpi2)/4./s) 20 Call tncm (kappa0) GoTo 70 c negative ke case,set zsig=denom**-1 30 If (nifty(4).gt.1) GoTo 50 If (nifty(4).eq.0) GoTo 60 Call lagrng (ekap0,ecmden,g,denom,necms,14,2,25,14) Do 40 n=1,14 zsig(n) = 0. c set d&f or maybe p waves =0 If((nifty(7).eq.2.or.nifty(7).eq.5).and.n.gt.6)g(n)=0. If(nifty(7).eq.1.and.(n.ne.1.and.n.ne.4))g(n)=0. c no imag part for denom If subthreshold c t(lpt convention)=t(coronis-Landau)/twopi2 If (g(n).ne.0.) zsig(n) = sigl(n)/g(n)/twopi2 40 Continue GoTo 110 50 Write (6,330) ekap0 STOP c special g=const case,for e lt 0 set kappa0=epsilon 60 kappa0 = 0.000001 GoTo 20 c t=g(k)*g(kp)/denom=ton*g(k)*g(kp)/g(ko)**2 70 Do 80 n=1,14 zsig(n) = retij(n)+zi*imtij(n) rt(n) = retij(n) it(n) = imtij(n) 80 Continue c Write out for Pauli c Write(6,991)(rt(n),it(n),n=1,6) c 991 format(" before Pauli,rt,it=",20x,6e15.6) c 992 format(" after Pauli and off-shell factor,rt,it=",6e15.6) c .end of Pauli Write out n = nifty(4)+1 GoTo (170,90,50,50,50,50,190,50,50,50), n c nlsp form c ton*2*pi*pi/g(ko)**2=1/denom 90 Call lagrng (kappa0,kapg,g,gin,nkapgs,14,2,100,14) Do 100 n=1,14 If (g(n).ne.0.) zsig(n) = zsig(n)/(g(n)**2) If (g(n).eq.0.) zsig(n) = (0.,0.) 100 Continue 110 Continue If(nifty(9) .eq.0) GoTo 140 c include Pauli via thomas's procedure c zsig=1/denom,where t=g*g'/denom c now denom =denom+ddinv ak = k/hbarth akd = kp/hbarth cskkd = cthnuc e = (ekap0-mnpi)/hbarth xon = -.000001 If (e.le.0.) GoTo 120 c use thomas's procedure for consistancy in integral pts e = (kappa0**2/2./938.91+Sqrt(137.3**2+kappa0**2)-137.3)/hbarth 120 If (e.gt.0.) xon = kappa0/hbarth Do 130 n=1,14 If (n.gt.6) GoTo 130 c nb change to rhlcode from thomas s crazycode nch = n Call Pauli (ddinv,nch) If (abs(zsig(n)).ne.0.) zsig(n) = 1/zsig(n)/twopi2 If ((kappap.eq.kappa).and.(abs(kappa-kappa0).le.1.e-4)) Write 1 (6,340) nch,k,ddinv,zsig(n) zsig(n) = zsig(n)+ddinv If (abs(zsig(n)).ne.0.) zsig(n) = 1/zsig(n)/twopi2 130 Continue c mult by g(kp) 140 Call lagrng (kappap,kapg,g,gin,nkapgs,14,2,100,14) c save g(p) needed for p11 pole removal If (abs(fmn).ge.1.e-04) tp11 = g(5) Do 150 n=1,14 zsig(n) = zsig(n)*g(n) 150 Continue c mult by g(k) Call lagrng (kappa,kapg,g,gin,nkapgs,14,2,100,14) c construct tp11 for pole removal If (abs(fmn).ge.1.e-04) tp11 = tp11*g(5) Do 160 n=1,14 zsig(n) = zsig(n)*g(n) 160 Continue If ((ekap0.lt.mnpi10).or.(abs(fmn).lt.1.e-04)) GoTo 170 c remove residue of p11 pole If above threshold tp11 = tp11*sigl(5)/(ekap0-mn)/fmn/twopi2 zsig(5) = zsig(5)-tp11 c temp print out c Write (6,350) ekap0,kappap,zsig(5),tp11 170 Continue c constant off shell case,or determine re and im parts of t Do 180 n=1,14 rt(n) = zsig(n) it(n) = -zi*zsig(n) retij(n) = rt(n) imtij(n) = it(n) 180 Continue c store off-shell two_body t matrix Do n = 1,14 t2body(jj1,jj2,1,n) = rt(n) t2body(jj1,jj2,2,n) = it(n) EndDo c form partial wave decom from channels 190 Continue Call mixup (bn,bnf,rt,it,nifty(1)) Do 200 j=1,16 If (bn(2).eq.0.) GoTo 210 If (abs(bn(j)/bn(2)).le.1.e-5) bn(j) = 0. If (abs(bnf(j)/bn(2)).le.1.e-5) bnf(j) = 0. 200 Continue 210 If (nifty(4).eq.6) GoTo 220 Return c ------local laplacian type form for both neutron and protone ditr 220 a = kappap**2+kappa**2 b = -2.*kappap*kappa a0 = 2.*kappa0**2 a2 = a*a b2 = b*b a02 = a0*a0 rhl = b/a0 rhl2 = rhl*rhl rhl3 = rhl2*rhl c s zsig(5) = bn(1)+zi*bn(2) nsig(5) = bn(3)+zi*bn(4) c p zsig(2) = bn(5)+zi*bn(6) nsig(2) = bn(7)+zi*bn(8) c d zsig(3) = bn(9)+zi*bn(10) nsig(3) = bn(11)+zi*bn(12) c f zsig(4) = bn(13)+zi*bn(14) nsig(4) = bn(15)+zi*bn(16) c swave off shell If ((bn(1).eq.0.).and.(bn(2).eq.0.)) GoTo 230 zsig(1) = 1.+(zsig(2)/zsig(5))*(a0-a)/a0+(1.5/a02)*(zsig(3)/zsig(5 1))*(a2+b2/3.+2.*a02/3.-2.*a*a0)-2.5*(zsig(4)/zsig(5)/a0/a02)*(a2*a 2+a*b2-.4*a02*a0+2.4*a02*a-3.*a0*a2-a0*b2) zsig(5) = zsig(5)*zsig(1) bn(1) = zsig(5) bn(2) = -zi*zsig(5) 230 If ((bn(3).eq.0.).and.(bn(4).eq.0.)) GoTo 240 nsig(1) = 1.+(nsig(2)/nsig(5))*(a0-a)/a0+(1.5/a02)*(nsig(3)/nsig(5 1))*(a2+b2/3.+2.*a02/3.-2.*a*a0)-2.5*(nsig(4)/nsig(5)/a0/a02)*(a2*a 2+a*b2-.4*a02*a0+2.4*a02*a-3.*a0*a2-a0*b2) nsig(5) = nsig(5)*nsig(1) bn(3) = nsig(5) bn(4) = -zi*nsig(5) c pwave 240 If ((bn(5).eq.0.).and.(bn(6).eq.0.)) GoTo 250 zsig(1) = -rhl*(1.+(zsig(4)/zsig(2)/2./a02)*(15.*a2+3.*b2+12.*a02- 130.*a*a0)+3.*(zsig(3)/zsig(2)/a0)*(a0-a)) zsig(2) = zsig(2)*zsig(1) bn(5) = zsig(2) bn(6) = -zi*zsig(2) c d wave 250 If ((bn(7).eq.0.).and.(bn(8).eq.0.)) GoTo 260 nsig(1) = -rhl*(1.+(nsig(4)/nsig(2)/2./a02)*(15.*a2+3.*b2+12.*a02- 130.*a*a0)+3.*(nsig(3)/nsig(2)/a0)*(a0-a)) nsig(2) = nsig(2)*nsig(1) bn(7) = nsig(2) bn(8) = -zi*nsig(2) 260 If ((bn(9).eq.0.).and.(bn(10).eq.0.)) GoTo 270 zsig(1) = rhl2*(1.+5.*(zsig(4)/zsig(3))*(1.-a/a0)) zsig(3) = zsig(1)*zsig(3) bn(9) = zsig(3) bn(10) = -zi*zsig(3) 270 If ((bn(11).eq.0.).and.(bn(12).eq.0.)) GoTo 280 nsig(1) = rhl2*(1.+5.*(nsig(4)/nsig(3))*(1.-a/a0)) nsig(3) = nsig(1)*nsig(3) bn(11) = nsig(3) bn(12) = -zi*nsig(3) c f wave 280 bn(13) = -rhl3*bn(13) bn(14) = -rhl3*bn(14) bn(15) = -rhl3*bn(15) bn(16) = -rhl3*bn(16) If (nifty(6).ne.3) GoTo 320 c flip parts off shell with laplacian c use different relatns than nonflip, since using pl primes c pwave Do 290 j=5,8 bnf(j) = bnf(j)+3.*bnf(j+4)+6.*bnf(j+8)-(3.*a/a0)*(bnf(j+4)+5.* 1 bnf(j+8))+((15.*a2+3.*b2)/2./a02)*bnf(j+8) 290 Continue c dwave Do 300 j=9,12 bnf(j) = (a*b*5./a02)*bnf(j+4)-(b/a0)*(bnf(j)+5.*bnf(j+4))+(b2/ 1 a02)*bnf(j+4) 300 Continue c f wave Do 310 j=13,16 bnf(j) = (b2/a02)*bnf(j) 310 Continue 320 Return c 330 format (43h //////////tnoff called for neg ke,non-nlsp,/7h ekap0=, 1e14.3) 340 format (28h Pauli supp for nch,k=kp=k0=,i2,f10.3,12h ddinv,dinv=, 12e15.3) 350 format (32h p11 pole removal,e,kp,k,z,tp11=,6e14.3) End