c subroutine PotFcn(isXbon, cl, npts, ze, P, Zk, Wm, Wmst, &Wm0, Wm0st, Mbare, f0, Uborn, zUborn, Urop, zUrop, Func) c Func is a pot func for a specific channel and intermediate baryon c for born and x-born diagrams c*********************************************************************** c implicit none c LOCAL variables integer first, nch, npts1 integer ich, jch, ipt, jpt, ichpt, jchpt, ib, cl double precision pi, zero, one, two, norm c SHARED variables integer Nifty, npts, isXbon double precision P(64), Uborn(64), Wm(64), Wmst(64), Urop(64) double precision Cplv, Cplct, Cplcs, A(2,2,6,2), f0, Mbare(3) double complex ze, Zk(2), Wm0(2), Wm0st(2) double complex zUborn(2), zUrop(2), Func(128,128,6) parameter (zero=0.0d0, one=1.0d0, two=2.0d0) parameter (pi=3.14159265358979323846d0) common /control/ Nifty(15) common /couple/ Cplv(3,3),Cplct(2,2,2),Cplcs(2,2,2) data first /1/ c*************************** c norm = one/(48.0d0*pi) nch = Nifty(2) npts1 = npts+1 c ??? initialize Func c do jch = 1, 128 c do ich = 1, 128 c Func(ich,jch,cl) = 0.0d0 c enddo c enddo if (isXbon .eq. 0) then if (cl .eq. 3) then ib = 1 else if (cl .eq. 6) then ib = 2 endif do 101 jch = 1, nch do 102 ich = 1, nch do jpt = 1, npts jchpt = jpt + (jch-1)*npts1 do ipt = 1, jpt ichpt = ipt + (ich-1)*npts1 Func(ichpt,jchpt,cl) = Func(ichpt,jchpt,cl) & +norm*Cplv(ich,ib)*Cplv(jch,ib)*Uborn(ipt)*Uborn(jpt) & *P(ipt)*P(jpt)/(f0*f0*Wmst(ipt)*Wmst(jpt) & *(ze-Mbare(ib))) enddo ichpt = ich*npts1 Func(ichpt,jchpt,cl) = Func(ichpt,jchpt,cl) & +norm*Cplv(ich,ib)*Cplv(jch,ib)*zUborn(ich)*Uborn(jpt) & *Zk(ich)*P(jpt)/(f0*f0*Wm0st(ich)*Wmst(jpt) & *(ze-Mbare(ib))) enddo c jchpt = jch*npts1 do ipt = 1, npts ichpt = ipt + (ich-1)*npts1 Func(ichpt,jchpt,cl) = Func(ichpt,jchpt,cl) & +norm*Cplv(ich,ib)*Cplv(jch,ib)*Uborn(ipt)*zUborn(jch) & *P(ipt)*Zk(jch)/(f0*f0*Wmst(ipt)*Wm0st(jch) & *(ze-Mbare(ib))) enddo ichpt = ich*npts1 jchpt = jch*npts1 Func(ichpt,jchpt,cl) = Func(ichpt,jchpt,cl) & +norm*Cplv(ich,ib)*Cplv(jch,ib)*zUborn(ich)*zUborn(jch) & *Zk(ich)*Zk(jch)/(f0*f0*Wm0st(ich)*Wm0st(jch) & *(ze-Mbare(ib))) 102 continue 101 continue c if (Nifty(1).ne.0 .and. cl.eq.3) then c including Roper contribution to P11 through direct Born ib = 3 do 201 jch = 1, nch do 202 ich = 1, nch do jpt = 1, npts jchpt = jpt + (jch-1)*npts1 do ipt = 1, jpt ichpt = ipt + (ich-1)*npts1 Func(ichpt,jchpt,cl) = Func(ichpt,jchpt,cl) & +norm*Cplv(ich,ib)*Cplv(jch,ib)*Urop(ipt)*Urop(jpt) & *P(ipt)*P(jpt)/(f0*f0*Wmst(ipt)*Wmst(jpt) & *(ze-Mbare(ib))) enddo ichpt = ich*npts1 Func(ichpt,jchpt,cl) = Func(ichpt,jchpt,cl) & +norm*Cplv(ich,ib)*Cplv(jch,ib)*zUrop(ich)*Urop(jpt) & *Zk(ich)*P(jpt)/(f0*f0*Wm0st(ich)*Wmst(jpt) & *(ze-Mbare(ib))) enddo c jchpt = jch*npts1 do ipt = 1, npts ichpt = ipt + (ich-1)*npts1 Func(ichpt,jchpt,cl) = Func(ichpt,jchpt,cl) & +norm*Cplv(ich,ib)*Cplv(jch,ib)*Urop(ipt)*zUrop(jch) & *P(ipt)*Zk(jch)/(f0*f0*Wmst(ipt)*Wm0st(jch) & *(ze-Mbare(ib))) enddo ichpt = ich*npts1 jchpt = jch*npts1 Func(ichpt,jchpt,cl) = Func(ichpt,jchpt,cl) & +norm*Cplv(ich,ib)*Cplv(jch,ib)*zUrop(ich)*zUrop(jch) & *Zk(ich)*Zk(jch)/(f0*f0*Wm0st(ich)*Wm0st(jch) & *(ze-Mbare(ib))) 202 continue 201 continue endif c************* else c compute spin-isospin coefficient just one time if (first .eq. 1) then c P11: cl = 3 call SpIso(0.5d0, 0.5d0, 3, A) c P31: cl = 4 call SpIso(1.5d0, 0.5d0, 4, A) c P13: cl = 5 call SpIso(0.5d0, 1.5d0, 5, A) c P33: cl = 6 call SpIso(1.5d0, 1.5d0, 6, A) first = 0 endif c c sum over intermediate baryon, notice the order change of Cplv's index do ib = 1, 2 do 103 jch = 1, nch do 104 ich = 1, nch do jpt = 1, npts jchpt = jpt + (jch-1)*npts1 do ipt = 1, jpt ichpt = ipt + (ich-1)*npts1 Func(ichpt,jchpt,cl) = Func(ichpt,jchpt,cl) & + A(ich,jch,cl,ib)*norm*Cplv(ib,ich)*Cplv(ib,jch) & * Uborn(ipt)*Uborn(jpt)*P(ipt)*P(jpt) &/(Wmst(ipt)*Wmst(jpt)*f0*f0*(ze-Mbare(ib)-Wm(ipt)-Wm(jpt))) enddo ichpt = ich*npts1 Func(ichpt,jchpt,cl) = Func(ichpt,jchpt,cl) & + A(ich,jch,cl,ib)*norm*Cplv(ib,ich)*Cplv(ib,jch) & * zUborn(ich)*Uborn(jpt)*Zk(ich)*P(jpt) &/(Wm0st(ich)*Wmst(jpt)*f0*f0*(ze-Mbare(ib)-Wm0(ich)-Wm(jpt))) enddo c jchpt = jch*npts1 do ipt = 1, npts ichpt = ipt + (ich-1)*npts1 Func(ichpt,jchpt,cl) = Func(ichpt,jchpt,cl) & + A(ich,jch,cl,ib)*norm*Cplv(ib,ich)*Cplv(ib,jch) & * Uborn(ipt)*zUborn(jch)*P(ipt)*Zk(jch) &/(Wmst(ipt)*Wm0st(jch)*f0*f0*(ze-Mbare(ib)-Wm(ipt)-Wm0(jch))) enddo ichpt = ich*npts1 jchpt = jch*npts1 Func(ichpt,jchpt,cl) = Func(ichpt,jchpt,cl) & + A(ich,jch,cl,ib)*norm*Cplv(ib,ich)*Cplv(ib,jch) & * zUborn(ich)*zUborn(jch)*Zk(ich)*Zk(jch) &/(Wm0st(ich)*Wm0st(jch)*f0*f0*(ze-Mbare(ib)-Wm0(ich)-Wm0(jch))) 104 continue 103 continue enddo c enddo ib if (Nifty(1).eq.2) then c including roper contribution from x-born which TRIUMF ignored c except the diff mass and ff, Roper has the same spin-isospin c factor and cpling const as nucleon ib = 3 do 203 jch = 1, nch do 204 ich = 1, nch do jpt = 1, npts jchpt = jpt + (jch-1)*npts1 do ipt = 1, jpt ichpt = ipt + (ich-1)*npts1 Func(ichpt,jchpt,cl) = Func(ichpt,jchpt,cl) & + A(ich,jch,cl,1)*norm*Cplv(ib,ich)*Cplv(ib,jch) & * Urop(ipt)*Urop(jpt)*P(ipt)*P(jpt) &/(Wmst(ipt)*Wmst(jpt)*f0*f0*(ze-Mbare(ib)-Wm(ipt)-Wm(jpt))) enddo ichpt = ich*npts1 Func(ichpt,jchpt,cl) = Func(ichpt,jchpt,cl) & + A(ich,jch,cl,1)*norm*Cplv(ib,ich)*Cplv(ib,jch) & * zUrop(ich)*Urop(jpt)*Zk(ich)*P(jpt) &/(Wm0st(ich)*Wmst(jpt)*f0*f0*(ze-Mbare(ib)-Wm0(ich)-Wm(jpt))) enddo c jchpt = jch*npts1 do ipt = 1, npts ichpt = ipt + (ich-1)*npts1 Func(ichpt,jchpt,cl) = Func(ichpt,jchpt,cl) & + A(ich,jch,cl,1)*norm*Cplv(ib,ich)*Cplv(ib,jch) & * Urop(ipt)*zUrop(jch)*P(ipt)*Zk(jch) &/(Wmst(ipt)*Wm0st(jch)*f0*f0*(ze-Mbare(ib)-Wm(ipt)-Wm0(jch))) enddo ichpt = ich*npts1 jchpt = jch*npts1 Func(ichpt,jchpt,cl) = Func(ichpt,jchpt,cl) & + A(ich,jch,cl,1)*norm*Cplv(ib,ich)*Cplv(ib,jch) & * zUrop(ich)*zUrop(jch)*Zk(ich)*Zk(jch) &/(Wm0st(ich)*Wm0st(jch)*f0*f0*(ze-Mbare(ib)-Wm0(ich)-Wm0(jch))) 204 continue 203 continue endif c end if roper endif c end if x-born return end subroutine SpIso(I, J, cl, A) c return spin isospin matrix A(ich,jch,cl,ib) for x-born diag c actualy I,J and cl has 1->1 relation, so argv I,J is not necessary. integer cl double precision I, J, A(2,2,6,2), sign, two, sqrt5 double precision F11, F12, Fx1, Fx2, F22 parameter (two=2.0d0, sqrt5=2.2360679775d0) F11(I) = (0.5+I)/3.0 F12(I) = (0.5+I)*(two*(3.5+I)*(1.5-I)-(I-0.5)**2)/12.0 Fx1(I) = sqrt((3.5+I)*(2.5-I))/3.0 Fx2(I) = sqrt((3.5+I)*(2.5-I))* & ((4.5+I)*(1.5-I)-two*(I+0.5)*(I-0.5)) F22(I) = (0.5+I)*((I-0.5d0)**2-two*(4.5+I)*(2.5-I))/30.0 if (cl.eq.4 .or. cl.eq.5) then sign = -1.0d0 else sign = 1.0d0 endif A(1,1,cl,1) = sign* F11(I) * F11(J) A(1,1,cl,2) = sign* F12(I) * F12(J) A(1,2,cl,1) = sign* Fx1(I) * Fx1(J) A(1,2,cl,2) = sign* Fx2(I) * Fx2(J)/360.0 A(2,1,cl,1) = A(1,2,cl,1) A(2,1,cl,2) = A(1,2,cl,2) A(2,2,cl,1) = sign* F11(I) * F11(J) A(2,2,cl,2) = sign* F22(I) * F22(J) return end