265 lines
6.1 KiB
Fortran
265 lines
6.1 KiB
Fortran
|
|
c***********************************************************************
|
|
SUBROUTINE DSTRIP(IQ,DR,K,F1,F2,FR,QNUM,OPT,KM,SL,C)
|
|
c
|
|
c Calculates two nucleon transfer form factor via the
|
|
c Bayman and Kallio method.
|
|
c***********************************************************************
|
|
c
|
|
c IQ Input quantum numbers for form factor
|
|
c DR Step size
|
|
c K Number of steps
|
|
c F1 First orbital
|
|
c F2 Second orbital
|
|
c FR Output form factor
|
|
c QNUM Quantum numbers for orbitals
|
|
c OPT
|
|
c
|
|
implicit real*8(a-h,o-z)
|
|
parameter (maxg=10, maxr=12)
|
|
DIMENSION F1(400),F2(400),FR(800),QNUM(4,2),TVCC(10),IQ(3)
|
|
1 ,D1(10),D2(10),C(32),AG(maxg),WG(maxg),BG(maxg)
|
|
2 ,AR(maxr),WR(maxr)
|
|
C
|
|
DATA KR,KX/0,0/
|
|
data ag,wg,bg,ar,wr/maxg*0.,maxg*0.,maxg*0.,maxr*0.,maxr*0./
|
|
C
|
|
c c1 = R1 scale
|
|
c c2 = R2 scale
|
|
c c3 = r1 scale
|
|
c c4 = r2 scale
|
|
c c5 = r0, integration scale
|
|
c c6 = Pauli flag
|
|
c c7 = order of integration
|
|
c c8 = number of integration points
|
|
c
|
|
IPAULI=C(6)
|
|
R0 =C(5)
|
|
L =IQ(1)
|
|
IS=IQ(2)
|
|
JJ=IQ(3)
|
|
N1=QNUM(1,1)
|
|
N2=QNUM(1,2)
|
|
L1=QNUM(2,1)
|
|
L2=QNUM(2,2)
|
|
J1=QNUM(3,1)
|
|
J2=QNUM(3,2)
|
|
IS1=QNUM(4,1)
|
|
IS2=QNUM(4,2)
|
|
c3=c(3)
|
|
c4=c(4)
|
|
dr1=dr*c(1)
|
|
dr2=dr*c(2)
|
|
ITEMP=N1+N1+N2+N2
|
|
NX=(((ITEMP+L1+L2+L+2)/4+2)+1+2)/2+2*IPAULI
|
|
if(c(8).eq.0.0) then
|
|
NR=(((ITEMP+L1+L2-L+3)/4+8)+1+2)/2+2*IPAULI
|
|
NR=MIN0(NR,maxr)
|
|
IF(NR.NE.KR) then
|
|
CUT=0.0
|
|
IERR=0
|
|
ALFA=C(7)
|
|
CALL GAUSSR(NR,KS,ALFA,AR,WR,IERR,CUT)
|
|
NR=KS
|
|
kr=nr
|
|
endif
|
|
else
|
|
nr = c(8)
|
|
do 45 i=1,nr
|
|
ar(i)=c(i+8)
|
|
wr(i)=c(i+nr+8)
|
|
if(wr(i).ne.0.0) kr=i
|
|
45 continue
|
|
nr=kr
|
|
endif
|
|
NX=MIN0(NX,maxg)
|
|
WRITE(6,9000)NR,NX
|
|
9000 FORMAT(15H0 NO. R STEPS =,I3,18H NO. X STEPS =,I3)
|
|
IF(NX.NE.KX) then
|
|
CALL LEGAUS(2*NX,AG,WG)
|
|
KX=NX
|
|
do 47 i=1,nx
|
|
BG(i) = sqrt(1.0-ag(i)**2)
|
|
47 continue
|
|
endif
|
|
LL=L+L
|
|
LL1=L1+L1
|
|
LL2=L2+L2
|
|
FACT1=YXFCT(L1,LL1)/2.0**L1
|
|
FACT2=YXFCT(L2,LL2)/2.0**L2
|
|
FNORM=OPT*SQRT(FLOAT((LL1+1)*(LL2+1))/FLOAT(LL+1))
|
|
IF(IPAULI.NE.0) GO TO 60
|
|
TEMP=2.0
|
|
DO 50 I=1,4
|
|
IF(QNUM(I,1).NE.QNUM(I,2)) GO TO 55
|
|
50 CONTINUE
|
|
TEMP=4.0
|
|
55 CONTINUE
|
|
FNORM=FNORM/SQRT(TEMP)
|
|
60 CONTINUE
|
|
FNORM=FNORM*SQRT(FLOAT((LL+1)*(IS+1)*(J1+1)*(J2+1)))
|
|
1 *WINEJ(LL1,IS1,J1,LL2,IS2,J2,LL,IS,JJ)
|
|
FM1=1.0
|
|
FM2=1.0
|
|
FL1=L1
|
|
FL2=L2
|
|
LPL=MIN0(L1,L2)+1
|
|
DO 80 M=1,LPL
|
|
M2=M+M-2
|
|
FM=M-1
|
|
TVCC(M)=VCC(LL1,LL2,LL,M2,-M2)*2.0/SQRT(FM1*FM2)
|
|
FM1=FM1*(FL1+FM+1)*(FL1-FM)
|
|
FM2=FM2*(FL2+FM+1)*(FL2-FM)
|
|
80 CONTINUE
|
|
TVCC(1)=TVCC(1)/2.0
|
|
C
|
|
C RS=r
|
|
C
|
|
C R1=| C1*R+C3*r |
|
|
C R2=| C2*R+C4*r |
|
|
C
|
|
C
|
|
C CENTER OF MASS R LOOP
|
|
C
|
|
R=0.0
|
|
S=0.0
|
|
DO 500 M=1,K
|
|
R=R+DR1
|
|
S=S+DR2
|
|
RSQ=R**2
|
|
SSQ=S**2
|
|
SUMR=0.0
|
|
C
|
|
C RELATIVE R LOOP
|
|
C
|
|
DO 400 MR=1,KR
|
|
RS=AR(MR)*R0
|
|
SS=RS*C3
|
|
RS=RS*C4
|
|
RSSQ=RS**2+RSQ
|
|
RPROD=2.0*R*RS
|
|
SSSQ=SS**2+SSQ
|
|
SPROD=2.0*S*SS
|
|
C
|
|
C RELATIVE R ANGLE LOOP
|
|
C
|
|
SUMX=0.0
|
|
DO 300 MX=1,KX
|
|
X =AG(MX)
|
|
y =BG(mx)
|
|
IX=0
|
|
110 CONTINUE
|
|
R1=SQRT(RSSQ+RPROD*X)
|
|
R2=SQRT(SSSQ+SPROD*X)
|
|
FK1=R1/DR
|
|
K1=FK1
|
|
K1=MAX0(K1,2)
|
|
FK1=FK1-FLOAT(K1)
|
|
IF(K1.GT.K) GO TO 300
|
|
FK2=R2/DR
|
|
K2=FK2
|
|
K2=MAX0(K2,2)
|
|
FK2=FK2-FLOAT(K2)
|
|
IF(K2.GT.K) GO TO 300
|
|
COS1=(R+RS*X)/R1
|
|
COS2=(S+SS*X)/R2
|
|
SIN1=abs(rs*y/r1)
|
|
SIN2=abs(ss*y/r2)
|
|
120 CONTINUE
|
|
DM1=0.0
|
|
DL1=FACT1
|
|
IF(L1.EQ.0) GO TO 141
|
|
DO 140 LI=1,L1
|
|
DL1=DL1*SIN1
|
|
140 CONTINUE
|
|
141 CONTINUE
|
|
D1(L1+1)=DL1
|
|
DM2=0.0
|
|
DL2=FACT2
|
|
IF(L2.EQ.0) GO TO 151
|
|
DO 150 LI=1,L2
|
|
DL2=DL2*SIN2
|
|
150 CONTINUE
|
|
151 CONTINUE
|
|
D2(L2+1)=DL2
|
|
IF(L1.EQ.0) GO TO 171
|
|
FJ1=1.0
|
|
FL1=LL1
|
|
FM1=LL1
|
|
DO 170 LI=1,L1
|
|
DK1=(FM1*COS1*DL1/SIN1-DM1)/(FJ1*FL1)
|
|
FJ1=FJ1+1.0
|
|
FL1=FL1-1.0
|
|
FM1=FM1-2.0
|
|
DM1=DL1
|
|
DL1=DK1
|
|
INDX=L1+1-LI
|
|
D1(INDX)=DL1
|
|
170 CONTINUE
|
|
171 CONTINUE
|
|
IF(L2.EQ.0) GO TO 181
|
|
FJ2=1.0
|
|
FL2=LL2
|
|
FM2=LL2
|
|
DO 180 LI=1,L2
|
|
DK2=(FM2*COS2*DL2/SIN2-DM2)/(FJ2*FL2)
|
|
FJ2=FJ2+1.0
|
|
FL2=FL2-1.0
|
|
FM2=FM2-2.0
|
|
DM2=DL2
|
|
DL2=DK2
|
|
INDX=L2+1-LI
|
|
D2(INDX)=DL2
|
|
180 CONTINUE
|
|
181 CONTINUE
|
|
PROD=0.0
|
|
DO 185 LI=1,LPL
|
|
PROD=PROD+D1(LI)*D2(LI)*TVCC(LI)
|
|
185 CONTINUE
|
|
280 CONTINUE
|
|
C INTERPOLATE - 4 POINT FORMULA
|
|
FT1=-FK1*(FK1-1.)*(FK1-2.)*F1(K1-1)/6.
|
|
1 + (FK1**2-1.)*(FK1-2.)*F1(K1 )/2.
|
|
2 - FK1*(FK1+1.)*(FK1-2.)*F1(K1+1)/2.
|
|
3 + FK1*(FK1**2-1.)*F1(K1+2)/6.
|
|
FT2=-FK2*(FK2-1.)*(FK2-2.)*F2(K2-1)/6.
|
|
1 + (FK2**2-1.)*(FK2-2.)*F2(K2 )/2.
|
|
2 - FK2*(FK2+1.)*(FK2-2.)*F2(K2+1)/2.
|
|
3 + FK2*(FK2**2-1.)*F2(K2+2)/6.
|
|
C INTERPOLATE - 2 POINT FORMULA
|
|
C FT1=FK1*(F1(K1+1)-F1(K1))+F1(K1)
|
|
C FT2=FK2*(F2(K2+1)-F2(K2))+F2(K2)
|
|
c if(m.eq.21) write(20,'(2i4,1p10e12.4)')mr,mx,x,r1,r2,r1**2+r2**2
|
|
c 1 ,ft1,ft2,ft1*ft2
|
|
SUMX=SUMX+WG(MX)*PROD*FT1*FT2
|
|
IF(IX.NE.0) GO TO 300
|
|
IX=1
|
|
IF(IPAULI.EQ.0) then
|
|
ITEMP=K1
|
|
K1=K2
|
|
K2=ITEMP
|
|
ATEMP=FK1
|
|
FK1=FK2
|
|
FK2=ATEMP
|
|
ATEMP=COS1
|
|
COS1=COS2
|
|
COS2=ATEMP
|
|
ATEMP=SIN1
|
|
SIN1=SIN2
|
|
SIN2=ATEMP
|
|
IF(L1.EQ.L2) GO TO 280
|
|
GO TO 120
|
|
endif
|
|
X=-X
|
|
GO TO 110
|
|
300 CONTINUE
|
|
SUMR=SUMR+WR(MR)*SUMX
|
|
400 CONTINUE
|
|
SUMR=SUMR*FNORM
|
|
FR(2*M-1)=FR(2*M-1)+SUMR
|
|
IF(M.EQ.KM) SL=SUMR
|
|
500 CONTINUE
|
|
1000 CONTINUE
|
|
RETURN
|
|
END
|