added DWUCK4 source code, no UI implemented for it
This commit is contained in:
Ryan@Home
parent
c49095aa95
commit
67cd8a1b09
1
.gitignore
vendored
1
.gitignore
vendored
|
|
@ -10,3 +10,4 @@ __pycache__
|
|||
IAEA_NuclearData.csv
|
||||
|
||||
*.txt
|
||||
*.o
|
||||
|
|
|
|||
1075
dwuck4/ADWCK4.FOR
Normal file
1075
dwuck4/ADWCK4.FOR
Normal file
File diff suppressed because it is too large
Load Diff
564
dwuck4/BDWCK4.FOR
Normal file
564
dwuck4/BDWCK4.FOR
Normal file
|
|
@ -0,0 +1,564 @@
|
|||
c***********************************************************************
|
||||
SUBROUTINE BDWUCK4
|
||||
c
|
||||
c Control program for second part of DWUCK4 which integrates the
|
||||
c distorted waves, calculates radial integrals, inelastic
|
||||
c amplitudes and the crossections.
|
||||
c
|
||||
c***********************************************************************
|
||||
c
|
||||
parameter(ispc0 = 4010, ispc1 = 8000, ispc2 = 8000)
|
||||
IMPLICIT REAL*8(A-H,O-Z)
|
||||
logical i_sym(2)
|
||||
COMMON ALPHA(15),IDAT(6),ICON(20),ANGLE(5),HBARC,AMU,AMASS,CHSQ,AA
|
||||
1,DRF,Z(3),ZA(3),FM(3),FMA(3),RC(3),AC(3),PNLOC(3),FS(3),ECM(3)
|
||||
2,FK(3),FK2(3),ETA(3),DR(3),FMU(3),FN,FL,FJ2,FSS,VCE,FNRNG,RSIG(2)
|
||||
3,K,KZ,LPLUS,LPL2,IS(3),NS(3),NLTR,LTRT(8),JTRT(8),ISTRT(8),IBF(8)
|
||||
4,KC,IBUFF,IWORD,ILINE,JLINE
|
||||
Common/array0/space0(ispc0)
|
||||
Common/array1/space1(ispc1)
|
||||
Common/array2/space2(ispc2)
|
||||
|
||||
DIMENSION D(8000),sigplt(200,2),plm(2000), dtemp(2000), F(800)
|
||||
1, FLL(8000), UB(800), FF(10)
|
||||
Equivalence (space1( 1), D), (space2( 1), FLL)
|
||||
1, (space0( 1), F), (space0( 1), plm(1))
|
||||
2, (space0(1601), sigplt(1,1)), (space0(3201), UB)
|
||||
3, (space0(4001), FF) ,(space1(1001), dtemp)
|
||||
DATA FOURPI/12.5663706/
|
||||
c
|
||||
do 40 i=1,2
|
||||
c
|
||||
if(fm(i).eq.fma(i).and.z(i).eq.za(i)) then
|
||||
i_sym(i)=.true.
|
||||
else
|
||||
i_sym(i)=.false.
|
||||
endif
|
||||
40 continue
|
||||
C
|
||||
IBUF=IBF(1)
|
||||
write(*,'(a)')' Subroutine INTEG entered'
|
||||
CALL INTEG4(i_sym)
|
||||
C
|
||||
C PRINT OUT ELASTIC CROSS-SECTIONS
|
||||
C
|
||||
IF(ICON(6).ne.0.or.ICON(16).ne.0) then
|
||||
WRITE(6,9999)ALPHA,(IDAT(I),I=1,3)
|
||||
WRITE(6,9904)
|
||||
C
|
||||
CALL ELSIG(dtemp,d,plm,sigplt,angle,fk,eta,rsig,alpha
|
||||
1 ,idat,is,icon,lplus,i_sym)
|
||||
C
|
||||
else
|
||||
WRITE(6,9002)(RSIG(N),N=1,2)
|
||||
endif
|
||||
IF(ICON(12).NE.0) then
|
||||
c
|
||||
c print out radial wave functions
|
||||
c
|
||||
c skip over form factors
|
||||
DO 72 M=1,NLTR
|
||||
READ(4)
|
||||
72 CONTINUE
|
||||
WRITE(6,9999)ALPHA,(IDAT(I),I=1,3)
|
||||
C
|
||||
CALL TAPED
|
||||
C
|
||||
endif
|
||||
c
|
||||
RZ=FLOAT(KZ)*DRF
|
||||
RMAX=FLOAT(K)*DRF
|
||||
JR=NS(1)
|
||||
JS=NS(2)
|
||||
DO 101 II=1,NLTR
|
||||
LTR=LTRT(II)
|
||||
MPLUS=LTR+1
|
||||
C
|
||||
C SPACE TO PROPER FORM FACTOR FOR THIS L-TRANSFER
|
||||
C
|
||||
DO 70 IJ=1,NLTR
|
||||
IF(IJ.EQ.II) then
|
||||
READ (4)UB,FF
|
||||
else
|
||||
READ (4)
|
||||
endif
|
||||
70 continue
|
||||
C
|
||||
write(*,'(a)')' Subroutine RADINT entered'
|
||||
CALL RADINT(F, FLL, UB, FF, LTR)
|
||||
C
|
||||
IF(ICON(7).ne.0) then
|
||||
C
|
||||
C WRITE( RADIAL MATRIX ELEMENTS IF ICON(7).NE.0
|
||||
C
|
||||
INCR=LPL2*LTR
|
||||
INC=1
|
||||
IS1=-IS(1)
|
||||
|
||||
DO 100 I=1,JR
|
||||
IS2=-IS(2)
|
||||
DO 98 J=1,JS
|
||||
WRITE(6,9999)ALPHA,(IDAT(M),M=1,3)
|
||||
WRITE(6,9900)IS1,IS2
|
||||
WRITE(6,9901)
|
||||
DO 90 LL=1,LPLUS
|
||||
LM=LL-1
|
||||
IND=INC+INCR
|
||||
WRITE(6,9902)LM,(FLL(IT),FLL(IT+1),IT=INC,IND,LPL2)
|
||||
INC=INC+2
|
||||
90 CONTINUE
|
||||
INC=INC+INCR
|
||||
IS2=IS2+2
|
||||
98 CONTINUE
|
||||
IS1=IS1+2
|
||||
100 CONTINUE
|
||||
endif
|
||||
101 CONTINUE
|
||||
END FILE 2
|
||||
REWIND 2
|
||||
C
|
||||
C RESTORE SPIN STORAGE
|
||||
C
|
||||
IS(1)=IBF(7)
|
||||
FS(1)=FLOAT(IBF(7))/2.0
|
||||
NS(1)=IBF(7)+1
|
||||
JR=NS(1)
|
||||
IS(2)=IBF(8)
|
||||
FS(2)=FLOAT(IBF(8))/2.0
|
||||
NS(2)=IBF(8)+1
|
||||
JS=NS(2)
|
||||
DO 300 II=1,NLTR
|
||||
LTR=LTRT(II)
|
||||
JTR=JTRT(II)
|
||||
IS(3)=ISTRT(II)
|
||||
C
|
||||
C CALCULATE NORMALIZATION FACTOR
|
||||
C
|
||||
c fact normalizes the cross section
|
||||
c flfact normalizes the amplitudes
|
||||
c
|
||||
flfact=1.0
|
||||
C
|
||||
c Photo-capture
|
||||
if (fm(2).eq.0.0.and.is(2).eq.2) then
|
||||
c (p,gamma) reaction normalization
|
||||
fact= 2.0*fmu(1)*amu/(hbarc*fk(1))**2
|
||||
1 *chsq/fk(2)**2
|
||||
flfact=sqrt(float(2*ltr+1))
|
||||
c
|
||||
c Photo-disintegration
|
||||
elseif(fm(1).eq.0.0.and.is(1).eq.2) then
|
||||
c (gamma,p) reaction normalization
|
||||
fact= 2.0*fmu(2)*amu/(hbarc*fk(2))**2
|
||||
1 *chsq/fk(1)**2
|
||||
else
|
||||
FACT= 2.0*FMU(1)/(HBARC*FK(1))**2
|
||||
1 *2.0*FMU(2)/(HBARC*FK(2))**2
|
||||
2 *AMU**2/FOURPI
|
||||
if(abs(fm(1)-fm(2)).GT.0.1) then
|
||||
C Stripping normalization factors
|
||||
flfact=100.0*SQRT(FLOAT(2*LTR+1)/FLOAT(JTR+1))
|
||||
fact=fact*float(jtr+1)
|
||||
endif
|
||||
endif
|
||||
c
|
||||
FACT=FACT*FK(2)/FK(1)
|
||||
FN=(II-1)*ICON(3)*(ICON(3)-1)
|
||||
C
|
||||
CALL BETAFN(FLL, D, LTR,JTR,flfact,i_sym)
|
||||
C
|
||||
MPLUS=JTR/2+1
|
||||
IF(icon(3).le.1.or.(icon(3).eq.2.and.II.eq.NLTR)) then
|
||||
IF(ICON(8).ne.0) then
|
||||
C
|
||||
C WRITE BETA TABLES IF ICON(8).NE.0
|
||||
C
|
||||
I1=MPLUS+MPLUS
|
||||
IFACT=I1 *NS(1)*NS(2)
|
||||
KT=1
|
||||
IS1=-IS(1)
|
||||
DO 120 I=1,JR
|
||||
IS2=-IS(2)
|
||||
DO 116 J=1,JS
|
||||
WRITE(6,9999)ALPHA,(IDAT(M),M=1,3)
|
||||
WRITE(6,9905)IS2,IS1
|
||||
WRITE(6,9903)
|
||||
DO 114 LL=1,LPLUS
|
||||
LM=LL-1
|
||||
IND=KT+LM*IFACT
|
||||
INDF=IND+I1-1
|
||||
WRITE(6,9902)LM,(D(INDEX),INDEX=IND,INDF)
|
||||
114 CONTINUE
|
||||
KT=KT+I1
|
||||
IS2=IS2+2
|
||||
116 CONTINUE
|
||||
IS1=IS1+2
|
||||
120 CONTINUE
|
||||
endif
|
||||
C
|
||||
C SET HEADINGS FOR INELASTIC SIGMA
|
||||
C
|
||||
WRITE(6,9999)ALPHA,(IDAT(I),I=1,3)
|
||||
WRITE(6,9507)DRF,RZ,RMAX,VCE,FS(1)
|
||||
WRITE(6,9508)FNRNG,PNLOC,FS(2)
|
||||
TEMP=ECM(2)-ECM(1)
|
||||
do 280 jj=1,nltr
|
||||
if((icon(3).le.1.and.jj.eq.ii).or.
|
||||
1 (icon(3).eq.2.and.ii.eq.nltr)) then
|
||||
WRITE(6,9505)LTRT(jj),JTRT(jj),IS(3),TEMP
|
||||
endif
|
||||
280 continue
|
||||
C
|
||||
write(*,'(a)')' Subroutine INSIG entered'
|
||||
CALL INSIG(D, plm, JTR,FACT)
|
||||
C
|
||||
endif
|
||||
300 CONTINUE
|
||||
REWIND 2
|
||||
RETURN
|
||||
|
||||
9002 FORMAT(1H0,'REACSIG 1',1PE14.5,45X,'REACSIG 2',1PE14.5)
|
||||
9505 FORMAT(18H ANG MOM TRANSFER ,9H LTR =,I4,14H. 2*JTR=,I4
|
||||
1,14H. 2*STR=,I4,14H. Q =,F9.4)
|
||||
9507 FORMAT(18H0BASIC DATA ,9H DR =,F9.4,9H RMIN =,F9.4
|
||||
1, 9H RMAX =,F9.4,9H COUEX=,F9.4
|
||||
2, 9H IS1=,F9.4)
|
||||
9508 FORMAT(18X,9H FNRNG=,F9.4,9H PNLC1=,F9.4,9H PNLC2=,F9.4
|
||||
1, 9H PNLC3=,F9.4,9H IS2=,F9.4)
|
||||
9900 FORMAT(24H0 RADIAL MATRIX ELEMENTS ,9H, J1=L1+,I2,2H/2
|
||||
1, 9H, J2=L2+,I2,2H/2 )
|
||||
9901 FORMAT('0 L2 F(L2,/L2-LTR/ ) F(L2,/L2-LTR/+2)'
|
||||
1, ' F(L2,/L2-LTR/+4) F(L2,/L2-LTR/+6)')
|
||||
9902 FORMAT(I4,1P10E10.3/(4X,1P10E10.3))
|
||||
9903 FORMAT('0 L2 BETA(L2,0) BETA(L2,1) BETA(L2,2)'
|
||||
1, ' BETA(L2,3) BETA(L2,4)')
|
||||
9904 FORMAT(1H0,32HELASTIC SCATTERING CROSS-SECTION )
|
||||
9905 FORMAT(1H0,8H MS2=,I2,2H/2,8H MS1=,I2,2H/2)
|
||||
9999 FORMAT(1H1,15A4,I4,2(1H/,I2.2),I4,2(1H.,I2.2))
|
||||
END
|
||||
|
||||
c***********************************************************************
|
||||
SUBROUTINE INTEG4(isym)
|
||||
C
|
||||
c Subroutine to integrate radial differential equations for the
|
||||
c distorted waves.
|
||||
c
|
||||
c***********************************************************************
|
||||
parameter(ispc0 = 4010, ispc1 = 8000, ispc2 = 8000)
|
||||
IMPLICIT REAL*8(A-H,O-Z)
|
||||
logical isym(2)
|
||||
COMMON ALPHA(15),IDAT(6),ICON(20),ANGLE(5),HBARC,AMU,AMASS,CHSQ,AA
|
||||
1,DRF,Z(3),ZA(3),FM(3),FMA(3),RC(3),AC(3),PNLOC(3),FS(3),ECM(3)
|
||||
2,FK(3),FK2(3),ETA(3),DR(3),FMU(3),FN,FL,FJ2,FSS,VCE,FNRNG,RSIG(2)
|
||||
3,K,KZ,LPLUS,LPL2,IS(3),NS(3),NLTR,LTRT(8),JTRT(8),ISTRT(8),IBF(8)
|
||||
4,KC,IBUFF,IWORD,ILINE,JLINE
|
||||
Common/array0/space0(ispc0)
|
||||
Common/array1/space1(ispc1)
|
||||
Common/array2/space2(ispc2)
|
||||
DIMENSION U(800,2), V(800,2)
|
||||
1 ,F (400),FP(400),G (400),GP(400),S(400)
|
||||
2 ,F1(800),F2(800),Q1(800),Q2(800),C(800)
|
||||
3 ,D (800),X(800),DTEMP(3200)
|
||||
4 ,E (12),Q(4),A(2),B(2),CTEMP(2),LM(6)
|
||||
5 ,DRR2(2),DR2(2),R(2)
|
||||
EQUIVALENCE (space0( 1), U), (space0(1601), V)
|
||||
1 ,(U,DTEMP)
|
||||
2 ,(space1( 1),Q1),(space1( 801),Q2),(space1(1601),F1)
|
||||
3 ,(space1(2401),F2),(space1( 801),X ),(space1( 1),D )
|
||||
4 ,(DTEMP( 1),F ),(DTEMP( 401),FP),(DTEMP( 801),G )
|
||||
5 ,(DTEMP(1201),GP),(DTEMP(1601),S ),(DTEMP(2001),C )
|
||||
DATA ETA3/10.E+00/
|
||||
C
|
||||
IWORD=0
|
||||
JT=NS(1)+NS(2)
|
||||
NP=LPL2*JT
|
||||
I=0
|
||||
DO 30 N=1,2
|
||||
DR2(N)=DR(N)**2/12.0
|
||||
R(N)=0.0
|
||||
JS=NS(N)
|
||||
DO 29 ISS=1,JS
|
||||
I=I+1
|
||||
LM(I)=0
|
||||
29 CONTINUE
|
||||
30 CONTINUE
|
||||
DO 40 IQ=1,NP
|
||||
F1(IQ)=0.0
|
||||
F2(IQ)=0.0
|
||||
Q1(IQ)=0.0
|
||||
Q2(IQ)=0.0
|
||||
40 CONTINUE
|
||||
C
|
||||
DO 100 M=1,K
|
||||
MK=M+M-1
|
||||
IX=0
|
||||
I=0
|
||||
DO 90 N=1,2
|
||||
R(N)=R(N)+DR(N)
|
||||
DRR2(N)=DR2(N)/R(N)**2
|
||||
Q(1)=1.0+DR2(N)*U(MK ,N)
|
||||
Q(2)= DR2(N)*U(MK+1,N)
|
||||
LTEMP=2.0*FK(N)*R(N)+ETA3
|
||||
LTEMP=MIN0(LTEMP,LPLUS)
|
||||
FI=-FS(N)
|
||||
JS=NS(N)
|
||||
SFACT=FS(N)**2+FS(N)
|
||||
DO 89 ISS=1,JS
|
||||
I=I+1
|
||||
FL=0.0
|
||||
DO 80 LL=1,LPLUS
|
||||
FJ=FL+FI
|
||||
IX1=IX+LL+LL-1
|
||||
FLFACT=FL**2+FL
|
||||
FACT=DR2(N)*(FJ**2+FJ-FLFACT-SFACT)*0.5
|
||||
Q(3 )=Q(1)+FACT*V(MK ,N)-DRR2(N)*FLFACT
|
||||
Q(4 )=Q(2)+FACT*V(MK+1,N)
|
||||
IF(LL.LE.LM(I)) GO TO 70
|
||||
IF(LTEMP.LT.LL) GO TO 72
|
||||
LM(I)=LM(I)+1
|
||||
IF(FJ-ABS(FL-FS(N)).LT.0.0) GO TO 72
|
||||
c calculate approximate starting value
|
||||
f2(ix1 )=1.0
|
||||
do 50 ii=1,ll
|
||||
f2(ix1 )=f2(ix1 )*(fk(n)*r(n))/float(2*ii-1)
|
||||
50 continue
|
||||
F2(IX1+1)=0.0
|
||||
Q2(IX1 )=Q(3)*f2(ix1 )
|
||||
Q2(IX1+1)=Q(4)*f2(ix1 )
|
||||
C
|
||||
C EVALUATE Q AT ORIGIN FOR L=1
|
||||
C
|
||||
IF(LL.EQ.2) Q1(IX+3)=-f2(ix1 )/6.0
|
||||
GO TO 72
|
||||
70 CONTINUE
|
||||
c
|
||||
c Step equations forward by dr(n) via Numerov-Fox-Goodwin-Milne method
|
||||
c
|
||||
CTEMP(1)=12.*F2(IX1 )-10.*Q2(IX1 )-Q1(IX1 )
|
||||
CTEMP(2)=12.*F2(IX1+1)-10.*Q2(IX1+1)-Q1(IX1+1)
|
||||
F1(IX1 )=F2(IX1 )
|
||||
F1(IX1+1)=F2(IX1+1)
|
||||
DET=Q(3)**2+Q(4)**2
|
||||
F2(IX1 )=(CTEMP(1)*Q(3 )+CTEMP(2)*Q(4 ))/DET
|
||||
F2(IX1+1)=(CTEMP(2)*Q(3 )-CTEMP(1)*Q(4 ))/DET
|
||||
Q1(IX1 )=Q2(IX1 )
|
||||
Q1(IX1+1)=Q2(IX1+1)
|
||||
Q2(IX1 )=CTEMP(1)
|
||||
Q2(IX1+1)=CTEMP(2)
|
||||
72 CONTINUE
|
||||
FL=FL+1.0
|
||||
80 CONTINUE
|
||||
FI=FI+1.0
|
||||
IX=IX+LPL2
|
||||
89 CONTINUE
|
||||
90 CONTINUE
|
||||
C
|
||||
C WRITE RADIAL WAVE FUNCTIONS ON TAPE 4
|
||||
C
|
||||
WRITE(4)(F2(J),J=1,NP)
|
||||
100 CONTINUE
|
||||
LX=1
|
||||
drrc = 0.1
|
||||
DO 120 N=1,2
|
||||
R2=FK(N)*R(N)
|
||||
R1=R2-DR(N)*FK(N)
|
||||
CALL COU(R1,R2,ETA(N),LPLUS,drrc,F(LX),FP(LX),G(LX),GP(LX),S(LX))
|
||||
RSIG(N)=0.0
|
||||
LX=LX+LPLUS
|
||||
120 CONTINUE
|
||||
C
|
||||
IF(ICON(5).ne.0) then
|
||||
WRITE(6,9999)ALPHA,(IDAT(I),I=1,3)
|
||||
WRITE(6,9600)
|
||||
WRITE(6,9601)
|
||||
endif
|
||||
c
|
||||
c Match solutions to asymptotic form
|
||||
c
|
||||
DO 300 LL=1,LPLUS
|
||||
FL=FLOAT(LL-1)
|
||||
LX=LL
|
||||
I=0
|
||||
IX1=LL+LL-1
|
||||
DO 200 N=1,2
|
||||
JS=NS(N)
|
||||
FI=-FS(N)
|
||||
ARG=S(LX)-S(LX-LL+1)
|
||||
Q(1)=COS(ARG)
|
||||
Q(2)=SIN(ARG)
|
||||
Q(3)=Q(1)**2-Q(2)**2
|
||||
Q(4)=2.0*Q(1)*Q(2)
|
||||
DO 199 ISS=1,JS
|
||||
FJ=FL+FI
|
||||
I=I+1
|
||||
DET=F(LX)*GP(LX)-FP(LX)*G(LX)
|
||||
A(1)=(F1(IX1 )*GP(LX)-F2(IX1 )*G (LX))/DET
|
||||
A(2)=(F1(IX1+1)*GP(LX)-F2(IX1+1)*G (LX))/DET
|
||||
B(1)=(F2(IX1 )*F (LX)-F1(IX1 )*FP(LX))/DET
|
||||
B(2)=(F2(IX1+1)*F (LX)-F1(IX1+1)*FP(LX))/DET
|
||||
IF(LL.LE.LM(I).and.FJ-ABS(FL-FS(N)).ge.0.0) then
|
||||
DET=(A(1)+B(2))**2+(A(2)-B(1))**2
|
||||
CTEMP(1)=(A(1)+B(2))/DET
|
||||
CTEMP(2)=(B(1)-A(2))/DET
|
||||
else
|
||||
CTEMP(1)=0.0
|
||||
CTEMP(2)=0.0
|
||||
endif
|
||||
C
|
||||
C C=NORMALIZATION CONSTANTS
|
||||
C
|
||||
C(IX1 )=Q(1)*CTEMP(1)-Q(2)*CTEMP(2)
|
||||
C(IX1+1)=Q(1)*CTEMP(2)+Q(2)*CTEMP(1)
|
||||
C
|
||||
C E=PARTIAL WAVE SCATTERING AMPLITUDES
|
||||
C
|
||||
E(2*I-1)=B(1)*CTEMP(1)-B(2)*CTEMP(2)
|
||||
E(2*I )=B(1)*CTEMP(2)+B(2)*CTEMP(1)
|
||||
T1 = E(2*I-1)
|
||||
T2 = E(2*I )
|
||||
if(isym(N) .and. is(N).eq.0 ) then
|
||||
if(Phasef(lx-1).lt.0.0) then
|
||||
T1 = 0.0
|
||||
T2 = 0.0
|
||||
E(2*I-1) = 0.0
|
||||
E(2*I ) = 0.0
|
||||
else
|
||||
T1 = 2.0*T1
|
||||
T2 = 2.0*T2
|
||||
endif
|
||||
endif
|
||||
C
|
||||
C D=PARTIAL WAVE SCATTERING AMPLITUDES* COULOMB PHASE / WAVE NUMBER
|
||||
C
|
||||
D(IX1 )=(Q(3)*T1 - Q(4)*T2)/FK(N)
|
||||
D(IX1+1)=(Q(3)*T2 + Q(4)*T1)/FK(N)
|
||||
X(IX1 )=E(2*I-1)
|
||||
X(IX1+1)=E(2*I )
|
||||
C
|
||||
C CALCULATE REACTION SIGMA
|
||||
C
|
||||
T1 = E(2*I ) - E(2*I-1)**2-E(2*I )**2
|
||||
if(isym(N) .and. is(N).eq. 0) T1 = 4.0*T1
|
||||
RSIG(N)=RSIG(N)+(2.0*FJ+1.0)*T1
|
||||
FI=FI+1.0
|
||||
IX1=IX1+LPL2
|
||||
199 CONTINUE
|
||||
LX=LX+LPLUS
|
||||
200 CONTINUE
|
||||
IF(ICON(5).ne.0) then
|
||||
C
|
||||
C WRITE ELASTIC PARTIAL WAVE SCATTERING AMPLITUDES
|
||||
C
|
||||
IX=LL-1
|
||||
I1=1
|
||||
I2=NS(1)*2
|
||||
WRITE(6,9602)IX,(E(INDEX ),INDEX=I1,I2)
|
||||
I1=I2+1
|
||||
I2=I2+NS(2)*2
|
||||
WRITE(6,9603)IX,(E(INDEX ),INDEX=I1,I2)
|
||||
endif
|
||||
300 CONTINUE
|
||||
DO 310 N=1,2
|
||||
RSIG(N)=RSIG(N)*12.566371 /((2.0*FS(N)+1.0)*FK(N)**2)
|
||||
310 CONTINUE
|
||||
C
|
||||
C WRITE NORMALIZATION CONSTANTS ON TAPE 4
|
||||
C
|
||||
WRITE(4)(C(I),I=1,NP)
|
||||
C
|
||||
C WRITE END POINT FUNCTIONS FOR UNBOUND STATE STRIPPING
|
||||
C
|
||||
C ILINE IS SET IN ADWUCK FORM FACTOR LOOP
|
||||
IF(ILINE.EQ.0) GO TO 400
|
||||
WRITE(4)(X(I),I=1,NP),(GP(I),FP(I),I=1,LPL2),(S(I),I=1,LPL2)
|
||||
400 CONTINUE
|
||||
END FILE 4
|
||||
REWIND 4
|
||||
RETURN
|
||||
9600 FORMAT(1H0,35HPARTIAL WAVE SCATTERING AMPLITUDES )
|
||||
9601 FORMAT(4H L,20H REAL D1 IMAG D1 ,20H REAL D2 IMAG D2
|
||||
1, 20H REAL D3 IMAG D3
|
||||
2, 4X,4H L,20H REAL D1 IMAG D1 ,20H REAL D2 IMAG D2
|
||||
3, 20H REAL D3 IMAG D3 )
|
||||
9602 FORMAT(1H , I3,6F10.6)
|
||||
9603 FORMAT(1H+,68X,I3,6F10.6)
|
||||
9999 FORMAT(1H1,15A4,I4,2(1H/,I2.2),I4,2(1H.,I2.2))
|
||||
END
|
||||
|
||||
c***********************************************************************
|
||||
SUBROUTINE TAPED
|
||||
C
|
||||
c Subroutine writes out radial wave functions,
|
||||
c spaced icon(12) points apart
|
||||
c***********************************************************************
|
||||
c
|
||||
parameter(ispc0 = 4010, ispc1 = 8000, ispc2 = 8000)
|
||||
IMPLICIT REAL*8(A-H,O-Z)
|
||||
COMMON ALPHA(15),IDAT(6),ICON(20),ANGLE(5),HBARC,AMU,AMASS,CHSQ,AA
|
||||
1,DRF,Z(3),ZA(3),FM(3),FMA(3),RC(3),AC(3),PNLOC(3),FS(3),ECM(3)
|
||||
2,FK(3),FK2(3),ETA(3),DR(3),FMU(3),FN,FL,FJ2,FSS,VCE,FNRNG,RSIG(2)
|
||||
3,K,KZ,LPLUS,LPL2,IS(3),NS(3),NLTR,LTRT(8),JTRT(8),ISTRT(8),IBF(8)
|
||||
4,KC,IBUFF,IWORD,ILINE,JLINE
|
||||
Common/array0/space0(ispc0)
|
||||
Common/array1/space1(ispc1)
|
||||
Common/array2/space2(ispc2)
|
||||
|
||||
DIMENSION C(800),FR(800),R(2),CTEMP(2)
|
||||
EQUIVALENCE (space0(2001), C(1)), (space0( 801), FR(1))
|
||||
c
|
||||
IK=ICON(12)
|
||||
JT=NS(1)+NS(2)
|
||||
NP=LPL2*JT
|
||||
R(1)=0.0
|
||||
R(2)=0.0
|
||||
IKTEMP=0
|
||||
DO 50 M=1,K
|
||||
IKTEMP=IKTEMP+1
|
||||
C
|
||||
C READ IN DISTORTED WAVE RADIAL FUNCTIONS
|
||||
C
|
||||
READ (4)(FR(J),J=1,NP)
|
||||
IF(IKTEMP.NE.IK) GO TO 50
|
||||
IKTEMP=0
|
||||
IX=0
|
||||
DO 40 N=1,2
|
||||
R(N)=R(N)+DR(N)*FLOAT(IK)
|
||||
JX=NS(N)
|
||||
DO 39 J=1,JX
|
||||
DO 30 LL=1,LPLUS
|
||||
LK=LL+LL-1
|
||||
IX1=LK+IX
|
||||
IX2=IX1+1
|
||||
C
|
||||
C NORMALIZE RADIAL FUNCTIONS
|
||||
C
|
||||
CTEMP(1)=FR(IX1)*C(IX1)-FR(IX2)*C(IX2)
|
||||
CTEMP(2)=FR(IX1)*C(IX2)+FR(IX2)*C(IX1)
|
||||
FR(IX1)=CTEMP(1)
|
||||
FR(IX2)=CTEMP(2)
|
||||
30 CONTINUE
|
||||
IX=IX+LPL2
|
||||
39 CONTINUE
|
||||
40 CONTINUE
|
||||
WRITE(6,9001)R(1),R(2)
|
||||
WRITE(6,9601)
|
||||
DO 45 LL=1,LPLUS
|
||||
LM=LL-1
|
||||
LK1=LM+LL
|
||||
LK2=LPL2*(NS(1)-1)+LK1
|
||||
WRITE(6,9602)LM,(FR(LK),FR(LK+1),LK=LK1,LK2,LPL2)
|
||||
LK1=LK2+LPL2
|
||||
LK2=LPL2*(NS(2)-1)+LK1
|
||||
WRITE(6,9603)LM,(FR(LK),FR(LK+1),LK=LK1,LK2,LPL2)
|
||||
45 CONTINUE
|
||||
50 CONTINUE
|
||||
REWIND 4
|
||||
RETURN
|
||||
9001 FORMAT(1H0,3HR1=,F8.4,57X,3HR2=,F8.4)
|
||||
9601 FORMAT(4H L,20H REAL D1 IMAG D1 ,20H REAL D2 IMAG D2 ,20H
|
||||
1 REAL D3 IMAG D3 ,4X,4H L,20H REAL D1 IMAG D1 ,20H REAL D2
|
||||
2 IMAG D2 ,20H REAL D3 IMAG D3 )
|
||||
9602 FORMAT(1H , I3,6F10.7)
|
||||
9603 FORMAT(1H+,68X,I3,6F10.7)
|
||||
END
|
||||
|
||||
813
dwuck4/CDWCK4.FOR
Normal file
813
dwuck4/CDWCK4.FOR
Normal file
|
|
@ -0,0 +1,813 @@
|
|||
|
||||
c$debug
|
||||
c***********************************************************************
|
||||
SUBROUTINE RADINT(F,FLL,UB,FF,LTR)
|
||||
c
|
||||
c Subroutine for computing radial integrals
|
||||
c
|
||||
c f Radial wave function storage
|
||||
c fll Radial integral storage
|
||||
c ltr Angular momentum transfer
|
||||
c***********************************************************************
|
||||
c
|
||||
c Ymax maximum X = ikr, off real axis
|
||||
c Nx number of points off real axis, must be a multiple of 5
|
||||
C
|
||||
parameter(ispc0 = 2005, ispc1 = 4000, ispc2 = 4000)
|
||||
IMPLICIT REAL*8(A-H,O-Z)
|
||||
double complex space0, space1, space2
|
||||
parameter (kmax = 400, lmax = 400, nx=200, Ymax=10.0)
|
||||
double complex FLL(*), F(*), H(lmax), C(lmax), D(lmax)
|
||||
1 , cfk1, cfk2, cfk3, FP(2*nx+1), FA(2*nx+1)
|
||||
1 , UB, CTEMP, VTEMP, FFTEMP, buffr
|
||||
2 , T1, CN, CP, CD, SUM1, SUM3, Smat, HN
|
||||
c
|
||||
COMMON ALPHA(15),IDAT(6),ICON(20),ANGLE(5),HBARC,AMU,AMASS,CHSQ,AA
|
||||
1,DRF,Z(3),ZA(3),FM(3),FMA(3),RC(3),AC(3),PNLOC(3),FS(3),ECM(3)
|
||||
2,FK(3),FK2(3),ETA(3),DR(3),FMU(3),FN,FL,FJ2,FSS,VCE,FNRNG,RSIG(2)
|
||||
3,K,KZ,LPLUS,LPL2,IS(3),NS(3),NLTR,LTRT(8),JTRT(8),ISTRT(8),IBF(8)
|
||||
4,KC,IBUFF,IWORD,ILINE,JLINE
|
||||
c
|
||||
Common/array0/space0(ispc0)
|
||||
Common/array1/space1(ispc1)
|
||||
Common/array2/space2(ispc2)
|
||||
c
|
||||
DIMENSION UB(kmax),ff(10),buffr(1600)
|
||||
1, DRX(2), LPTBL(lmax/2), S(lmax), WT(5)
|
||||
EQUIVALENCE (space1( 1), buffr), (space0( 1), D)
|
||||
2 ,(space0( 401), H), (space0(1201), C)
|
||||
C
|
||||
IF(RC(3).EQ.0.0) RC(3)=DR(3)
|
||||
c Coulomb excitation factor
|
||||
VFACT=3.0*VCE*CHSQ*Z(3)*ZA(3)*RC(3)**LTR/FLOAT(LTR+LTR+1)
|
||||
if(ltr.eq.0) vfact=vfact/3.0
|
||||
DRX(1)=2.0*DR(3)/3.0
|
||||
DRX(2)=2.0*DRX(1)
|
||||
C JACOBIAN FACTOR
|
||||
ANORM= MAX (DR(1),DR(2))**2/(DR(3)* MIN (DR(1),DR(2)))
|
||||
JR = NS(1)
|
||||
JS = NS(2)
|
||||
NP=LPLUS*(JR+JS)
|
||||
INCR=LPLUS*(LTR+1)
|
||||
c
|
||||
C Unbound state and coulomb excitation end point data
|
||||
C ff( 1) = D REAL (exp(2i*delta) - 1)/(2i)
|
||||
C ff( 2) = D IMAG (exp(2i*delta) - 1)/(2i)
|
||||
C ff( 3) = G irregular solution at R = Rmax
|
||||
C ff( 4) = F regular solution at R = Rmax
|
||||
C ff( 5) = K**2 real
|
||||
C ff( 6) = K**2 imag
|
||||
C ff( 7) = Eta * K
|
||||
C ff( 8) = IVB switch
|
||||
C = 2, unbound state routine
|
||||
C = 4, coulomb excitation
|
||||
C ff( 9) = Number of last point of form factor
|
||||
C ff(10) = ISW parameter in BIND routine
|
||||
C
|
||||
IVB =ff( 8)
|
||||
isw =ff(10)
|
||||
c
|
||||
if(ivb.eq.2) then
|
||||
c Unbound state
|
||||
FFTEMP = UB(KC)
|
||||
elseif(ivb.eq.4) then
|
||||
c Coulomb excitation
|
||||
fftemp = cmplx(ff(1), ff(2))/(dr(3)*float(k))
|
||||
endif
|
||||
c Spin orbit factor
|
||||
FSFACT=FS(1)*(FS(1)+1.)+FS(2)*(FS(2)+1.)
|
||||
c clear radial integral storage
|
||||
INC=INCR*NS(1)*NS(2)
|
||||
DO 3 II=1,INC
|
||||
FLL(II)=0.0
|
||||
3 CONTINUE
|
||||
c
|
||||
R3 = 0.0
|
||||
MX = 1
|
||||
DO 100 M=1,K
|
||||
MX = 3-MX
|
||||
R3 = R3+DRF
|
||||
C
|
||||
C READ IN DISTORTED WAVE RADIAL FUNCTIONS
|
||||
C
|
||||
READ (4)(F(J),J=1,NP)
|
||||
VTEMP = UB(M)*DRX(MX)
|
||||
IF(VFACT.NE.0.0) then
|
||||
C
|
||||
C COULOMB EXCITATION ADDITION TO FORM FACTOR
|
||||
C
|
||||
IF(R3 .GT .RC(3)) then
|
||||
VTEMP = VTEMP + DRX(MX)*VFACT/R3**(LTR+1)
|
||||
endif
|
||||
endif
|
||||
C
|
||||
C**** READ IN NORMALIZATION CONSTANTS at last point
|
||||
C
|
||||
IF(M .EQ. K) then
|
||||
READ (4)(C(I),I=1,NP)
|
||||
c adjust last point in integration rule
|
||||
VTEMP = VTEMP*0.5
|
||||
endif
|
||||
c
|
||||
INC=0
|
||||
IY=0
|
||||
c
|
||||
c Loop over initial state spin states
|
||||
c
|
||||
FS1=-FS(1)
|
||||
DO 96 I= 1,JR
|
||||
IZ=NS(1)*LPLUS
|
||||
c
|
||||
c Loop over final state spin states
|
||||
c
|
||||
FS2=-FS(2)
|
||||
DO 95 J=1,JS
|
||||
c
|
||||
c Final state L values
|
||||
c
|
||||
DO 90 LL=1,LPLUS
|
||||
LK=LL
|
||||
IZ1=LL+IZ+(J-1)*LPLUS
|
||||
LP1=IABS(LL-LTR-1)+1
|
||||
LP2=MIN0(LL+LTR,LPLUS)
|
||||
CTEMP = VTEMP*F(IZ1)
|
||||
c
|
||||
c Initial state L values
|
||||
c
|
||||
DO 80 LP=LP1,LP2,2
|
||||
IY1=LP+(I-1)*LPLUS
|
||||
IND=LK+INC
|
||||
IF(M .LT. KZ) GO TO 79
|
||||
FLL(IND)=FLL(IND) + CTEMP*F(IY1)
|
||||
IF(M.EQ.K) THEN
|
||||
C
|
||||
C NORMALIZE RADIAL INTEGRALS
|
||||
C
|
||||
FLL(IND) = C(IZ1)*FLL(IND)*C(IY1)*ANORM
|
||||
C L*S FORM FACTOR, use symmetrized form
|
||||
IF(IVB.EQ.1) THEN
|
||||
FJ1=FLOAT(LL)+FS1
|
||||
FJ2=FLOAT(LP)+FS2
|
||||
TEMP1 = (FJ1*(FJ1-1.)+FJ2*(FJ2-1.)-FLOAT(LL*(LL-1))
|
||||
1 -FLOAT(LP*(LP-1))-FSFACT)/4.
|
||||
FLL(IND)=FLL(IND)*TEMP1
|
||||
ENDIF
|
||||
ENDIF
|
||||
79 continue
|
||||
LK=LK+LPLUS
|
||||
80 CONTINUE
|
||||
90 CONTINUE
|
||||
INC=INC+INCR
|
||||
FS2=FS2+1.0
|
||||
95 CONTINUE
|
||||
IY=IY+LPLUS
|
||||
FS1=FS1+1.0
|
||||
96 CONTINUE
|
||||
100 CONTINUE
|
||||
c special flag to skip this section
|
||||
IF(ICON(20).NE.0) GO TO 1100
|
||||
IF(IVB.EQ.2 .OR .IVB.EQ.4) THEN
|
||||
C
|
||||
C UNBOUND STATE SECTION
|
||||
C
|
||||
cfk1 = fk2(1)
|
||||
cfk2 = fk2(2)
|
||||
cfk3 =cmplx(ff (5),ff(6))
|
||||
CN =cmplx(FF(1), FF(2))
|
||||
HN =cmplx(FF(3), FF(4))
|
||||
etak =ff(7)
|
||||
FK(3) = sqrt(abs(ff (5)))
|
||||
c
|
||||
C read in scatt. amp. and asymptotic fcts - h(ODD) = g, h(EVEN) = f
|
||||
c and coulomb phases
|
||||
c
|
||||
READ (4)(D(I),I=1,NP),(H(I),I=1,LPL2),(S(I),I=1,LPL2)
|
||||
R1=DR(1)*FLOAT(KC)
|
||||
R2=DR(2)*FLOAT(KC)
|
||||
R3=DR(3)*FLOAT(KC)
|
||||
DX=Ymax/FLOAT(NX)
|
||||
EZ=EXP(-DX)
|
||||
DX1=DX/(FK(1)-FK(2)*FMA(1)/FMA(2)-FK(3))
|
||||
IF(DX1.LE.0.0) THEN
|
||||
WRITE(6,'(a)')'0KINEMATICS INCONSISTENT - EXIT ON ERROR'
|
||||
STOP 'Kinematics error in Routine UNBIND'
|
||||
ENDIF
|
||||
C
|
||||
NI=DX1/DR(1)/2.0+0.5
|
||||
NI=MAX0(NI,1)
|
||||
DX1=DX1/FLOAT(NI)
|
||||
DX2=DX1*FMA(1)/FMA(2)
|
||||
C Calculate form factor extension into complex (Rmax,y) plane
|
||||
IFLG=1
|
||||
C -----------------------------------------------------
|
||||
CALL UNBIND(LTR,NX,NI,FA,CN,HN,etak,cfk3,DX1,R1,IFLG)
|
||||
C -----------------------------------------------------
|
||||
C ADJUST FA FOR FINITE RANGE, NON LOCALITY, AND PHASE
|
||||
C FFTEMP IS FORM FACTOR AT RMAX
|
||||
C FA(R+i0) IS UNMODIFIED FORM FACTOR FROM BIND AT RMAX
|
||||
C T1 = FFTEMP/FA(R+i0)
|
||||
T1 = FFTEMP/FA(nx+1)
|
||||
DX=DX1*FLOAT(NI)
|
||||
NX1=NX+1
|
||||
C Multiply FA BY R/(R+iy )
|
||||
DO 120 M=1,NX1
|
||||
M1=M
|
||||
M2=2*NX+2 - M
|
||||
X = dx*float(NX1-M)
|
||||
FA(M1) = FA(M1)*(R1*T1)/cmplx(R1, X)
|
||||
FA(M2) = conjg(FA(M1))
|
||||
120 CONTINUE
|
||||
C
|
||||
WT(1)=190.*DX/288.
|
||||
WT(2)=375.*DX/288.
|
||||
WT(3)=250.*DX/288.
|
||||
WT(4)=WT(3)
|
||||
WT(5)=WT(2)
|
||||
C MULTIPLY FA BY INTEGRATION WEIGHTS
|
||||
DO 130 M=1,NX
|
||||
M1=M
|
||||
M2=2*NX+2 - M
|
||||
MX=MOD(M-1,5) + 1
|
||||
FA(M1 ) = FA(M1 )*WT(MX)
|
||||
FA(M2 ) = FA(M2 )*WT(MX)
|
||||
130 CONTINUE
|
||||
C ADJUST WT FOR END POINT R+i0 IN INTEGRATION RULE
|
||||
FA(NX1) = FA(NX1)*0.5*WT(1)
|
||||
C
|
||||
IF((2*LTR+1)*(2*NX+2).GT.IBUFF) THEN
|
||||
WRITE(6,9900)LTR
|
||||
9900 FORMAT('0NOT ENOUGH CIRCULAR BUFFER SPACE FOR DEUTERON WAVE,'
|
||||
1 ,' LTR=' , I3, ' IS TOO LARGE')
|
||||
STOP 'BUFFER ERROR IN UNBIND'
|
||||
ENDIF
|
||||
C
|
||||
INC=0
|
||||
IY1=0
|
||||
FS1=-FS(1)
|
||||
DO 1020 I=1,JR
|
||||
IY2=NS(1)*LPLUS
|
||||
FS2=-FS(2)
|
||||
DO 1010 J=1,JS
|
||||
LPX=0
|
||||
LPT=1
|
||||
DO 1000 LL=1,LPLUS
|
||||
LK=LL
|
||||
LP1=IABS(LL-LTR-1)+1
|
||||
LP2=MIN0(LL+LTR,LPLUS)
|
||||
FJ2=FLOAT(LL-1)+FS2
|
||||
C CALCULATE PROTON WAVE extension into complex plane
|
||||
LM=LL+LPLUS
|
||||
IZ2=IY2+LK
|
||||
IFLG=1
|
||||
C -----------------------------------------------------
|
||||
CALL UNBIND(LL-1,NX,NI,FP(1),D(IZ2),H(LM)
|
||||
1, ETA(2)*fk(2),cfk2,DX2,R2,IFLG)
|
||||
C -----------------------------------------------------
|
||||
C
|
||||
M2=2*NX+2
|
||||
LP=1
|
||||
IF(LL.EQ.1) LP=MIN0(LTR+1,LPLUS)
|
||||
IF(LPX.GE.LPLUS) GO TO 160
|
||||
DO 150 L=1,LP
|
||||
C CALCULATE DEUTERON WAVE AND PLACE IN CIRCULAR BUFFER
|
||||
LM=LPX+1
|
||||
IZ1=IY1+LM
|
||||
IFLG=0
|
||||
C -----------------------------------------------------
|
||||
CALL UNBIND(LPX,NX,NI,BUFFR(LPT),D(IZ1),H(LM)
|
||||
1, ETA(1)*fk(1),cfk1,DX1,R1,IFLG)
|
||||
C -----------------------------------------------------
|
||||
LPX=LPX+1
|
||||
LPTBL(LPX)=LPT-1
|
||||
LPT=LPT+(NX+1)
|
||||
IF(LPT+(NX+1).GT.IBUFF/2) LPT=1
|
||||
150 CONTINUE
|
||||
160 CONTINUE
|
||||
C
|
||||
C MULTIPLY FP BY FA and place in FP
|
||||
C
|
||||
LM=LL+LPLUS
|
||||
CP = cmplx(COS(S(LM)-S(LPLUS+1)), SIN(S(LM)-S(LPLUS+1)) )
|
||||
NX2=2*NX+1
|
||||
DO 300 M=1,NX2
|
||||
FP(M) = CP*FP(M)*FA(M)
|
||||
300 CONTINUE
|
||||
c
|
||||
LPT1=LPTBL(LP)+1
|
||||
LPT2=LPT1+(NX+1)-1
|
||||
C
|
||||
DO 400 LP=LP1,LP2,2
|
||||
FJ1=FLOAT(LP-1)+FS1
|
||||
IND=LK+INC
|
||||
SUM1=0.0
|
||||
SUM3=0.0
|
||||
C CONSTRUCT OUTGOING WAVE AMPLITUDE FROM D = ( EXP(2i*delta) - 1)/2i
|
||||
IZ1=IY1+LP
|
||||
Smat = cmplx(0.0, 2.0)*D(IZ1) + 1.0
|
||||
CD = cmplx(COS(S(LP)-S(1)), SIN(S(LP)-S(1)) )
|
||||
IF(FJ1.LT.0.0.OR.FJ2.LT.0.0) GO TO 331
|
||||
C NUMERICAL INTEGRATION FOR RADIAL MATRIX ELEMENTS
|
||||
C INTEGRATION IS +i*Dy FOR +y AND -i*Dy FOR -y
|
||||
C WITH LIMITS ON y OF 0 --> infinity HENCE THE + SIGN
|
||||
C WHEN COMBINING OUTGOING AND INGOING DEUTERON WAVES
|
||||
C
|
||||
FE=1.0
|
||||
NX1=NX+1
|
||||
DO 330 M=1,NX1
|
||||
M1=NX+2 - M
|
||||
M2=NX + M
|
||||
IX1=LPTBL(LP)+M1
|
||||
c
|
||||
c Let k = k_d - k_p - k_n, EZ = exp(-k*dy), FE = exp(-k*y)
|
||||
c use UD(-, R-iy) = conjg[ UD(+, R+iy) ]
|
||||
c
|
||||
C MULTIPLY BY DEUTERON OUTGOING WAVE PART, UD(+)*FP(R+iy)*exp(-k*y)
|
||||
SUM1 = SUM1 + FP(M1)* BUFFR(IX1) *FE
|
||||
C MULTIPLY BY DEUTERON INGOING WAVE PART, UD(-)*FP(R-iy)*exp(-k*y)
|
||||
SUM3 = SUM3 + FP(M2)*conjg(BUFFR(IX1))*FE
|
||||
FE=FE*EZ
|
||||
330 CONTINUE
|
||||
331 CONTINUE
|
||||
C UD = (S*UD(+) + UD(-))/2 (divide by 2i NOT! since dz = idy)
|
||||
FLL(IND) = FLL(IND)+(Smat*SUM1+SUM3)*(0.5*CD*ANORM)
|
||||
LK=LK+LPLUS
|
||||
400 CONTINUE
|
||||
1000 CONTINUE
|
||||
INC=INC+INCR
|
||||
IY2=IY2+LPLUS
|
||||
FS1=FS1+1.0
|
||||
1010 CONTINUE
|
||||
IY1=IY1+LPLUS
|
||||
FS2=FS2+1.0
|
||||
1020 CONTINUE
|
||||
C
|
||||
c End of unbound state section
|
||||
c
|
||||
ENDIF
|
||||
C
|
||||
1100 CONTINUE
|
||||
C
|
||||
C
|
||||
REWIND 4
|
||||
JR=IBF(7)+1
|
||||
JS=IBF(8)+1
|
||||
IF(NLTR.NE.1) GO TO 1105
|
||||
IF(JR+JS.EQ.2) GO TO 2000
|
||||
1105 CONTINUE
|
||||
C
|
||||
C WRITE RADIAL MATRIX ELEMENTS ON TAPE 2
|
||||
C
|
||||
JSX=JS
|
||||
IF(IBF(6).EQ.0) JSX=1
|
||||
DO 1120 I=1,JR
|
||||
IY=I-1
|
||||
IF(IBF(5).EQ.0) IY=0
|
||||
DO 1110 J=1,JS
|
||||
IZ=J-1
|
||||
IF(IBF(6).EQ.0) IZ=0
|
||||
INC=INCR*(JSX*IY+IZ)+1
|
||||
INDEX=INC-1+INCR
|
||||
WRITE(2)(FLL(II),II=INC,INDEX)
|
||||
1110 CONTINUE
|
||||
1120 CONTINUE
|
||||
2000 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
|
||||
c***********************************************************************
|
||||
SUBROUTINE UNBIND(L,NX,NI,Y,D,H,ETAK,cfk2,DX,R,IFLG)
|
||||
C
|
||||
c Subroutine to extend wave functions into complex plane for unbound
|
||||
c stripping cases.
|
||||
c
|
||||
c L Orbital angular momentum
|
||||
c nx Number of points in integration
|
||||
c ni Number of intermediate points
|
||||
c y Storage for resulting wave function
|
||||
c d Scattering amplitude = (exp(2i*delta) - 1)/(2i)
|
||||
c h Hankel functions at Rmax
|
||||
c etak Coulomb parameter * wave number
|
||||
c cfk2 Square of wave number
|
||||
c dx Integration step size
|
||||
c r Rmax on real axis
|
||||
c iflg =0 for single side of real axis, =1 for both sides
|
||||
c***********************************************************************
|
||||
c
|
||||
implicit real*8(a-h,o-z)
|
||||
double complex Y(*), D, H, cfk2, Y1, Z1, Z0, Z
|
||||
1 , T1, T3, Smat
|
||||
c
|
||||
DATA Yinit/1.0E+00/
|
||||
C
|
||||
R2=R*R
|
||||
FL1=L*(L+1)
|
||||
DX12=DX*DX/12.
|
||||
EZ = EXP(-DX*SQRT(real(cfk2)))
|
||||
c set starting points
|
||||
X = DX*FLOAT(NX*NI+NI+1)
|
||||
Z = cmplx(R, X)
|
||||
ETAK2=2.0*ETAK
|
||||
IF(real(cfk2) .EQ. 0.0) THEN
|
||||
Y0 = 1.0 - cmplx(0.0, float(L)) *DX/Z
|
||||
ELSE
|
||||
Y0 = Yinit
|
||||
ENDIF
|
||||
Z0 = Y0 * (1.0 + DX12*(FL1/Z**2 + ETAK2/Z - cfk2))
|
||||
C
|
||||
Z = Z - cmplx(0.0D+0, DX)
|
||||
Y1 = Yinit
|
||||
Z1 = Y1 * (1.0 + DX12*(FL1/Z**2 + ETAK2/Z - cfk2))
|
||||
|
||||
C INTEGRATE INWARDS FROM R + iy TO R - iy FOR IFLG = 1
|
||||
C FROM R + iy TO R FOR IFLG = 0
|
||||
C REMOVE EXP( k*y ) FACTOR SO THERE IS NO OVERFLOW
|
||||
C
|
||||
if(iflg .eq. 0) then
|
||||
n2 = nx+1
|
||||
else
|
||||
n2 = 2*nx+1
|
||||
endif
|
||||
c
|
||||
DO 200 I=1,N2
|
||||
DO 190 J=1,NI
|
||||
Z = Z - cmplx(0.0D+0, DX)
|
||||
T1=12.0*Y1
|
||||
T1=(T1 - 10.0*Z1 - Z0*EZ)*EZ
|
||||
Z0 = Z1
|
||||
Z1 = T1
|
||||
Y1 = Z1 / (1.0 + DX12*(FL1/Z**2 + ETAK2/Z - cfk2))
|
||||
190 CONTINUE
|
||||
Y(I)=Y1
|
||||
200 CONTINUE
|
||||
C
|
||||
IF(IFLG .EQ. 0) then
|
||||
C
|
||||
C NORMALIZE 'DEUTERON' WAVE TO OUTGOING HANKEL FUNCTION
|
||||
C
|
||||
C Z0 is normalization constant to an
|
||||
C outgoing Hankel fct at Z = RMAX + i0
|
||||
C Z0 = H(+)/Y( R + i0)
|
||||
Z0 = H/Y(NX+1)
|
||||
DO 220 I=1,NX+1
|
||||
Y(I ) = Y(I )*Z0
|
||||
220 CONTINUE
|
||||
c
|
||||
RETURN
|
||||
else
|
||||
c
|
||||
c here for proton or neutron function
|
||||
c
|
||||
c Construct an outgoing wave amplitude from H
|
||||
C H(1) IS G
|
||||
C H(2) IS F
|
||||
C Z0 is normalization constant to an
|
||||
C outgoing Hankel fct at Z = RMAX + i0
|
||||
C Z0 = H(+)/Y(R + i0)
|
||||
c
|
||||
Z0 = H/Y(NX+1)
|
||||
c
|
||||
C D is scattering amplitude = (exp(2i*delta) -1)/(2i)
|
||||
c
|
||||
Smat = cmplx(0.0, 2.0)*D + 1.0
|
||||
F1=1.0
|
||||
F2=EZ**(2*NI)
|
||||
NX1 = NX+1
|
||||
DO 250 I=1,NX1
|
||||
IK = NX+2 - I
|
||||
IL = NX + I
|
||||
C T1 = exp(-k*X)*H(R-iy)
|
||||
C T3 = exp( k*X)*H(R+iy)
|
||||
T1 = Y(IL)*Z0
|
||||
T3 = Y(IK)*Z0*F1
|
||||
c
|
||||
C u(R+iy) = exp(-k*X)*(S*H(R+iy) - H(R-iy))/(2*i)
|
||||
Y(IK) = (Smat*T3 - dconjg(T1) )*cmplx(0.0, -0.5)
|
||||
C u(R-iy) = exp(-k*X)*(S*H(R-iy) - H(R+iy))/(2i)
|
||||
Y(IL) = (Smat*T1 - dconjg(T3) )*cmplx(0.0, -0.5)
|
||||
F1=F1*F2
|
||||
250 CONTINUE
|
||||
c
|
||||
endif
|
||||
c
|
||||
RETURN
|
||||
c
|
||||
END
|
||||
|
||||
c***********************************************************************
|
||||
SUBROUTINE BETAFN(FLL,D,LTR,JX,flfact,i_sym)
|
||||
C
|
||||
c Subroutine to form scattering amplitude from radial matrix elements
|
||||
c
|
||||
c FLL Storage for radial matrix elements
|
||||
c D Storage for scattering amplitudes
|
||||
c LTR L -transfer
|
||||
c JX 2*J-transfer
|
||||
c flfact normalizing factor
|
||||
c i_sym symmetry flags
|
||||
c***********************************************************************
|
||||
c
|
||||
implicit real*8(a-h,o-z)
|
||||
double complex FLL(*), D(*)
|
||||
logical i_sym(2), igam1,igam2
|
||||
C
|
||||
COMMON ALPHA(15),IDAT(6),ICON(20),ANGLE(5),HBARC,AMU,AMASS,CHSQ,AA
|
||||
1,DRF,Z(3),ZA(3),FM(3),FMA(3),RC(3),AC(3),PNLOC(3),FS(3),ECM(3)
|
||||
2,FK(3),FK2(3),ETA(3),DR(3),FMU(3),FN,FL,FJ2,FSS,VCE,FNRNG,RSIG(2)
|
||||
3,K,KZ,LPLUS,LPL2,IS(3),NS(3),NLTR,LTRT(8),JTRT(8),ISTRT(8),IBF(8)
|
||||
4,KC
|
||||
c
|
||||
ISB=IS(3)
|
||||
JR=NS(1)
|
||||
JS=NS(2)
|
||||
c
|
||||
c Set up spin for photon
|
||||
c
|
||||
if(fm(1).eq.0.0.and.is(1).eq.2) then
|
||||
isi=0
|
||||
igam1=.true.
|
||||
else
|
||||
isi=is(1)
|
||||
igam1=.false.
|
||||
endif
|
||||
if(fm(2).eq.0.0.and.is(2).eq.2) then
|
||||
isf=0
|
||||
igam2=.true.
|
||||
else
|
||||
isf=is(2)
|
||||
igam2=.false.
|
||||
endif
|
||||
c
|
||||
MPLUS=JX/2+1
|
||||
IFACT=MPLUS*JR*JS
|
||||
J2K=(1.0+PHASEF(NS(2)))/2.0
|
||||
M2K=JX-MPLUS-MPLUS+2
|
||||
LX=LTR+LTR
|
||||
TEMP2=SQRT(FLOAT((JX+1)*(IS(1)+1)))*flfact
|
||||
IF(FN.EQ.0.0) THEN
|
||||
c clear amplitude storage unless for coherent sum
|
||||
IND=2*LPLUS*IFACT
|
||||
DO 10 M=1,IND
|
||||
D(M)=0.0
|
||||
10 CONTINUE
|
||||
ENDIF
|
||||
IS1=-IS(1)
|
||||
DO 95 I=1,JR
|
||||
IS2=-IS(2)
|
||||
DO 90 J=1,JS
|
||||
IF(NLTR.NE.1) GO TO 14
|
||||
IF(JR*JS.EQ.1) GO TO 15
|
||||
IF(IBF(5)+IBF(6).EQ.0) GO TO 15
|
||||
14 CONTINUE
|
||||
C
|
||||
C READ RADIAL MATRIX ELEMENTS FROM TAPE 2
|
||||
C
|
||||
INCR = LPLUS*(LTR+1)
|
||||
READ (2)(FLL(INDEX),INDEX=1,INCR)
|
||||
15 continue
|
||||
c final L loop
|
||||
DO 80 LL=1,LPLUS
|
||||
lf=LL-1
|
||||
LLX=lf+lf
|
||||
JLX=LLX+IS2
|
||||
IF(JLX.LT.0) GO TO 75
|
||||
if(i_sym(2)) then
|
||||
if(phasef(lf).gt.0.0) then
|
||||
temp4=2.0*temp2
|
||||
else
|
||||
temp4=0.0
|
||||
endif
|
||||
else
|
||||
temp4=temp2
|
||||
endif
|
||||
TEMP4=temp4*SQRT(FLOAT(JLX+1))*float(llx+1)
|
||||
if(igam2) then
|
||||
temp4=temp4*sqrt(float(ll)/(float(lf)+1.e-6))
|
||||
1 *(z(1)+za(1)*(-fm(1)/fma(1))**lf)
|
||||
endif
|
||||
LSTOR=lf*IFACT
|
||||
LP1=IABS(LL-LTR-1)+1
|
||||
LP2=MIN0(LL+LTR,LPLUS)
|
||||
LK=0
|
||||
c initial L loop
|
||||
DO 60 LP=LP1,LP2,2
|
||||
li=lp-1
|
||||
LPX=LP+LP-2
|
||||
JPX=LPX+IS1
|
||||
IF(JPX.GE.0) then
|
||||
if(i_sym(1)) then
|
||||
if(phasef(li).gt.0.0) then
|
||||
temp3=2.0*temp4
|
||||
else
|
||||
temp3=0.0
|
||||
endif
|
||||
else
|
||||
temp3=temp4
|
||||
endif
|
||||
if(igam1) then
|
||||
temp3=temp3*sqrt(float(lp)/(float(li)+1.e-6))
|
||||
1 *(z(2)+za(1)*(-fm(2)/fma(2))**li)
|
||||
endif
|
||||
TEMP=temp3*SQRT(FLOAT(LPX+1))*PHASEF((LP-LL-LTR)/2)
|
||||
1 *VCC(LLX,LX,LPX,0,0)*WINEJ(LLX,isf,JLX,LX,ISB,JX,LPX,isi,JPX)
|
||||
INDEX=LK+LL
|
||||
KT=0
|
||||
c Initial state spins
|
||||
MSP=-IS(1)
|
||||
DO 57 MS1=1,JR
|
||||
c Final state spins
|
||||
MS =-IS(2)
|
||||
DO 55 MS2=1,JS
|
||||
VCP=VCC(LPX,IS(1),JPX,0,MSP)
|
||||
c
|
||||
DO 50 M=1,MPLUS
|
||||
MK=M+M-1
|
||||
MX=MK-1+M2K
|
||||
ML2=MSP-MX-MS
|
||||
ML=IABS(ML2/2)
|
||||
IF(ML.LE.lf) then
|
||||
IND=LSTOR+KT+M
|
||||
FACT=VCP*VCC(JLX,JX,JPX,MSP-MX,MX)*VCC(LLX,IS(2),JLX,ML2,MS)
|
||||
1 *SQRT(YXFCT(lf+ML,lf-ML))*TEMP
|
||||
D(IND)=D(IND)+FLL(INDEX)*FACT
|
||||
endif
|
||||
50 CONTINUE
|
||||
KT = KT+MPLUS
|
||||
MS =MS +2
|
||||
55 CONTINUE
|
||||
MSP=MSP+2
|
||||
57 CONTINUE
|
||||
endif
|
||||
LK=LK+LPLUS
|
||||
60 CONTINUE
|
||||
75 CONTINUE
|
||||
80 CONTINUE
|
||||
IS2=IS2+2
|
||||
90 CONTINUE
|
||||
IS1=IS1+2
|
||||
95 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
|
||||
c***********************************************************************
|
||||
SUBROUTINE INSIG(D,PLM,JTR,FACTR)
|
||||
c
|
||||
c Calculate inelastic cross sections and spin observables.
|
||||
c
|
||||
c D Final state amplitudes
|
||||
c PLM Legendre polynomial storage
|
||||
c JTR 2*J_transfer
|
||||
c Factr Normalization factor from BDWUCK4
|
||||
c***********************************************************************
|
||||
c
|
||||
parameter( ispc0 = 4010, ispc1 = 8000, ispc2 = 8000)
|
||||
implicit real*8(a-h,o-z)
|
||||
parameter(pi = 3.14159265, NX = 200, npol = 10)
|
||||
double complex D(*), SUM1, SUM(1000)
|
||||
logical i_open20, i_out20, i_20flag
|
||||
c
|
||||
COMMON ALPHA(15),IDAT(6),ICON(20),ANGLE(5),HBARC,AMU,AMASS,CHSQ,AA
|
||||
1,DRF,Z(3),ZA(3),FM(3),FMA(3),RC(3),AC(3),PNLOC(3),FS(3),ECM(3)
|
||||
2,FK(3),FK2(3),ETA(3),DR(3),FMU(3),FN,FL,FJ2,FSS,VCE,FNRNG,RSIG(2)
|
||||
3,K,KZ,LPLUS,LPL2,IS(3),NS(3),NLTR,LTRT(8),JTRT(8),ISTRT(8),IBF(8)
|
||||
4,KC,IBUFF,IWORD,ILINE,JLINE
|
||||
Common/array2/Space2(ispc2)
|
||||
c
|
||||
DIMENSION PLM(1000), Polz(npol)
|
||||
DIMENSION Sigplt(NX), Asyplt(NX)
|
||||
EQUIVALENCE (Space2(1), SUM(1)), (Space2(3601), Sigplt(1))
|
||||
1 , (Space2(3601+NX), Asyplt(1))
|
||||
2 , (ANGLE(1), THETAN),(ANGLE(2), THETA1)
|
||||
3 , (ANGLE(3), DTHETA), (SIG, Polz(1))
|
||||
data i_20flag / .true. /
|
||||
C
|
||||
if(icon(17) .eq. 2 .or. icon(17) .eq. 3) then
|
||||
i_out20 = .true.
|
||||
if(i_20flag) then
|
||||
i_open20 = .true.
|
||||
endif
|
||||
i_20flag = .false.
|
||||
else
|
||||
i_open20 = .false.
|
||||
i_out20 = .false.
|
||||
endif
|
||||
NTHETA=THETAN
|
||||
NTHETA = min0(NTHETA, NX)
|
||||
asymax=0.0
|
||||
JR=NS(1)
|
||||
JS=NS(2)
|
||||
if(is(1).eq.2.and.fm(1).eq.0.0) then
|
||||
c initial state average factor for Gamma ray
|
||||
FACTR=sqrt(FACTR*3.0/2.0)
|
||||
else
|
||||
FACTA=sqrt(FACTR)
|
||||
endif
|
||||
c
|
||||
M2K=(1.0-PHASEF(IS(3)))/2.0
|
||||
NPLUS=(JTR+IS(1)+IS(2))/2+1
|
||||
MPLUS=JTR/2+1
|
||||
IFACT = MPLUS*JR*JS
|
||||
WRITE(6,9000)
|
||||
IF(NTHETA.EQ.0) GO TO 230
|
||||
TotSig=0.0
|
||||
c
|
||||
THETA=THETA1
|
||||
DO 120 NTH=1,NTHETA
|
||||
CALL LGNDR(PLM,NPLUS,LPLUS,THETA)
|
||||
c
|
||||
Index1 = JS*JR*((JTR+1)/2)
|
||||
Index2 = Index1 + 1
|
||||
DO 100 M=1,MPLUS
|
||||
M2 = 2*(M-1)+M2K
|
||||
KT=M
|
||||
IS1=-IS(1)
|
||||
c Loop for initial spin substates
|
||||
DO 70 I=1,JR
|
||||
IS2=-IS(2)
|
||||
c Loop for final spin substates
|
||||
DO 60 J=1,JS
|
||||
ML=-(M2+IS2-IS1)/2
|
||||
PHAS1 = 1.0
|
||||
IF(ML .lt. 0) PHAS1 = PHASEF(ML)
|
||||
PHAS2 = 1.0
|
||||
IF(ML .gt. 0) PHAS2 = PHASEF(ML)
|
||||
ML1 = IABS(ML)*LPLUS
|
||||
SUM1=0.0
|
||||
c
|
||||
IND=KT
|
||||
DO 40 LL=1,LPLUS
|
||||
ML1 =ML1 +1
|
||||
SUM1 = SUM1+D(IND)*PLM(ML1)
|
||||
C
|
||||
C CALCULATE TOTAL INELASTIC SIGMA
|
||||
C
|
||||
IF(NTH .eq. 1) THEN
|
||||
L=LL-1
|
||||
ML = iabs(ML)
|
||||
if(ML.le.L) then
|
||||
FACT = conjg(D(IND))*D(IND)*YXFCT(L-ML,L+ML)/FLOAT(2*L+1)
|
||||
IF(M2 .NE. 0) FACT=FACT*2.0
|
||||
TotSig=TotSig+FACT
|
||||
endif
|
||||
ENDIF
|
||||
IND=IND+IFACT
|
||||
40 CONTINUE
|
||||
index1 = index1+1
|
||||
SUM(index1) = SUM1*PHAS1 *FACTA
|
||||
if(M2 .ne. 0) then
|
||||
index2 = index2-1
|
||||
SUM(index2) = SUM1*PHAS2 *FACTA
|
||||
endif
|
||||
c if(nth.eq.2) write(*,'(a,4i3, 1p4e12.4)')
|
||||
c 1 ' Is2,Is1 M, ML :',is2,is1,M,ML,SUM(Index1),SUM(Index2)
|
||||
KT = KT+MPLUS
|
||||
IS2=IS2+2
|
||||
60 CONTINUE
|
||||
IS1=IS1+2
|
||||
70 CONTINUE
|
||||
c
|
||||
100 CONTINUE
|
||||
c
|
||||
Maxi = JTR + 1
|
||||
Max1 = 1
|
||||
CALL POLFCT(Max1,Maxi,JR,JS,Theta,Polz,SUM
|
||||
1 ,i_open20,i_out20,nth,ntheta,ALPHA,IDAT)
|
||||
c
|
||||
WRITE(6,9001)THETA,(Polz(I), I=1,10),THETA
|
||||
SIGPLT(NTH)=SIG
|
||||
ASYPLT(NTH)=Polz(3)
|
||||
asymax=max(asymax,abs(asyplt(nth)))
|
||||
THETA=THETA+DTHETA
|
||||
120 CONTINUE
|
||||
c
|
||||
TotSig =TotSig *4.0*pi*FACTA**2/float(JR)
|
||||
WRITE(6,9002)TotSig
|
||||
c
|
||||
IF(ICON(13).ne.0) then
|
||||
WRITE(7,9011)ALPHA
|
||||
WRITE(7,9010)(SIGPLT(N),N=1,NTHETA)
|
||||
ENDIF
|
||||
IF(ICON(9).NE.0) then
|
||||
NTH=NTHETA
|
||||
WRITE(6,9011)ALPHA,(IDAT(I),I=1,3)
|
||||
CALL DWPLOT(NTH,ICON(9),SIGPLT,DTHETA,THETA1)
|
||||
NTEMP=-10
|
||||
if(IS(1).NE.0.and.asymax.gt.0.05) then
|
||||
WRITE(6,9013)ALPHA,(IDAT(I),I=1,3)
|
||||
CALL DWPLOT(NTH,NTEMP ,ASYPLT,DTHETA,THETA1)
|
||||
endif
|
||||
ENDIF
|
||||
230 continue
|
||||
RETURN
|
||||
c
|
||||
9000 FORMAT('0 Theta',' Inelsig,fm**2'
|
||||
1, ' Polz',' Asy',' Ayy'
|
||||
2, ' A22',' A21',' A20'
|
||||
3, ' T22',' T21',' T20'
|
||||
4, ' Theta')
|
||||
9001 FORMAT(0PF7.2,1PE14.4,0P9F10.4,0PF7.2)
|
||||
9002 FORMAT('0Tot-sig',1PE13.4)
|
||||
9010 FORMAT(1PE10.4,5(4X,1PE10.4))
|
||||
9011 FORMAT('1Inelastic ',15A4,I4,2(1H/,I2.2),I4,2(1H.,I2.2))
|
||||
9013 FORMAT('1Asymmetry ',15A4,I4,2(1H/,I2.2),I4,2(1H.,I2.2))
|
||||
END
|
||||
|
||||
18
dwuck4/CompileAndTest.sh
Executable file
18
dwuck4/CompileAndTest.sh
Executable file
|
|
@ -0,0 +1,18 @@
|
|||
#added --std=legacy to obviate awkward compilation error in ADWCK.FOR caused by FORTRAN being a messy little goblin
|
||||
|
||||
gfortran --std=legacy -c *.FOR
|
||||
gfortran -c DW4UNIX.F
|
||||
|
||||
cd culib4
|
||||
|
||||
gfortran --std=legacy -c *.FOR
|
||||
|
||||
cd ../culib8
|
||||
|
||||
gfortran --std=legacy -c *.FOR
|
||||
|
||||
cd ..
|
||||
|
||||
gfortran *.o culib8/*.o -o DWUCK4
|
||||
|
||||
./DWUCK4 < DW4TST.DAT
|
||||
133
dwuck4/DW4TST.DAT
Normal file
133
dwuck4/DW4TST.DAT
Normal file
|
|
@ -0,0 +1,133 @@
|
|||
1001000030000000 CA40(D,P)CA41 G.S. LZR WITH PROTON SPIN ORBIT
|
||||
+37. +00. +05.
|
||||
+15+01+03+07
|
||||
+00.10 +12.
|
||||
+13.70 +02. +01. +40. +20. +01.40 +02.
|
||||
+01. -97.40 +01.112 +00.875 +01.562 +00.477
|
||||
-02. +01.112 +00.875 +70.00 +01.562 +00.477
|
||||
+06.141 +01. +01. +41. +20. +01.25 +01.
|
||||
+01. -49.47 +01.18 +00.70 +24.2 +01.180 +00.700
|
||||
-02. +01.18 +00.70 +19.80 +01.252 +00.750
|
||||
-08.364 +01. +00. +40. +20. +01.25 +01.
|
||||
-01. -01. +01.18 +00.70 +25.
|
||||
+00. +03. +07. +01. +58.
|
||||
1001000030100000 ZR91 (D,HE3) Y90 28 MEV. P3/2 HULTHEN FR CORR
|
||||
+55. +00. +01.6667
|
||||
+20+01+01+02
|
||||
+00.1 +00. +18. +00.77 +90.
|
||||
+28. +02. +01. +91. +40. +01.30
|
||||
+02. +00. +01.10 +00.80 +00. +49.9 +01.27 +00.844 +00.
|
||||
-01. -100. +01.10 +00.80 +00. +00. +01.27 +00.844 +00.
|
||||
-03.21 +03. +02. +90. +39. +01.40
|
||||
-01. -170. +01.14 +00.75 +00. -18. +01.60 +00.80 +00.
|
||||
-08.71 +01. +01. +90. +39. +01.25
|
||||
-01. -01. +01.25 +00.70 +18.
|
||||
+01. +01. +03. +01. +56.77
|
||||
1212000030000000 TEST OF OPTIONS 1 AND 6 IN CATHEN
|
||||
+55. +00. +03.3334
|
||||
+15+02+00+00
|
||||
+00.1 +00. +15.
|
||||
+27. +01. +01. +56. +26. +01.25
|
||||
+01. -50. +01.25 +00.65 +00. +00. +01.25 +00.47 +00.
|
||||
-02. +00. +01.25 +00.65 +00. +40. +01.25 +00.47 +00.
|
||||
+00. +01. +01. +56. +26. +01.25
|
||||
+01. -50. +01.25 +00.65 +00. +00. +01.25 +00.47 +00.
|
||||
-02. +00. +01.25 +00.65 +00. +40. +01.25 +00.47 +00.
|
||||
-01. +01. +08.00 +40.0744
|
||||
-08. +01. +00. +56. +26. +01.25
|
||||
-01. -01. +01.25 +00.65 +25.
|
||||
+01. +01. +03. +01. +55.
|
||||
-01. +06. +00.00 +01.
|
||||
-08. +01. +00. +56. +26. +01.25
|
||||
-01. -01. +01.25 +00.65 +25.
|
||||
+01. +01. +03. +01. +55.
|
||||
1011000030000000 FE56(P,P)FE56* L=3- SPIN ORBIT = OPTION 4
|
||||
+37.0000+00.0000+05.0000
|
||||
+15+02+03+03
|
||||
+00.1000+00.0000+15.0000
|
||||
+22.5000+01.0078+01.0000+56.0000+26.0000+01.2500+00.0000+00.0000+01.0000
|
||||
+04. -28.2 +01.25 +00.735 +00. +00. +01.25 +00.735 +00.
|
||||
+01.0000-46.3800+01.2500+00.7350+00. +00.0000+01.2500+00.7350+00.0000
|
||||
-02.0000+00.0000+01.2500+00.4370+00.0000+61.4000+01.2500+00.4370+00.0000
|
||||
-04.4999+01.0078+01.0000+56.0000+26.0000+01.2500+00.0000+00.0000+01.0000
|
||||
+04. -28.2 +01.25 +00.735 +00. +00. +01.25 +00.735 +00.
|
||||
+01.0000-46.3800+01.2500+00.7350+00. +00.0000+01.2500+00.7350+00.0000
|
||||
-02.0000+00.0000+01.2500+00.4370+00.0000+61.4000+01.2500+00.4370+00.0000
|
||||
+00.0000+01.0000+00.0000+56.0000+26.0000+01.2500+00.0000+00.0000+00.0000
|
||||
+02.0000-46.3800+01.2500+00.7350+00. +00.0000+01.2500+00.7350+00.0000
|
||||
-03.0000+00.0000+01.2500+00.4370+00.0000+61.4000+01.2500+00.4370+00.0000
|
||||
+00.0000+01.0000+00.0000+56.0000+26.0000+01.2500+00.0000+00.0000+00.0000
|
||||
+11.0000-46.3800+01.2500+00.7350+00. +00.0000+01.2500+00.7350+00.0000
|
||||
+00.10 +03.
|
||||
-12.0000+00.0000+01.2500+00.4370+00.0000+61.4000+01.2500+00.4370+00.0000
|
||||
+00.10 +03.
|
||||
1222000030000000 FE54(HE3,T)CO54 EX= 1.82 1+,LTR=0,2 COHERENT SUM
|
||||
+55. +00. +01.6667
|
||||
+25+02+00+02+02+02
|
||||
+00.1 +00. +15. +00. +00.
|
||||
+37.7 +03. +02. +54. +26. +01.4 +00. +00. +01.
|
||||
-01. -170.6 +01.143 +00.721 +00. -18.5 +01.599 +00.829 +00.
|
||||
-10.071 +03. +01. +54. +27. +01.4 +00. +00. +01.
|
||||
-01. -170.6 +01.143 +00.721 +00. -18.5 +01.599 +00.829 +00.
|
||||
+02. +03. +00.7 +10. +07. +00. +02.
|
||||
-13.6 +01. +00. +54. +26. +01.25 +00. +00. +02.
|
||||
-01. -01. +01.25 +00.65 +25.
|
||||
+00. +03. +07. +01. +52.
|
||||
-04. +01. +01. +54. +26. +01.25 +00. +00. +02.
|
||||
-01. -01. +01.25 +00.65 +25.
|
||||
+00. +03. +07. +01. +52.
|
||||
-02. -01. +00.7 +10. +07. +00. +02.
|
||||
+02. +03. +00.7 +10. +07. +00. +02.
|
||||
-13.6 +01. +00. +54. +26. +01.25 +00. +00. +02.
|
||||
-01. -01. +01.25 +00.65 +25.
|
||||
+00. +03. +07. +01. +52.
|
||||
-04. +01. +01. +54. +26. +01.25 +00. +00. +02.
|
||||
-01. -01. +01.25 +00.65 +25.
|
||||
+00. +03. +07. +01. +52.
|
||||
-02. -01. +00.7 +10. +07. +00. +02.
|
||||
1202000030000000 CA40(T,P) 0+ 10.1 MEV ZR-TNT BAYMAN CASE
|
||||
+55. +00. +03.3334
|
||||
+20+01+00+00
|
||||
+00.10 -16.00
|
||||
+10.10 +03.016 +01. +40. +20. +01.24 +00.00 +00.
|
||||
-01. -144. +01.24 +00.678 +00. -30. +01.45 +00.841 +00.
|
||||
+11.35 +01.008 +01. +42. +20. +01.30 +00.00 +00.
|
||||
+01. -53. +01.25 +00.65 +00. +00. +01.25 +00.47 +00.
|
||||
-02. +00. +01.25 +00.65 +00. +62.00 +01.25 +00.47 +00.
|
||||
-01. +05. +00. +03.118
|
||||
-09.90 +01.008 +00. +40. +20. +01.25
|
||||
-01. -01. +01.25 +00.65 +25.
|
||||
+01. +01. +03. +01. +55.
|
||||
1202000030000000 TI50(P,T)TI48 0+ 19 MEV .95(F7/2)**2+ .31(P3/2)**2
|
||||
+55. +00. +01.6667
|
||||
+20+01+00+00
|
||||
+00.1 +00. +15. +00.
|
||||
+19. +01. +01. +50. +22. +01.25 +01.
|
||||
+04. -24. +00.98 +00.75 +00.
|
||||
+01. -54.6 +01.12 +00.78 +00. -03.2 +01.32 +00.568 +00.
|
||||
-02. +00. +01.12 +00.78 +00. +24. +01.32 +00.568 +00.
|
||||
-10.61 +03. +01. +48. +22. +01.3 +01.
|
||||
-01. -165.4 +01.16 +00.752 +00. -16.4 +01.498 +00.817 +00.
|
||||
+01. +05. +00. +00.95
|
||||
-09.55 +01. +00. +48. +22. +01.25
|
||||
-01. -01. +01.25 +00.65 +25.
|
||||
+00. +03. +07. +01. +55.
|
||||
-01. +05. +00. +00.31
|
||||
-09.55 +01. +00. +48. +22. +01.25
|
||||
-01. -01. +01.25 +00.65 +25.
|
||||
+01. +01. +03. +01. +55.
|
||||
1011000030000000 O16(D,P)O17 D3/2+ UNBOUND STRIPPPING RMAX= 15 FM
|
||||
+55. +00. +03.3334
|
||||
+16+01+02+03
|
||||
+00.10 +00. -15.
|
||||
+12. +02. +01. +16. +08. +01.25 +02.
|
||||
+01. -85.3 +01.25 +00.606 +00. +00. +00.958 +01.578 +00.
|
||||
-02. +00. +01.25 +00.606 +00. +51.00 +00.958 +01.578 +00.
|
||||
-03.17 +01. +01. +17. +08. +01.25 +00. +01.
|
||||
+01. -57.32 +01.25 +00.425 +00. +00. +01.207 +00.254 +00.
|
||||
-02. +00. +01.25 +00.425 +00. +30.80 +01.207 +00.254 +00.
|
||||
+00.933 +01. +00. +16. +08. +01.25 +01.
|
||||
-01. -01. +01.325 +00.50 +34.00
|
||||
+00. +02. +03. +01. +51.30 +00. +00.00
|
||||
9 END OF DATA DWUCK4 test cases
|
||||
|
||||
127
dwuck4/DW4UNIX.F
Normal file
127
dwuck4/DW4UNIX.F
Normal file
|
|
@ -0,0 +1,127 @@
|
|||
SUBROUTINE DW4UNIX(IDAT,ifirst)
|
||||
DIMENSION IDAT(8)
|
||||
C
|
||||
if(ifirst.eq.0) then
|
||||
OPEN(UNIT=2,STATUS='SCRATCH',FORM='UNFORMATTED')
|
||||
OPEN(UNIT=4,STATUS='SCRATCH',FORM='UNFORMATTED')
|
||||
C
|
||||
CALL unixfile(5,6,'DWUCK4 AT YOUR SERVICE')
|
||||
endif
|
||||
C
|
||||
CALL unixDAT(IDAT)
|
||||
C
|
||||
RETURN
|
||||
END
|
||||
C
|
||||
C SUBROUTINE UNIXFILE (INPUT, IOUTPUT, TITLE)
|
||||
C
|
||||
C @(#)sunfile.f 1.2 90/05/30 10:38:37 J.J.A. Zalmstra
|
||||
C
|
||||
C This subroutine will determine the files associated with STDIN(= unit 5)
|
||||
C and STDOUT (= unit 6) and print a two line title block to STDOUT
|
||||
C
|
||||
C
|
||||
SUBROUTINE UNIXFILE (INPUT, IOUTPUT, TITLE)
|
||||
CHARACTER*(*) TITLE
|
||||
C
|
||||
integer getcwd
|
||||
character*40 instdat, fdate
|
||||
character*40 infile, outfile
|
||||
character*40 user
|
||||
character*40 cwd
|
||||
character*256 arg
|
||||
parameter (instdat = 'Mon May 21 11:05:50 1990 ')
|
||||
|
||||
infile = 'Standard Input'
|
||||
outfile= 'Standard Output'
|
||||
user = 'unknown'
|
||||
cwd = 'unknown'
|
||||
c
|
||||
c Determine the user
|
||||
c
|
||||
call getenv('USER',arg)
|
||||
if(lnblnk(arg) .ne. 0) user = arg
|
||||
|
||||
c
|
||||
c We have read all flags and must now check for input and/or
|
||||
c outputfilename. 'arg' contains the argument to check, unless
|
||||
c there are no arguments at all.
|
||||
c
|
||||
nargs = iargc()
|
||||
if(nargs .gt. 0) then
|
||||
call getarg(1,arg)
|
||||
if(arg(1:1) .ne. '-') then
|
||||
open(input,file=arg,err=99)
|
||||
call ltrunc(arg, infile, 40)
|
||||
rewind input
|
||||
endif
|
||||
endif
|
||||
if(nargs .gt. 1) then
|
||||
call getarg(2, arg)
|
||||
open(ioutput,file=arg,err=99)
|
||||
rewind ioutput
|
||||
call ltrunc(arg, outfile, 40)
|
||||
endif
|
||||
c
|
||||
c Print title page
|
||||
c
|
||||
write(6,1020) title,instdat,fdate()
|
||||
if(getcwd(arg) .eq. 0) then
|
||||
call ltrunc(arg, cwd, 40)
|
||||
else
|
||||
write(0,*)'Cannot get current directory name'
|
||||
endif
|
||||
write(ioutput,1030)user,cwd,infile,outfile
|
||||
return
|
||||
|
||||
|
||||
99 write(0,1010)arg
|
||||
stop
|
||||
1010 format('Cannot open file ',a)
|
||||
1020 format(1h1,20(1h*),A,20(1h*)//
|
||||
+ ' installed',t20,a,/,' today is ',t20,a,
|
||||
+ 20(/))
|
||||
1030 format(20x,55(1h*)/20x,1h*,t75,1h*/
|
||||
+ 20x,1h*,' User : ',a40,t75,1h*/
|
||||
+ 20x,1h*,' Directory: ',a40,t75,1h*/
|
||||
+ 20x,1h*,' Input : ',a40,t75,1h*/
|
||||
+ 20x,1h*,' Output : ',a40,t75,1h*/
|
||||
+ 20x,1h*,t75,1h*,/20x,55(1h*)/1h1)
|
||||
end
|
||||
|
||||
|
||||
subroutine ltrunc(src, dest, maxlen)
|
||||
c
|
||||
c copy src to dest but truncate from the left if
|
||||
c the length of src exceeds maxlen
|
||||
c
|
||||
character*(*) src, dest
|
||||
|
||||
istart = 1
|
||||
iend = lnblnk(src)
|
||||
if(iend .gt. maxlen) then
|
||||
istart = iend - maxlen - 3
|
||||
dest(1:2) = '<-'
|
||||
dest(3:maxlen) = src(istart:iend)
|
||||
else
|
||||
dest = src(istart:iend)
|
||||
endif
|
||||
return
|
||||
end
|
||||
|
||||
SUBROUTINE unixDAT(IDAT)
|
||||
DIMENSION IDAT(8)
|
||||
C
|
||||
CALL date_and_time(VALUES = IDAT)
|
||||
c
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE SECOND(TIME)
|
||||
C THIS SUBROUTINE INTERFACES THE SUN SECONDS ROUTINE
|
||||
C TO THE SECONDS CALL IN THE PROGRAMS
|
||||
c implicit real*8 time
|
||||
real tarray(2), time
|
||||
time = etime(tarray)
|
||||
RETURN
|
||||
END
|
||||
BIN
dwuck4/DWUCK4
Executable file
BIN
dwuck4/DWUCK4
Executable file
Binary file not shown.
99
dwuck4/DWUCK4.FOR
Normal file
99
dwuck4/DWUCK4.FOR
Normal file
|
|
@ -0,0 +1,99 @@
|
|||
c$debug
|
||||
c***********************************************************************
|
||||
PROGRAM DWUCK4
|
||||
c
|
||||
c Main program, calls ADWCK4 and BDWCK4
|
||||
c
|
||||
c***********************************************************************
|
||||
c
|
||||
parameter(ispc0 = 4010, ispc1 = 8000, ispc2 = 8000)
|
||||
IMPLICIT REAL*8(A-H,O-Z)
|
||||
COMMON ALPHA(15),IDAT(6),ICON(20),ANGLE(5),HBARC,AMU,AMASS,CHSQ,AA
|
||||
1,DRF,Z(3),ZA(3),FM(3),FMA(3),RC(3),AC(3),PNLOC(3),FS(3),ECM(3)
|
||||
2,FK(3),FK2(3),ETA(3),DR(3),FMU(3),FN,FL,FJ2,FSS,VCE,FNRNG,RSIG(2)
|
||||
3,K,KZ,LPLUS,LPL2,IS(3),NS(3),NLTR,LTRT(8),JTRT(8),ISTRT(8),IBF(8)
|
||||
4,KC,IBUFF,IWORD,ILINE,JLINE
|
||||
Common/array0/space0(ispc0)
|
||||
Common/array1/space1(ispc1)
|
||||
Common/array2/space2(ispc2)
|
||||
C
|
||||
C STORE STANDARD ANGLE DATA
|
||||
C
|
||||
ANGLE(1)=37.0
|
||||
ANGLE(2)=0.0
|
||||
ANGLE(3)=5.0
|
||||
c Store fundamental constants
|
||||
HBARC=197.327
|
||||
AMU=931.495
|
||||
FSCON=137.036
|
||||
CHSQ=HBARC/FSCON
|
||||
IBUFF=3200
|
||||
IFIRST=0
|
||||
C
|
||||
1001 CONTINUE
|
||||
CALL DW4unix (IDAT,IFIRST)
|
||||
C CALL DW4Vax (IDAT,IFIRST)
|
||||
C CALL DW4unix(IDAT,IFIRST)
|
||||
C CALL DW4ibm (IDAT,IFIRST)
|
||||
WRITE(6,9999)IFIRST
|
||||
call cpu_time(time)
|
||||
write(*,9900)time
|
||||
write(6,9900)time
|
||||
ifirst = 1
|
||||
ibf(3) = 0
|
||||
C
|
||||
C TAPE 2 STORES RADIAL INTEGRALS
|
||||
REWIND 2
|
||||
C
|
||||
C TAPE 4 STORES DISTORTED WAVES
|
||||
REWIND 4
|
||||
C
|
||||
|
||||
C READ CARD SET 1
|
||||
|
||||
WRITE(6,9502)
|
||||
WRITE(6,9804)IDAT
|
||||
c
|
||||
c icon Control integers
|
||||
c alpha Alphanumeric run identification
|
||||
c
|
||||
icon(1) = 9
|
||||
READ (5,9802,END=2)ICON,ALPHA
|
||||
WRITE(6,9803)ICON,ALPHA
|
||||
2 continue
|
||||
IF(ICON(1).eq.9) then
|
||||
c
|
||||
c close up shop
|
||||
c
|
||||
close (2)
|
||||
close (4)
|
||||
close (5)
|
||||
close (6)
|
||||
STOP ' End of data'
|
||||
endif
|
||||
C
|
||||
C DIVISION FOR OVERLAY MAY BE MADE 1-ADWUCK4, 2-BDWUCK4
|
||||
C
|
||||
write(*,'('' '',15a4)')alpha
|
||||
call cpu_time(time)
|
||||
write(*,'(a)') ' Adwck4 entered'
|
||||
CALL ADWUCK4
|
||||
C CALL OVERLAY(FNAME,1,0)
|
||||
IF(IBF(3).EQ.0) then
|
||||
call cpu_time(time)
|
||||
write(*,'(a)') ' Bdwck4 entered'
|
||||
CALL BDWUCK4
|
||||
C CALL OVERLAY(FNAME,2,0)
|
||||
endif
|
||||
GO TO 1001
|
||||
c
|
||||
9502 FORMAT('0CONTROL INTEGERS')
|
||||
9802 FORMAT(20I1,15A4)
|
||||
9803 FORMAT(1H ,20I2,4X,15A4)
|
||||
9804 FORMAT(' 1 2 3 4 5 6 7 8 9 A B C D E F G H I J K'
|
||||
1, ' RUN IDENTIFICATION ',40X
|
||||
2 ,I4,2(1H/,I2.2),I4,2(1H.,I2.2))
|
||||
9900 format(' Elapsed time in seconds =',f7.2)
|
||||
9999 FORMAT(I1,'DWUCK4-DISTORTED WAVES U.COLORADO- PC-VERSION'
|
||||
1,' 12/Jan /1995' )
|
||||
END
|
||||
250
dwuck4/culib4/ANGMOM.FOR
Normal file
250
dwuck4/culib4/ANGMOM.FOR
Normal file
|
|
@ -0,0 +1,250 @@
|
|||
|
||||
c***********************************************************************
|
||||
FUNCTION VCC(JX1,JX2,JX3,MX1,MX2)
|
||||
c
|
||||
c Clebsch-Gordan Coefficient Routine
|
||||
c
|
||||
c***********************************************************************
|
||||
C IMPLICIT REAL*8(A-H,O-Z)
|
||||
c EXTERNAL FACTOR
|
||||
COMMON/FACTRL/FACT(0:32)
|
||||
C
|
||||
VCC=0.0
|
||||
J1=JX1
|
||||
J2=JX2
|
||||
J3=JX3
|
||||
M1=MX1
|
||||
M2=MX2
|
||||
IF(J1.LT.J2) GO TO 20
|
||||
IF(J3.LT.J2) GO TO 30
|
||||
ICNTR=0
|
||||
GO TO 40
|
||||
20 IF(J3.LT.J1) GO TO 30
|
||||
ICNTR=-1
|
||||
IT=J1
|
||||
J1=J2
|
||||
J2=IT
|
||||
IT=M1
|
||||
M1=M2
|
||||
M2=IT
|
||||
GO TO 40
|
||||
30 ICNTR=1
|
||||
IT=J2
|
||||
J2=J3
|
||||
J3=IT
|
||||
M2=-M1-M2
|
||||
40 CONTINUE
|
||||
JZ1=(J1+J2-J3)/2
|
||||
IF(JZ1.LT.0) GO TO 150
|
||||
JZ2=(J1+J3-J2)/2
|
||||
IF(JZ2.LT.0) GO TO 150
|
||||
JZ3=(J2+J3-J1)/2
|
||||
IF(JZ3.LT.0) GO TO 150
|
||||
IF(J1-IABS(M1).LT.0) GO TO 150
|
||||
IF(J2-IABS(M2).LT.0) GO TO 150
|
||||
IF(J3-IABS(M1+M2).LT.0) GO TO 150
|
||||
JT1=(J1-J3+M2)/2
|
||||
JT2=(J2-J3-M1)/2
|
||||
NUMIN=MAX0 (JT1,JT2,0)
|
||||
JT3=(J1-M1)/2
|
||||
JT4=(J2+M2)/2
|
||||
NUMAX=MIN0 (JT3,JT4,JZ1)
|
||||
JT5=(J2-M2)/2
|
||||
IF(NUMAX.LT.NUMIN) GO TO 150
|
||||
J4=J1/2
|
||||
J5=J3/2
|
||||
PHAS=PHASEF(NUMIN)
|
||||
DO 100 NU=NUMIN,NUMAX
|
||||
VCC=VCC+PHAS *(YXFCT(JT3-NU,J4)*YXFCT(NU-JT2,J5))
|
||||
1/(FACT(JT4-NU)*FACT(NU-JT1)*FACT(JZ1-NU)*FACT(NU))
|
||||
PHAS=-PHAS
|
||||
100 CONTINUE
|
||||
FCTOR=YXFCT(J4,(J1+M1)/2)*YXFCT(J4,JT3)*YXFCT((J1+J2+J3)/2+1,JZ2)*
|
||||
1YXFCT(J5,(J3+M1+M2)/2)*YXFCT(J5,(J3-M1-M2)/2)*FACT(JZ1)*FACT(JZ3)*
|
||||
2FACT(JT4)*FACT(JT5)*FLOAT(J3+1)
|
||||
VCC=SQRT(FCTOR)*VCC
|
||||
IF(ICNTR)120,150,110
|
||||
110 VCC=VCC*SQRT(FLOAT(J2+1)/FLOAT(J3+1))*PHASEF(JT3)
|
||||
GO TO 150
|
||||
120 VCC=VCC*PHASEF(JZ1)
|
||||
150 RETURN
|
||||
END
|
||||
|
||||
c***********************************************************************
|
||||
FUNCTION PHASEF(N)
|
||||
c
|
||||
c Calculates (-1)**N
|
||||
c
|
||||
c***********************************************************************
|
||||
c IMPLICIT REAL*8(A-H,O-Z)
|
||||
c
|
||||
PHASEF=FLOAT(1-2*IABS(N-2*(N/2)))
|
||||
RETURN
|
||||
END
|
||||
|
||||
c***********************************************************************
|
||||
FUNCTION YXFCT(M,N)
|
||||
c
|
||||
C COMPUTES N_FACTORIAL/M_FACTORIAL
|
||||
c
|
||||
c***********************************************************************
|
||||
c IMPLICIT REAL*8(A-H,O-Z)
|
||||
c
|
||||
YXFCT=1.0
|
||||
NUMAX=M-N
|
||||
IF(NUMAX)30,100,20
|
||||
20 ICTRL=0
|
||||
FCTOR=N
|
||||
GO TO 40
|
||||
30 ICTRL=1
|
||||
NUMAX=-NUMAX
|
||||
FCTOR=M
|
||||
40 CONTINUE
|
||||
DO 50 NU=1,NUMAX
|
||||
FCTOR=FCTOR+1.0
|
||||
YXFCT=YXFCT*FCTOR
|
||||
50 CONTINUE
|
||||
IF(ICTRL.EQ.0) YXFCT=1.0/YXFCT
|
||||
100 RETURN
|
||||
END
|
||||
|
||||
c***********************************************************************
|
||||
FUNCTION RACAH(J1,J2,J3,J4,J5,J6)
|
||||
c
|
||||
c Calculates Racah coefficients
|
||||
c Spins are input as twice the spin
|
||||
c
|
||||
c***********************************************************************
|
||||
c
|
||||
c IMPLICIT REAL*8(A-H,O-Z)
|
||||
logical jy_big
|
||||
c
|
||||
c EXTERNAL FACTOR
|
||||
COMMON/FACTRL/FACT(0:32)
|
||||
c
|
||||
RACAH=0.0
|
||||
Z1=DELR(J1,J2,J5)
|
||||
IF(Z1.EQ.0.0) GO TO 90
|
||||
Z1=DELR(J3,J4,J5)*Z1
|
||||
IF(Z1.EQ.0.0) GO TO 90
|
||||
Z2=DELR(J1,J3,J6)
|
||||
IF(Z2.EQ.0.0) GO TO 90
|
||||
Z2=DELR(J2,J4,J6)*Z2
|
||||
IF(Z2.EQ.0.0) GO TO 90
|
||||
Z1=SQRT(Z1/Z2)*Z2
|
||||
JT1=(J1+J2+J5)/2
|
||||
JT2=(J3+J4+J5)/2
|
||||
JT3=(J1+J3+J6)/2
|
||||
JT4=(J2+J4+J6)/2
|
||||
JZ1=(J1+J2+J3+J4)/2
|
||||
JZ2=(J1+J4+J5+J6)/2
|
||||
JZ3=(J2+J3+J5+J6)/2
|
||||
c
|
||||
NUMIN=MAX0 (JT1,JT2,JT3,JT4)
|
||||
NUMAX=MIN0 (JZ1,JZ2,JZ3)
|
||||
IF(NUMAX.ge.NUMIN) then
|
||||
if(NUMIN-JT4 .gt. JZ1-NUMIN) then
|
||||
jy_big = .true.
|
||||
else
|
||||
jy_big = .false.
|
||||
endif
|
||||
PHASE=PHASEF(NUMIN+JZ1)*Z1
|
||||
DO 80 NU=NUMIN,NUMAX
|
||||
JY1=NU-JT1
|
||||
JY2=NU-JT2
|
||||
JY3=NU-JT3
|
||||
JY4=NU-JT4
|
||||
JY5=JZ1-NU
|
||||
JY6=JZ2-NU
|
||||
JY7=JZ3-NU
|
||||
if(jy_big) then
|
||||
FACTR = YXFCT(JY4,NU+1)/FACT(JY5)
|
||||
else
|
||||
FACTR = YXFCT(JY5,NU+1)/FACT(JY4)
|
||||
endif
|
||||
RACAH=RACAH+PHASE*FACTR
|
||||
1 /(FACT(JY1)*FACT(JY2)*FACT(JY3)*FACT(JY6)*FACT(JY7))
|
||||
PHASE=-PHASE
|
||||
80 CONTINUE
|
||||
endif
|
||||
90 RETURN
|
||||
END
|
||||
|
||||
c***********************************************************************
|
||||
FUNCTION DELR(J1,J2,J3)
|
||||
c
|
||||
c Triangular function
|
||||
c Used by Racah Function
|
||||
c
|
||||
c***********************************************************************
|
||||
c IMPLICIT REAL*8(A-H,O-Z)
|
||||
EXTERNAL FACTOR
|
||||
COMMON/FACTRL/FACT(0:32)
|
||||
c
|
||||
JZ1=(J1+J2-J3)/2
|
||||
IF(JZ1.LT.0) GO TO 130
|
||||
JZ2=(J1-J2+J3)/2
|
||||
IF(JZ2.LT.0) GO TO 130
|
||||
JZ3=(J2+J3-J1)/2
|
||||
IF(JZ3.LT.0) GO TO 130
|
||||
JZ4=(J1+J2+J3)/2+1
|
||||
IF(JZ3.LT.JZ2) GO TO 80
|
||||
IF(JZ3.LT.JZ1) GO TO 70
|
||||
DELR=YXFCT(JZ4,JZ3)*FACT(JZ1)*FACT(JZ2)
|
||||
RETURN
|
||||
70 DELR=YXFCT(JZ4,JZ1)*FACT(JZ2)*FACT(JZ3)
|
||||
RETURN
|
||||
80 IF(JZ2.LT.JZ1) GO TO 70
|
||||
DELR=YXFCT(JZ4,JZ2)*FACT(JZ1)*FACT(JZ3)
|
||||
RETURN
|
||||
130 DELR=0.0
|
||||
RETURN
|
||||
END
|
||||
|
||||
c***********************************************************************
|
||||
FUNCTION WINEJ(J1,J2,J3,J4,J5,J6,J7,J8,J9)
|
||||
c
|
||||
c NineJ Symbol Function
|
||||
c
|
||||
c***********************************************************************
|
||||
c IMPLICIT REAL*8(A-H,O-Z)
|
||||
c
|
||||
WINEJ=0.0
|
||||
MUMIN=MAX0(IABS(J1-J9),IABS(J2-J6),IABS(J4-J8))
|
||||
MUMAX=MIN0(J1+J9,J2+J6,J4+J8)
|
||||
IF(MUMAX.LT.MUMIN) GO TO 40
|
||||
DO 20 MU=MUMIN,MUMAX,2
|
||||
PROD=RACAH(J1,J4,J9,J8,J7,MU)*RACAH(J2,J5,MU,J4,J8,J6)*
|
||||
1 RACAH(J9,MU,J3,J2,J1,J6)*FLOAT(MU+1)
|
||||
WINEJ=WINEJ+PROD
|
||||
20 CONTINUE
|
||||
WINEJ=WINEJ*PHASEF((J1+J3+J5+J8)/2+J2+J4+J9)
|
||||
40 RETURN
|
||||
END
|
||||
|
||||
BLOCK DATA FACTOR
|
||||
c
|
||||
c Factorial table
|
||||
c
|
||||
c IMPLICIT REAL*8(A-H,O-Z)
|
||||
COMMON/FACTRL/FACT(0:32)
|
||||
C
|
||||
DATA FACT/ 1.0000000000E+00, 1.0000000000E+00, 2.0000000000E+00
|
||||
1 , 6.0000000000E+00, 2.4000000000E+01, 1.2000000000E+02
|
||||
2 , 7.2000000000E+02, 5.0400000000E+03, 4.0320000000E+04
|
||||
3 , 3.6288000000E+05, 3.6288000000E+06, 3.9916800000E+07
|
||||
4 , 4.7900160000E+08, 6.2270208000E+09, 8.7178291200E+10
|
||||
5 , 1.3076743680E+12, 2.0922789888E+13, 3.5568742810E+14
|
||||
6 , 6.4023737057E+15, 1.2164510041E+17, 2.4329020082E+18
|
||||
7 , 5.1090942172E+19, 1.1240007278E+21, 2.5852016739E+22
|
||||
8 , 6.2044840173E+23, 1.5511210043E+25, 4.0329146113E+26
|
||||
9 , 1.0888869450E+28, 3.0488834461E+29, 8.8417619937E+30
|
||||
$ , 2.6525285981E+32, 8.2228386542E+33, 2.6313083693E+35/
|
||||
C $ , 8.6833176188D+36, 2.9523279904D+38, 1.0333147966D+40
|
||||
C $ , 3.7199332679D+41, 1.3763753091D+43, 5.2302261747D+44
|
||||
C $ , 2.0397882081D+46, 8.1591528325D+47, 3.3452526613D+49
|
||||
C $ , 1.4050061178D+51, 6.0415263063D+52, 2.6582715748D+54
|
||||
C $ , 1.1962222087D+56, 5.5026221598D+57, 2.5862324151D+59
|
||||
C $ , 1.2413915593D+61, 6.0828186403D+62, 3.0414093202D+64
|
||||
C $ , 1.5511187533D+66/
|
||||
END
|
||||
443
dwuck4/culib4/BIND.FOR
Normal file
443
dwuck4/culib4/BIND.FOR
Normal file
|
|
@ -0,0 +1,443 @@
|
|||
SUBROUTINE BIND(U,F,DR,RM,FNODE,FL,Kin,FK,ETA,V,E,FK2,ISW,IERR,D)
|
||||
C
|
||||
C U = POTENTIAL STORAGE
|
||||
C ODD = - SCALED PART OF V *(2M/HBAR**2)
|
||||
C EVEN = (ENERGY - NON SCALED PART OF V)*(2M/HBAR**2)
|
||||
C F = OUTPUTTED WAVE FUNCTION
|
||||
C DR = RADIAL INCREMENT
|
||||
C RM = MATCHING RADIUS, INPUT IS DEFAULT, OUTPUT IS VALUE USED
|
||||
C FNODE = NO. NODES IN WAVE FCT., EXCLUDING ORIGIN AND INFINITY
|
||||
C FL = ORBITAL ANGULAR MOMENTUM
|
||||
C Kin = MAX NO. OF POINTS + 2048*(MIN POINT)
|
||||
C FK = |WAVE NUMBER| E.G. SIN(FK*R) OR EXP(-FK*R)
|
||||
C ETA = COULOMB PARAMETER
|
||||
C V = SCALE FACTOR FOR ODD POTENTIAL VALUES
|
||||
C E = ENERGY
|
||||
C FK2 = E*(2*M/HBAR**2)
|
||||
C ISW = SEARCH SWITCH
|
||||
C 0 = SEARCH ON V
|
||||
C 1 = SEARCH ON E
|
||||
C 2 = NO SEARCH, FOR E>0 ONLY (PHASE SHIFT IS CALCULATED)
|
||||
C 3 = Search on V, box b.c.
|
||||
C 4 = Search on E. box b.c.
|
||||
C IERR = ERROR FLAG, IS SET IF ERROR OCCURS
|
||||
C D = LAST POINT DATA FOR UNBOUND STRIPPING
|
||||
C D(1),D(2) ARE REAL AND IMAG PARTS OF EXP(2I*DELTA)
|
||||
C D(3),D(4) ARE GL(RMAX) AND FL(RMAX)
|
||||
C D(5),D(6) are real and imaginary K**2
|
||||
C D(10) is ISW
|
||||
C
|
||||
c IMPLICIT REAL*8(A-H,O-Z)
|
||||
c
|
||||
parameter (Pi = 3.141592654)
|
||||
logical dplus,dminus,turnpt
|
||||
CHARACTER*2 A
|
||||
DIMENSION U(800),F(400),T(8),D(10)
|
||||
common /ch3files/input,ioutp
|
||||
DATA ICMAX/32/
|
||||
DATA DLAMY,DETX,dinterp,dlammax/.001,.01,0.1,0.3/
|
||||
DATA XFACT, ELOG10, ONE/0.707, 2.302585, 1.0/
|
||||
C
|
||||
C CHANGES TO ALLOW INTEGRATION OF HARD CORE POTENTIALS
|
||||
C THEY ARE KLUDGED TO ALLOW BACKWARD COMPATIBILITY
|
||||
C Kmin is initial point for hard core
|
||||
C
|
||||
if(ioutp .eq. 0) then
|
||||
ioutput = 6
|
||||
else
|
||||
ioutput = ioutp
|
||||
endif
|
||||
Kmin = Kin/2048
|
||||
Kmax = Kin-Kmin*2048
|
||||
Kmin=Kmin+1
|
||||
C
|
||||
CFACT=1.0
|
||||
dv=0.225*v
|
||||
v0=0.0
|
||||
v1=0.0
|
||||
d0 =-1.0e20
|
||||
d1 = 1.0e20
|
||||
dplus =.false.
|
||||
dminus=.false.
|
||||
IXNT=0
|
||||
IPRNT=0
|
||||
IF(IERR.LT.0) IPRNT=1
|
||||
IERR=0
|
||||
ICNT=ICMAX
|
||||
IF(ISW.EQ.2) ICNT=0
|
||||
FLP=FL*(FL+1.0)
|
||||
DR2=DR**2/12.0
|
||||
LL=FL+1.0
|
||||
ITER=0
|
||||
C
|
||||
C CALCULATE OUTER BOUNDARY CONDITION
|
||||
C
|
||||
10 CONTINUE
|
||||
RMAX=DR*FLOAT(Kmax)
|
||||
IF(FK2.GT.0.0) THEN
|
||||
C POSITIVE ENERGY BOUNDARY CONDITION
|
||||
IF(ISW.EQ.0.OR.ISW.EQ.1.OR.ISW.EQ.2) THEN
|
||||
c
|
||||
c get functions at Rmax - dr and Rmax
|
||||
c
|
||||
M=MAX0(LL+1,3)
|
||||
T(2)=FK*RMAX
|
||||
T(1)=T(2)-FK*DR
|
||||
CALL COU(T(1),T(2),ETA,M ,DR,F( 1),F(21),F(41),F(61),F(81))
|
||||
SCALE=ABS(F(LL+60))
|
||||
T(8)=F(LL+60)/SCALE
|
||||
T(7)=F(LL+40)/SCALE
|
||||
T(6)=F(LL+20)/SCALE
|
||||
T(5)=F(LL )/SCALE
|
||||
D(4)=F(LL+20)
|
||||
D(3)=F(LL+60)
|
||||
c
|
||||
c Calculate surface term for width
|
||||
c
|
||||
c calculate Surf = d(k*u'/u)/dk = (u'/u) +kR*[(u''/u) - (u'/u)**2]
|
||||
c
|
||||
c Ratio = (u'/u)
|
||||
c
|
||||
Ratio = (((FL+1.0)**2 + ETA)/t(2)
|
||||
1 - sqrt((FL+1.0)**2 + ETA**2)*F(LL+61)/F(LL+60))/(FL+1.0)
|
||||
Surf = ( (1. - T(2)*Ratio)*Ratio
|
||||
1 -T(2)*(1.0 - FL*(FL+1.0)/T(2)**2 - 2.0*ETA/T(2)))/(2.0*fk)
|
||||
c
|
||||
c write(ioutput,'(a,1p4e12.4)')' Surf =',Surf
|
||||
c
|
||||
ELSEIF(ISW.EQ.3.OR.ISW.EQ.4) THEN
|
||||
T(8)=0.0
|
||||
T(7)=1.0E-15
|
||||
SCALE=1.0
|
||||
ELSE
|
||||
IERR=1
|
||||
WRITE(ioutput,'(''0Illegal FISW parameter, ='',i3)')isw
|
||||
RETURN
|
||||
C
|
||||
ENDIF
|
||||
ELSE
|
||||
C NEGATIVE ENERGY BOUNDARY CONDITION
|
||||
IF(ISW.EQ.0.OR.ISW.EQ.1) THEN
|
||||
T(8)=1.0E-15
|
||||
T(7)=T(8)*EXP(FK*DR+ETA* LOG(1.0+DR/RMAX))
|
||||
SCALE=1.0
|
||||
C BOX BOUNDARY CONDITIONS
|
||||
ELSEIF(ISW.EQ.3.OR.ISW.EQ.4) THEN
|
||||
T(8)=0.0
|
||||
T(7)=1.0E-15
|
||||
SCALE=1.0
|
||||
ENDIF
|
||||
ENDIF
|
||||
40 CONTINUE
|
||||
width = 0.0
|
||||
fnorm0 = 0.5*t(8)**2 + t(7)**2
|
||||
F(Kmax )=T(8)
|
||||
F(Kmax-1)=T(7)
|
||||
RMAX=RMAX-DR
|
||||
K1 = Kmax-2
|
||||
turnpt=.true.
|
||||
KM=Kmax
|
||||
C
|
||||
C INTEGRATE FROM INFINITY TO TURNING POINT
|
||||
C
|
||||
50 continue
|
||||
R=RMAX
|
||||
FNCT=0.0
|
||||
IF(ISW.NE.2) THEN
|
||||
G5=U(2*Kmax-4)-FLP/R**2
|
||||
IF(G5.LT.0.0) THEN
|
||||
IFLAG=1
|
||||
ELSE
|
||||
IFLAG=0
|
||||
ENDIF
|
||||
Q6=1.0+DR2*(U(2*Kmax-2)-FLP/(R+DR)**2)
|
||||
Q5=1.0+DR2*G5
|
||||
F6=T(8)
|
||||
F5=T(7)
|
||||
W2=0.0
|
||||
FNORM2=fnorm0
|
||||
C
|
||||
DO 100 M=K1,Kmin,-1
|
||||
MM = M
|
||||
MK=2*M-1
|
||||
R=R-DR
|
||||
G4=U(MK+1)+V*U(MK )-FLP/R**2
|
||||
Q4=1.0+DR2*G4
|
||||
F4=((12.0-10.0*Q5)*F5-Q6*F6)/Q4
|
||||
Q6=Q5
|
||||
Q5=Q4
|
||||
G6=G5
|
||||
G5=G4
|
||||
if(f6*f5.lt.0.0) fnct=fnct+1.0
|
||||
F6=F5
|
||||
F5=F4
|
||||
F(M)=F4
|
||||
IF(G6*G5.LT.0.0) IFLAG=IFLAG+1
|
||||
if((.not.turnpt.and.f5.lt.f6).or.IFLAG.GE.2) GO TO 110
|
||||
FNORM2=FNORM2+F5**2
|
||||
W2=W2+U(MK+2)*F5**2
|
||||
100 CONTINUE
|
||||
C
|
||||
C If no classical turning point is found, then find first maximum,
|
||||
C then if none, use external matching radius.
|
||||
C
|
||||
if(turnpt) then
|
||||
turnpt=.false.
|
||||
go to 50
|
||||
else
|
||||
MM = INT(RM/DR)
|
||||
endif
|
||||
105 continue
|
||||
F5=F(MM )
|
||||
F6=F(MM+1)
|
||||
110 CONTINUE
|
||||
C
|
||||
C INTEGRATE FROM ORIGIN TO TURNING POINT
|
||||
C
|
||||
if(isw.lt.2) fnct = 0.0
|
||||
KM=MM+1
|
||||
120 CONTINUE
|
||||
ENDIF
|
||||
c End of (Isw ne. 2)
|
||||
KS=FL/3.3+2.0
|
||||
W1=0.0
|
||||
FNORM1=0.0
|
||||
F2=0.0
|
||||
Q2=0.0
|
||||
R =0.0
|
||||
C
|
||||
DO 200 M=Kmin,KM
|
||||
MK=M+M-1
|
||||
R=R+DR
|
||||
Q3=1.0+DR2*(U(MK+1)+V*U(MK )-FLP/R**2)
|
||||
IF(M.GT.KS) THEN
|
||||
F3=((12.0-10.0*Q2)*F2-Q1*F1)/Q3
|
||||
ELSE
|
||||
F3=R**LL
|
||||
ENDIF
|
||||
Q1=Q2
|
||||
Q2=Q3
|
||||
F1=F2
|
||||
F2=F3
|
||||
IF(ICNT.EQ.0) F(M)=F3
|
||||
FNORM1=FNORM1+F1**2
|
||||
W1=W1+U(MK)*F1**2
|
||||
C NODE COUNT
|
||||
IF(F1*F2.LT.0.0) FNCT=FNCT+1.0
|
||||
200 CONTINUE
|
||||
F12=(F1+F2)*0.5
|
||||
IF(F1*F2.lt.0.0.and.F12*F2.lt.0.0) FNCT=FNCT-1.0
|
||||
C
|
||||
FN=FNODE-FNCT
|
||||
IF(ISW.EQ.2) GO TO 500
|
||||
F56=(F5+F6)*0.5
|
||||
DET=(F1*F6-F5*F2)/(F12*F56*DR)
|
||||
FNORM1=FNORM1/F2**2
|
||||
FNORM2=FNORM2/F6**2
|
||||
FNORM=FNORM1+FNORM2
|
||||
ITER=ITER+1
|
||||
IF(ICNT.EQ.0) GO TO 500
|
||||
ICNT=ICNT-1
|
||||
IF(ICNT.EQ.0) THEN
|
||||
WRITE(ioutput,'(''0BOUND STATE SEARCH FAILS IN'',I3,
|
||||
1 '' ITERATIONS'')')ICMAX
|
||||
IERR=1
|
||||
ENDIF
|
||||
IF(ICNT.EQ.18) CFACT=CFACT*XFACT
|
||||
IF(ICNT.EQ.12) CFACT=CFACT*XFACT
|
||||
RM=(FLOAT(KM)-0.5)*DR
|
||||
IF((ISW.EQ.3.OR.ISW.EQ.4).AND.E.GT.0.0) THEN
|
||||
RSCALE=RMAX
|
||||
ELSE
|
||||
RSCALE=RM*1.5
|
||||
ENDIF
|
||||
ESCALE= ABS(((fnode+1.0)*3.0+fl)/(FK2*RSCALE**2))
|
||||
DLAMX =DLAMY*ESCALE
|
||||
vold=v
|
||||
eold=e
|
||||
IF(ISW.EQ.0.OR.ISW.EQ.3) THEN
|
||||
C
|
||||
C CHOOSE NEXT GUESS FOR WELL DEPTH
|
||||
C
|
||||
IF(FN.NE.0.0) THEN
|
||||
c Node count incorrect
|
||||
c dlam= 1.625*cfact*fn*escale
|
||||
dlam= (cfact*((fnode+0.5*fl+0.5)**2
|
||||
1 - (fnct+0.5*fl+0.5)**2) )
|
||||
if(dlam.lt.-abs(dv/v)) then
|
||||
dlam = abs(dv/v)*sign(one,dlam)
|
||||
else
|
||||
dlam = min(dlam,dlammax*sign(one,dlam))
|
||||
endif
|
||||
a='Vn'
|
||||
ELSE
|
||||
if(det.gt.0.0) then
|
||||
dplus =.true.
|
||||
if(det.lt.d1) then
|
||||
v1=v
|
||||
d1=det
|
||||
endif
|
||||
else
|
||||
dminus=.true.
|
||||
if(det.gt.d0) then
|
||||
v0=v
|
||||
d0=det
|
||||
endif
|
||||
endif
|
||||
IF(dplus.and.dminus.and.abs(det).gt.dinterp) THEN
|
||||
c Interpolation search
|
||||
if(abs(d1/d0).gt.5.0 .or. abs(d1/d0).lt.0.2) then
|
||||
DLAM = (v0+v1)/(2.0*v) - 1.0
|
||||
else
|
||||
DLAM = ((d1*v0-d0*v1)/((d1-d0)*v) - 1.0)
|
||||
endif
|
||||
a='Vi'
|
||||
ELSE
|
||||
c Variational search
|
||||
DLAM= -DET/(V*DR*(W1/F12**2+W2/F56**2))
|
||||
IF(ABS(DLAM).GT.dlammax) DLAM=SIGN(dlammax,DLAM)
|
||||
a='Vv'
|
||||
ENDIF
|
||||
IXNT=IXNT+1
|
||||
ENDIF
|
||||
flam=1.0+dlam
|
||||
V=V*FLAM
|
||||
DLAMX=DLAMY
|
||||
C
|
||||
C CHOOSE NEXT GUESS FOR BINDING ENERGY
|
||||
C
|
||||
ELSEIF(ISW.EQ.1.OR.ISW.EQ.4) THEN
|
||||
IF(FN.NE.0.0) THEN
|
||||
c Node count incorrect
|
||||
c DLAM= 1.625*cfact*fn*sign(escale,e)
|
||||
DLAM= -0.75*cfact*((fnct +0.5*fl+0.5)**2
|
||||
1 -(fnode+0.5*fl+0.5)**2)*(3.2/rscale)**2/fk2
|
||||
a='En'
|
||||
ELSE
|
||||
if(det.gt.0.0) then
|
||||
dplus =.true.
|
||||
if(det.lt.d1) then
|
||||
v1=e
|
||||
d1=det
|
||||
endif
|
||||
else
|
||||
dminus=.true.
|
||||
if(det.gt.d0) then
|
||||
v0=e
|
||||
d0=det
|
||||
endif
|
||||
endif
|
||||
IF(dplus.and.dminus.and.abs(det).gt.dinterp) THEN
|
||||
c Interpolation search
|
||||
DLAM= ((d1*v0-d0*v1)/((d1-d0)*e) - 1.0)
|
||||
a='Ei'
|
||||
ELSE
|
||||
c Variational search
|
||||
DLAM= -cfact*DET/(DR*FK2*FNORM)
|
||||
a='Ev'
|
||||
IF(ABS(DLAM).GT.ESCALE) DLAM = SIGN(ESCALE,DLAM)
|
||||
ENDIF
|
||||
ENDIF
|
||||
FLAM=1.0+DLAM
|
||||
TEMP=SQRT(ABS(FLAM))
|
||||
FK=FK*TEMP
|
||||
ETA=ETA/TEMP
|
||||
TEMP=FK2*FLAM-FK2
|
||||
FK2=FK2+TEMP
|
||||
E=E*FLAM
|
||||
DO 485 M=1,Kmax
|
||||
MK=M+M-1
|
||||
U(MK+1)=U(MK+1)+TEMP
|
||||
485 CONTINUE
|
||||
ENDIF
|
||||
c diagnostic printout
|
||||
c if(icnt+1.eq.icmax) write(ioutput,8888)
|
||||
c 8888 format(' Iter',' Nodes',5x,' Det',9x,'Fnorm',9x,'Old E'
|
||||
c 1, 9x,'New E',9x,'Old V',9x,'New V',9x,' Flam',9x,' RM')
|
||||
c WRITE(ioutput,8889)A,ITER,FNCT,DET,FNORM,eold,E
|
||||
c 1 ,vold,V,1.0+DLAM,rm
|
||||
c 8889 FORMAT(' ',A2,I6,F6.0,8(2X,1PE12.5))
|
||||
c
|
||||
IF(ABS(DET).LT.DETX .AND. ABS(DLAM).LT.DLAMX) THEN
|
||||
ICNT=0
|
||||
ENDIF
|
||||
GO TO 10
|
||||
C
|
||||
500 CONTINUE
|
||||
C
|
||||
C NORMALIZE WAVE FUNCTION
|
||||
C
|
||||
IF(FK2.LT.0.0.OR.ISW.EQ.3.OR.ISW.EQ.4) THEN
|
||||
C
|
||||
C NEGATIVE ENERGY AND BOX B.C.
|
||||
C
|
||||
FNORM=SQRT(FNORM*DR)
|
||||
ELSEIF(FK.GT.0.0.AND.(ISW.EQ.0.OR.ISW.EQ.1)) THEN
|
||||
C POSITIVE ENERGY AND PI/2 PHASE SHIFT
|
||||
C
|
||||
D(1)=0.0
|
||||
D(2)=1.0
|
||||
VOL=(FNORM1+FNORM2)*DR*F6**2
|
||||
c Volume and surface terms are still divided by SCALE**2
|
||||
WIDTH=2.0*E/(FK*(VOL+SURF))
|
||||
IF(WIDTH.LT.0.0) then
|
||||
WRITE(ioutput,'(''0 Negative width '',20(1H*)/)')
|
||||
endif
|
||||
WIDTH=ABS(WIDTH)
|
||||
TEMP=( LOG(WIDTH)-2.0* LOG(SCALE))/ELOG10
|
||||
I1=TEMP-1.0
|
||||
A1=EXP(ELOG10*(TEMP-FLOAT(I1)))
|
||||
WRITE(ioutput,9502)A1,I1,VOL*SCALE**2,SURF*SCALE**2
|
||||
FNORM=1.0/SQRT(WIDTH*FK/(2.0*E))/F6
|
||||
C
|
||||
ELSEIF(FK.GT.0.0.AND.ISW.EQ.2) THEN
|
||||
C
|
||||
C FIND B.C. FOR E > 0 AND NO SEARCH (ISW = 2)
|
||||
C
|
||||
DET=T(5)*T(8)-T(6)*T(7)
|
||||
A1=(F1 *T(8)-F2 *T(7))/DET
|
||||
B1=(T(5)*F2 -T(6)*F1 )/DET
|
||||
DET=1.0/SQRT(A1**2+B1**2)
|
||||
A1=A1*DET
|
||||
B1=B1*DET
|
||||
C A1=COS(DELTA), B1=SIN(DELTA)
|
||||
C (D1,D2) = (exp(2i*delta) - 1)/(2i) = exp(i*delta)*sin(delta)
|
||||
WRITE(ioutput,9501)A1,B1
|
||||
D(1)=B1*A1
|
||||
D(2)=B1*B1
|
||||
FNORM=FK/SCALE
|
||||
F2=1.0/DET
|
||||
F6=1.0
|
||||
DET=0.0
|
||||
ENDIF
|
||||
C
|
||||
TEMP=1.0/(F2*FNORM)
|
||||
R=0.0
|
||||
DO 510 M=1,KM
|
||||
R=R+DR
|
||||
F(M)=F(M)*TEMP/R
|
||||
510 CONTINUE
|
||||
IF(KM.LT.Kmax) THEN
|
||||
KM=KM+1
|
||||
TEMP=1.0/(F6*FNORM)
|
||||
DO 520 M=KM,Kmax
|
||||
R=R+DR
|
||||
F(M)=F(M)*TEMP/R
|
||||
520 CONTINUE
|
||||
ENDIF
|
||||
IF(IPRNT.EQ.0.OR.IERR.NE.0) then
|
||||
WRITE(ioutput,9500)V,DET,FNCT,RM,E,ITER
|
||||
endif
|
||||
c
|
||||
D(5) = fk2
|
||||
D(6) = (fk2/e)*width/2.0/scale**2
|
||||
D(10)=ISW
|
||||
c
|
||||
RETURN
|
||||
c
|
||||
9500 FORMAT(21X,6HV =,F9.4,3X,6HDET =,F9.4,3X,6HNODES=,F9.4,3X,
|
||||
1 6HRM =,F9.4,3X,6HE =,F9.4,3X,6HITER.=,I4 )
|
||||
9501 FORMAT(21X,6HCOSD =,1pe12.4,12x,9H SIND =,1pe12.4)
|
||||
9502 FORMAT(24H0SINGLE PARTICLE WIDTH = ,F7.4,1HE,I3,' MEV '
|
||||
1,13HVOLUME TERM = ,1PE12.4,5X,14HSURFACE TERM = ,1PE12.4)
|
||||
END
|
||||
201
dwuck4/culib4/COU.FOR
Normal file
201
dwuck4/culib4/COU.FOR
Normal file
|
|
@ -0,0 +1,201 @@
|
|||
|
||||
c***********************************************************************
|
||||
SUBROUTINE COU(R,RP,ETA,L,H,F,FP,G,GP,S)
|
||||
c
|
||||
c Coulomb Function Subroutine
|
||||
c
|
||||
c Calculates the functions at 2 points, R and RP for convenience
|
||||
c in matching to the output of some integration formulae.
|
||||
c
|
||||
c R First argument
|
||||
c RP Second argument
|
||||
c E Coulomb parameter, eta
|
||||
c L Number of angular momenta = lmax+1
|
||||
c H Integration step size, usually = 0.10
|
||||
c F Regular function at R
|
||||
c FP Regular function at RP
|
||||
c G Irregular function at R
|
||||
c GP Irregular function at RP
|
||||
c S Coulomb phase
|
||||
c
|
||||
c***********************************************************************
|
||||
c
|
||||
c IMPLICIT REAL*8(A-H,O-Z)
|
||||
DIMENSION F(51),FP(51),G(51),GP(51),S(51)
|
||||
C
|
||||
LL=L
|
||||
IF(LL.LT.50) THEN
|
||||
ELP=50.
|
||||
J=50
|
||||
ELSE
|
||||
ELP=LL
|
||||
J=LL
|
||||
ENDIF
|
||||
A=ATAN (ETA/ELP)
|
||||
B=SQRT (ETA**2+ELP**2)
|
||||
Y=A*(ELP-0.5)+ETA*( LOG(B)-1.)-SIN (A)/(12.*B)
|
||||
1 +SIN (3.*A)/(360.*B**3)-SIN (5.*A)/(1260.*B**5)
|
||||
2 +SIN (7.*A)/(1680.*B**7)-SIN (9.*A)/(1188.*B**9)
|
||||
C
|
||||
K=J-1
|
||||
DO 100 I=1,K
|
||||
IF(J.LE.LL) S(J)=Y
|
||||
ELP=ELP-1.
|
||||
J=J-1
|
||||
Y=Y-ATAN (ETA/ELP)
|
||||
100 CONTINUE
|
||||
S(1)=Y
|
||||
DEL1=R-2.0*ETA
|
||||
RMAX=.41666667*(ETA**2+4.*ETA+3.)
|
||||
IF(RMAX.LT.10.0) RMAX=10.0
|
||||
DEL=R-RMAX
|
||||
IF(ETA.GE.5.0.AND.ABS (DEL1).LT.ABS (DEL)) THEN
|
||||
DEL=DEL1
|
||||
I1=2
|
||||
C Transition line expansion
|
||||
X=2.0*ETA
|
||||
T1=ETA**2
|
||||
T2=T1**2
|
||||
T3=ETA** .666666667
|
||||
T4=T3**2
|
||||
T5=T4**2
|
||||
T6=T3*T5
|
||||
T7=T4*T6
|
||||
T8=T3*T7
|
||||
T9=ETA** .166666667
|
||||
Y=1.22340402*T9*(1.+.495957017E-1/T4-.888888889E-2/T1
|
||||
1 +.245519918E-2/T6-.910895806E-3/T2+.845362E-3/T8)
|
||||
Z=-.707881773/T9*(1.-.172826039/T3+.317460317E-3/T1
|
||||
1 -.358121485E-2/T5+.311782468E-3/T2-.907396643E-3/T7)
|
||||
ELSE
|
||||
C
|
||||
IF(DEL.GE.0.0.OR.ETA.EQ.0.0) THEN
|
||||
X=R
|
||||
I1=1
|
||||
ELSE
|
||||
X=RMAX
|
||||
I1=2
|
||||
ENDIF
|
||||
C Asymptotic expansion
|
||||
T1=ETA**2
|
||||
T2=2.*X
|
||||
T4=ETA/T2
|
||||
SS=1.
|
||||
TS=0.
|
||||
SL=0.
|
||||
TL=1.-ETA/X
|
||||
SSS=1.
|
||||
STS=0.
|
||||
SSL=0.
|
||||
STL=TL
|
||||
EN=0.
|
||||
DO 700 K=1,25
|
||||
IF(ABS (SS/SSS).GT.1.0E-10) THEN
|
||||
T5=EN+1.
|
||||
T6=T5+EN
|
||||
T7=EN*T5
|
||||
T8=T6*T4/T5
|
||||
T9=(T1-T7)/(T2*T5)
|
||||
T5=T8*SS-T9*TS
|
||||
TS=T8*TS+T9*SS
|
||||
SS=T5
|
||||
T5=T8*SL-T9*TL-SS/X
|
||||
TL=T8*TL+T9*SL-TS/X
|
||||
SL=T5
|
||||
SSS=SSS+SS
|
||||
STS=STS+TS
|
||||
SSL=SSL+SL
|
||||
STL=STL+TL
|
||||
EN=EN+1.
|
||||
ENDIF
|
||||
700 CONTINUE
|
||||
C
|
||||
T3=X-ETA* LOG(T2)+S(1)
|
||||
T8=SIN (T3)
|
||||
T9=COS (T3)
|
||||
Y=SSS*T9-STS*T8
|
||||
Z=SSL*T9-STL*T8
|
||||
ENDIF
|
||||
C
|
||||
DO 810 I=1,I1
|
||||
IF(I.EQ.I1) THEN
|
||||
G(1) = Y
|
||||
W = Z
|
||||
DEL = RP - R
|
||||
ENDIF
|
||||
C Runge-Kutta integration
|
||||
N=ABS (DEL/H)+1.0
|
||||
DX=DEL/FLOAT(N)
|
||||
T1=DX/2.
|
||||
T2=DX/8.
|
||||
T3=2.0*ETA
|
||||
DO 805 J=1,N
|
||||
T4=DX*(T3/X-1.)*Y
|
||||
X=X+T1
|
||||
T5=DX*(T3/X-1.)*(Y+T1*Z+T2*T4)
|
||||
X=X+T1
|
||||
T6=DX*(T3/X-1.)*(Y+DX*Z+T1*T5)
|
||||
Y=Y+DX*(Z+(T4+2.*T5)/6.)
|
||||
Z=Z+(T4+4.*T5+T6)/6.
|
||||
805 CONTINUE
|
||||
810 CONTINUE
|
||||
GP(1)=Y
|
||||
C
|
||||
T1=ETA**2
|
||||
T8=SQRT (1.+T1)
|
||||
G(2)=((1./R+ETA)*G(1)-W)/T8
|
||||
GP(2)=((1./RP+ETA)*Y-Z)/T8
|
||||
T2=1.
|
||||
T3=2.
|
||||
C Recur irregular function upwards
|
||||
DO 910 I=3,LL
|
||||
T4=T2+T3
|
||||
T5=T2*T3
|
||||
T6=T3*SQRT (T2**2+T1)
|
||||
T7=T2*SQRT (T3**2+T1)
|
||||
G (I)=(T4*(ETA+T5/R )*G (I-1)-T6*G (I-2))/T7
|
||||
GP(I)=(T4*(ETA+T5/RP)*GP(I-1)-T6*GP(I-2))/T7
|
||||
T2=T2+1.
|
||||
T3=T3+1.
|
||||
910 CONTINUE
|
||||
N=MAX0(L+11, INT(2.0*R+11.0) )
|
||||
I1=N
|
||||
Y =1.0E-20
|
||||
YP=Y
|
||||
Z =0.
|
||||
ZP=Z
|
||||
C Recur regular function downwards
|
||||
DO 930 I=1,I1
|
||||
T2=N
|
||||
T3=T2+1.
|
||||
T4=T2+T3
|
||||
T5=T2*T3
|
||||
T6=T2*SQRT (T3**2+T1)
|
||||
T7=T3*SQRT (T2**2+T1)
|
||||
X =(T4*(ETA+T5/R )*Y -T6*Z )/T7
|
||||
XP=(T4*(ETA+T5/RP)*YP-T6*ZP)/T7
|
||||
IF(N.LE.LL) THEN
|
||||
F (N)=X
|
||||
FP(N)=XP
|
||||
ELSE
|
||||
c Scale for l > lmax
|
||||
IF(ABS (X).GT.1.0) THEN
|
||||
Y =Y *1.0E-20
|
||||
YP=YP*1.0E-20
|
||||
X =X *1.0E-20
|
||||
XP=XP*1.0E-20
|
||||
ENDIF
|
||||
ENDIF
|
||||
N=N-1
|
||||
Z =Y
|
||||
ZP=YP
|
||||
Y =X
|
||||
YP=XP
|
||||
930 CONTINUE
|
||||
Z =1./(T8*(F (1)*G (2)-F (2)*G (1)))
|
||||
ZP=1./(T8*(FP(1)*GP(2)-FP(2)*GP(1)))
|
||||
DO 950 I=1,LL
|
||||
F (I)=F (I)*Z
|
||||
950 FP(I)=FP(I)*ZP
|
||||
RETURN
|
||||
END
|
||||
278
dwuck4/culib4/DSTRIP.FOR
Normal file
278
dwuck4/culib4/DSTRIP.FOR
Normal file
|
|
@ -0,0 +1,278 @@
|
|||
|
||||
SUBROUTINE DSTRIP(IQ,DR,K,F1,F2,FR,QNUM,OPT,KM,SL,C)
|
||||
c
|
||||
c Calculates two nucleon transfer form factor (Bayman and Kallio)
|
||||
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
|
||||
parameter (maxg=10, maxr=12)
|
||||
DIMENSION F1(400),F2(400),FR(800),QNUM(4,2),IQ(4),TVCC(-9:9)
|
||||
1 ,D1(-9:9),D2(-9:9),C(32),AG(maxg),WG(maxg),BG(maxg)
|
||||
2 ,AR(maxr),WR(maxr)
|
||||
C
|
||||
DATA KR,KX,krel/0,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)
|
||||
lrel = iq(4)
|
||||
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)+3+4*lrel)/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)
|
||||
IF(NX .NE. KX .or. lrel .ne. krel) then
|
||||
CALL LEGAUS(2*NX,AG,WG)
|
||||
KX=NX
|
||||
krel=lrel
|
||||
DL1=sqrt(YXFCT(0,2*lrel))*YXFCT(lrel,2*lrel)/2.0**lrel
|
||||
1 *sqrt(float(2*lrel+1))*phasef(lrel)
|
||||
do 47 i=1,nx
|
||||
BG(i) = sqrt(1.0-ag(i)**2)
|
||||
DM1=0.0
|
||||
DO 46 LI=1,lrel
|
||||
DL1=DL1*BG(i)
|
||||
46 CONTINUE
|
||||
wg(i) = wg(i)*DL1
|
||||
47 continue
|
||||
endif
|
||||
c WRITE(20,'(15H0 NO. R STEPS =,I3,18H NO. X STEPS =,I3)')NR,NX
|
||||
c
|
||||
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))
|
||||
1 /vcc(LL,2*lrel,LL,0,2*lrel)
|
||||
IF(IPAULI. eq. 0) then
|
||||
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)
|
||||
endif
|
||||
c
|
||||
FNORM=FNORM*SQRT(FLOAT((LL+1)*(IS+1)*(J1+1)*(J2+1)))
|
||||
1 *WINEJ(LL1,IS1,J1,LL2,IS2,J2,LL,IS,JJ)
|
||||
if(l1 .le. l2) then
|
||||
mmin= -min0(l1,l2-lrel)
|
||||
mmax= l1
|
||||
else
|
||||
mmin=-min0(l2,l1-lrel)
|
||||
mmax= l2+lrel
|
||||
endif
|
||||
DO 80 M=mmin,mmax
|
||||
TVCC( M)=VCC(LL1,LL2,LL, 2*M,-2*M+2*lrel)
|
||||
1 *SQRT(yxfct(l1+abs( m ),l1-abs( m ))
|
||||
2 *yxfct(l2+abs(-m+lrel),l2-abs(-m+lrel)))
|
||||
c write(20,'(a,2i4,2f10.5)')' m1, m2, Tvcc(m1,m2)'
|
||||
c 1 ,m,-m+lrel,Tvcc( m)
|
||||
80 CONTINUE
|
||||
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
|
||||
c RS = r/2
|
||||
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)
|
||||
c
|
||||
120 CONTINUE
|
||||
DM1=0.0
|
||||
DL1=FACT1
|
||||
DO 140 LI=1,L1
|
||||
DL1=DL1*SIN1
|
||||
140 CONTINUE
|
||||
c time reversal phase
|
||||
D1( L1)=DL1*phasef(L1)
|
||||
D1(-L1)=DL1
|
||||
DM2=0.0
|
||||
DL2=FACT2
|
||||
DO 150 LI=1,L2
|
||||
DL2=DL2*SIN2
|
||||
150 CONTINUE
|
||||
c time reversal phase * exp(im*pi)
|
||||
D2( L2)=DL2
|
||||
D2(-L2)=DL2*phasef(L2)
|
||||
FJ1=1.0
|
||||
FL1=LL1
|
||||
FM1=LL1
|
||||
DO 170 m1=L1-1,0,-1
|
||||
DK1=(FM1*COS1*DL1/SIN1-DM1)/(FJ1*FL1)
|
||||
FJ1=FJ1+1.0
|
||||
FL1=FL1-1.0
|
||||
FM1=FM1-2.0
|
||||
DM1=DL1
|
||||
DL1=DK1
|
||||
c time reversal phase
|
||||
D1( m1)=DL1*phasef(m1)
|
||||
D1(-m1)=DL1
|
||||
170 CONTINUE
|
||||
c if(m .eq. 1 .and. mr .eq. 1) then
|
||||
c write(20,'(a,10(i4,f10.5))')' m1, D1 ='
|
||||
c 1 ,(m1,d1(m1),m1=l1,-l1,-1)
|
||||
c endif
|
||||
FJ2=1.0
|
||||
FL2=LL2
|
||||
FM2=LL2
|
||||
DO 180 m2=L2-1,0,-1
|
||||
DK2=(FM2*COS2*DL2/SIN2-DM2)/(FJ2*FL2)
|
||||
FJ2=FJ2+1.0
|
||||
FL2=FL2-1.0
|
||||
FM2=FM2-2.0
|
||||
DM2=DL2
|
||||
DL2=DK2
|
||||
c time reversal phase * exp(im*pi)
|
||||
D2( m2)=DL2
|
||||
D2(-m2)=DL2*phasef(m2)
|
||||
180 CONTINUE
|
||||
c if(m .eq. 1 .and. mr .eq. 1) then
|
||||
c write(20,'(a,10(i4,f10.5))')' m2, D2 ='
|
||||
c 1 ,(m2,d2(m2),m2=l2,-l2,-1)
|
||||
c endif
|
||||
PROD=0.0
|
||||
DO 185 LI=mmin,mmax
|
||||
PROD=PROD+D1( LI)*D2(-LI+lrel)*TVCC(LI)
|
||||
c if(m .eq. 1 .and. mr .eq. 1) then
|
||||
c write(20,'(a,2i4,4f10.5)')' m1, m2, D1, D2, Tvcc, Prod ='
|
||||
c 1 ,li,-li+lrel,d1(li),d2(-li+lrel),Tvcc(li),prod
|
||||
c endif
|
||||
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.
|
||||
SUMX=SUMX+WG(MX)*PROD*FT1*FT2
|
||||
c if(m.eq.34) write(20,'(2i4,1p10e12.4)')mr,mx,x,r1,r2,r1**2+r2**2
|
||||
c 1 ,ft1,ft2,ft1*ft2,prod,wg(mx),sumx
|
||||
IF(IX.eq.0) then
|
||||
IX=1
|
||||
ITEMP=K1
|
||||
K1=K2
|
||||
K2=ITEMP
|
||||
ATEMP=FK1
|
||||
FK1=FK2
|
||||
FK2=ATEMP
|
||||
IF(L1.EQ.L2) GO TO 280
|
||||
ATEMP=COS1
|
||||
COS1=COS2
|
||||
COS2=ATEMP
|
||||
ATEMP=SIN1
|
||||
SIN1=SIN2
|
||||
SIN2=ATEMP
|
||||
GO TO 120
|
||||
endif
|
||||
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
|
||||
81
dwuck4/culib4/DWPLOT.FOR
Normal file
81
dwuck4/culib4/DWPLOT.FOR
Normal file
|
|
@ -0,0 +1,81 @@
|
|||
|
||||
SUBROUTINE DWPLOT(NTH0,NLOG,SIGPLT,DTHETA,THETA1)
|
||||
C
|
||||
C THIS IS A NEW VERSION OF THE PRINTER PLOT ROUTINE, June 1992
|
||||
C
|
||||
Parameter (len = 100, pi = 3.141592)
|
||||
DIMENSION SIGPLT(*)
|
||||
CHARACTER*1 temp
|
||||
1, BLANK /' '/, ASTER /'*'/, FENCE /'|'/, APLUS /'+'/
|
||||
CHARACTER*(len+1) dstore
|
||||
CHARACTER*(len+3) astore
|
||||
c
|
||||
common/ch3files/input, ioutp
|
||||
C
|
||||
ioutput = 6
|
||||
if(ioutp .ne. 0) ioutput = ioutp
|
||||
nth = abs(nth0)
|
||||
if(nlog.gt.0) then
|
||||
MAXN= 0
|
||||
DO 30 I=1,NTH
|
||||
IF(SIGPLT(I).LE.0.0) SIGPLT(I)=1.0E-20
|
||||
SIGPLT(I)= LOG10(SIGPLT(I))
|
||||
MAXN=MAX0(MAXN,INT(SIGPLT(I) + 100.0)-NLOG)
|
||||
30 CONTINUE
|
||||
MAXN = MAXN - 100 + 1
|
||||
nlogp= nlog
|
||||
else
|
||||
MAXN = -1
|
||||
nlogp= 2
|
||||
endif
|
||||
c Write header line
|
||||
do 40 j=1,len+3
|
||||
40 astore(j:j) = BLANK
|
||||
do 45 j=0,nlogp
|
||||
indx = j*(len/nlogp) + 1
|
||||
45 write(astore(indx:indx+2),'(i3)')MAXN +j
|
||||
WRITE(ioutput,9000)astore
|
||||
c
|
||||
DO 100 I=1,NTH
|
||||
tint = THETA1 + (i-1)*DTHETA
|
||||
C Coose between angle or cos(angle) data
|
||||
if(nth0.lt.0) then
|
||||
if (tint.gt. 1.0) tint = 1.0
|
||||
if (tint.lt.-1.0) tint =-1.0
|
||||
theta = acos(tint)*180./pi
|
||||
else
|
||||
theta = tint
|
||||
endif
|
||||
cs = cos(theta*pi/180.)
|
||||
IF(I.EQ.1.OR.I.EQ.NTH) THEN
|
||||
TEMP=APLUS
|
||||
ELSE
|
||||
TEMP=BLANK
|
||||
ENDIF
|
||||
DSTORE( 1: 1) = APLUS
|
||||
DSTORE(len+1:len+1) = APLUS
|
||||
DO 70 J=2,LEN
|
||||
DSTORE(j:j) = TEMP
|
||||
70 CONTINUE
|
||||
if(nlog.le.0) dstore(len/2+1:len/2+1) = APLUS
|
||||
C
|
||||
IF(I .EQ. 1 .OR. I .EQ. NTH) THEN
|
||||
DO 80 J=0,NLOGP
|
||||
indx = j*(len/nlogp) +1
|
||||
DSTORE(indx:indx) = FENCE
|
||||
80 CONTINUE
|
||||
ENDIF
|
||||
C
|
||||
INDX= (SIGPLT(I)-float(MAXN))*float((LEN/NLOGP)) + 1.5
|
||||
IF(INDX.GE.1) DSTORE(indx:indx) = ASTER
|
||||
C
|
||||
WRITE(ioutput,9002)THETA,DSTORE,THETA,cs
|
||||
100 CONTINUE
|
||||
C Write trailer line
|
||||
WRITE(ioutput,9000)astore
|
||||
c
|
||||
RETURN
|
||||
c
|
||||
9000 FORMAT(' THETA ',A103 ,' THETA ','cos(theta)')
|
||||
9002 FORMAT(' ',F8.2 ,' ',A101, F8.2, f10.4 )
|
||||
END
|
||||
74
dwuck4/culib4/FNLOC5.FOR
Normal file
74
dwuck4/culib4/FNLOC5.FOR
Normal file
|
|
@ -0,0 +1,74 @@
|
|||
|
||||
SUBROUTINE FNLOC5(U,V,W,PNLOC,FK2,FK,ETA,RC,DR,KT)
|
||||
c
|
||||
c W Central optical potential
|
||||
c V Spin orbit potential, for Darwin form
|
||||
c W Function for correction to be applied to
|
||||
c PNLOC Non-locality parameter
|
||||
c Positive value gives Gaussian form
|
||||
c Negative value gives Darwin form
|
||||
c FK2 Wave numbre squared
|
||||
c FK Wave number
|
||||
c ETA Coulomb parameter
|
||||
c RC Coulomb radius
|
||||
c DR Radial increment
|
||||
c KT Number of points
|
||||
c
|
||||
DIMENSION U(800),V(800),W(800)
|
||||
C
|
||||
C NON LOCALITY CORRECTION FACTOR FOR DISTORTED WAVES
|
||||
C
|
||||
FACP=PNLOC**2/8.0
|
||||
IF(FACP.EQ.0.0) GO TO 410
|
||||
C
|
||||
WRITE(6,9900)PNLOC
|
||||
IF(PNLOC.GT.0.0) THEN
|
||||
R=0.0
|
||||
ETAK=2.0*ETA*FK
|
||||
ELSE
|
||||
R1=DR*FLOAT(KT+1)
|
||||
ENDIF
|
||||
CTEMP1=0.0
|
||||
CTEMP2=0.0
|
||||
T1=0.0
|
||||
T2=0.0
|
||||
C
|
||||
DO 400 M=1,KT
|
||||
IF(PNLOC.GT.0.0) THEN
|
||||
C PNLOC POSITIVE GIVES USUAL NON-LOCAL FACTOR WITH GAUSSIAN SHAPE
|
||||
MK=M+M-1
|
||||
R=R+DR
|
||||
IF(R.GT.RC) THEN
|
||||
VCOUL=ETAK/R
|
||||
ELSE
|
||||
VCOUL=0.5*ETAK*(3.0-(R/RC)**2)/RC
|
||||
ENDIF
|
||||
CTEMP1=-FACP*U(MK )+FACP*(FK2-VCOUL)
|
||||
CTEMP2=-FACP*U(MK+1)
|
||||
T1=U(MK )
|
||||
T2=U(MK+1)
|
||||
ELSE
|
||||
C PNLOC NEGATIVE GIVES DIRAC TYPE DARWIN FACTOR BASED ON SPIN ORBIT
|
||||
MK=KT+KT-M-M+1
|
||||
R2=R1
|
||||
R1=R1-DR
|
||||
CTEMP1=CTEMP1-(R2*T1+R1*V(MK ))*(DR*0.25)
|
||||
CTEMP2=CTEMP2-(R2*T2+R1*V(MK+1))*(DR*0.25)
|
||||
T1=V(MK )
|
||||
T2=V(MK+1)
|
||||
ENDIF
|
||||
C
|
||||
FACT=EXP(CTEMP1)
|
||||
UT1=FACT*COS(CTEMP2)
|
||||
UT2=FACT*SIN(CTEMP2)
|
||||
UF1 =UT1*W(MK )-UT2*W(MK+1)
|
||||
UF2 =UT1*W(MK+1)+UT2*W(MK )
|
||||
W(MK )=UF1
|
||||
W(MK+1)=UF2
|
||||
C WRITE(20,7777)R1,T1,T2,UT1,UT2
|
||||
C 7777 FORMAT(' R =',F6.2,' POT =',1P2E12.4,' FACTOR =',1P2E12.4)
|
||||
400 CONTINUE
|
||||
410 CONTINUE
|
||||
RETURN
|
||||
9900 FORMAT('0Non-locality correction is applied, parameter =',f8.3)
|
||||
END
|
||||
83
dwuck4/culib4/GAUSSR.FOR
Normal file
83
dwuck4/culib4/GAUSSR.FOR
Normal file
|
|
@ -0,0 +1,83 @@
|
|||
|
||||
SUBROUTINE GAUSSR(NMAX,INDEX,ALFA,AG,WG,IERR,CUTOFF)
|
||||
C
|
||||
C GAUSS-HERMITE AND GAUSS-LAGUERRE POINT AND WAIT ROUTINE
|
||||
C
|
||||
C IF ALFA IS INTEGER -- GAUSS-LAGUERRE
|
||||
C IF ALFA IS INTEGER + 1/2 -- GAUSS-HERMITE
|
||||
C
|
||||
c e.g. alfa = -0.5 gives usual Gauss-Hermite points and weights
|
||||
c e.g. alfa = 0.0 gives usual Gauss-Laguerre points and weights
|
||||
c
|
||||
DIMENSION AG(100),WG(100)
|
||||
C
|
||||
DATA PI,SQRPI,eps/3.14159265,1.77245385,1.e-6/
|
||||
INDEX=0
|
||||
FI=NMAX
|
||||
FKI=4.0*(FI+(ALFA+1.0)*0.5)
|
||||
FLN= LOG(FI)
|
||||
C
|
||||
K=ALFA
|
||||
JJ=(ALFA-FLOAT(K))*2.0
|
||||
DY=0.0
|
||||
IF(JJ.EQ.0) then
|
||||
FNORM=1.0
|
||||
IF(K.NE.0) then
|
||||
DO 10 J=1,K
|
||||
FNORM=FNORM*(ALFA+FI+1.0-FLOAT(J))
|
||||
10 CONTINUE
|
||||
endif
|
||||
else
|
||||
FNORM=SQRPI/2.0
|
||||
DO 20 J=1,NMAX
|
||||
FNORM=FNORM*(1.0+ALFA/FLOAT(J))
|
||||
20 CONTINUE
|
||||
K=ALFA+1.0
|
||||
IF(K.NE.0) then
|
||||
DO 22 J=1,K
|
||||
FNORM=FNORM*(FLOAT(J)-0.5)
|
||||
22 CONTINUE
|
||||
endif
|
||||
endif
|
||||
Y=0.0
|
||||
Z1=0.0
|
||||
Z2=0.0
|
||||
C
|
||||
DO 80 J=1,NMAX
|
||||
FJ=J
|
||||
FKJ=4.0*(FJ+(ALFA+1.0)*0.5)
|
||||
Z=((FJ+0.5*ALFA-0.25)*PI)**2/FKI
|
||||
Z=Z*(1.0+Z*(1.0+PI* LOG(FJ)*FLN/(8.0*(FI+FLN-FJ+eps)))/(3.0*FKI))
|
||||
DELZ=Z-Z1
|
||||
Z1=Z
|
||||
Z=Y+DELZ
|
||||
Z3=Z
|
||||
DO 74 M=1,20
|
||||
A1=0.0
|
||||
A2=1.0
|
||||
DO 70 K=1,NMAX
|
||||
FK=K
|
||||
A3=((2.0*FK+ALFA-1.0-Z)*A2-(FK+ALFA-1.0)*A1)/FK
|
||||
A1=A2
|
||||
A2=A3
|
||||
B2=(FK*A2-(FK+ALFA)*A1)/Z
|
||||
70 CONTINUE
|
||||
Y=Z-A2/B2
|
||||
IF(ABS((Z-Y)/Z).LT.3.0E-07) GO TO 75
|
||||
Z=Y
|
||||
74 CONTINUE
|
||||
IERR=J
|
||||
75 CONTINUE
|
||||
DZ=Z-Z2
|
||||
Z2=Z
|
||||
DZ=((FNORM/Z)/B2)/B2
|
||||
IF(DZ.LT.CUTOFF.AND.DZ.LT.DY) GO TO 100
|
||||
DY=DZ
|
||||
INDEX=J
|
||||
AG(J)=Y
|
||||
WG(J)=DZ
|
||||
IF(JJ.NE.0) AG(J)=SQRT(Y)
|
||||
80 CONTINUE
|
||||
100 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
43
dwuck4/culib4/LEGAUS.FOR
Normal file
43
dwuck4/culib4/LEGAUS.FOR
Normal file
|
|
@ -0,0 +1,43 @@
|
|||
|
||||
SUBROUTINE LEGAUS(LL,X,W)
|
||||
C
|
||||
C GAUSS-LEGENDRE POINT AND WAIT ROUTINE FOR AN EVEN NO. OF POINTS
|
||||
C
|
||||
C ll = order i.e. the total number of points for -1< x <1
|
||||
C x = points
|
||||
C w = weights
|
||||
C
|
||||
IMPLICIT REAL*8(A-H,O-Z)
|
||||
real*4 x,w
|
||||
DIMENSION X(100),W(100)
|
||||
Z3=-1.6/FLOAT(LL+1)
|
||||
Z2=3.0*Z3
|
||||
Z1=5.0*Z3
|
||||
NL=(LL+1)/2
|
||||
DO 200 L=1,NL
|
||||
ZOLD=0.0
|
||||
Z=Z1+3.0*(Z3-Z2)
|
||||
DO 50 J=1,10
|
||||
P1=0.0
|
||||
P2=1.0
|
||||
DO 30 I=1,LL
|
||||
P3=(FLOAT(I+I-1)*Z*P2-FLOAT(I-1)*P1)/FLOAT(I)
|
||||
P1=P2
|
||||
P2=P3
|
||||
30 CONTINUE
|
||||
DP=FLOAT(LL)*(P1-Z*P2)/(1.0-Z*Z)
|
||||
Z=Z-P2/DP
|
||||
IF(ABS(Z-ZOLD)/Z.LT.1.0E-10) GO TO 51
|
||||
ZOLD=Z
|
||||
50 CONTINUE
|
||||
WRITE(6,9100)L
|
||||
9100 FORMAT(28H0NO CONVERGENCE FOR ZERO NO.,I4)
|
||||
51 CONTINUE
|
||||
X(L)=Z
|
||||
W(L)=2.0/((1.0-Z*Z)*DP*DP)
|
||||
Z1=Z2
|
||||
Z2=Z3
|
||||
Z3=Z
|
||||
200 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
38
dwuck4/culib4/LGNDR.FOR
Normal file
38
dwuck4/culib4/LGNDR.FOR
Normal file
|
|
@ -0,0 +1,38 @@
|
|||
|
||||
SUBROUTINE LGNDR(PLM,MPLUS,LPLUS,THET)
|
||||
DIMENSION PLM(459)
|
||||
THETA=THET /57.295779
|
||||
Y=COS(THETA)
|
||||
Z=SIN(THETA)
|
||||
IX=0
|
||||
DO 100 M=1,MPLUS
|
||||
LX=M-1
|
||||
L2=0
|
||||
P3=1.0
|
||||
FL1=LX
|
||||
IF(LX.EQ.0) GO TO 41
|
||||
DO 40 LT=1,LX
|
||||
FL1=FL1+1.0
|
||||
P3=P3*FL1*Z/2.0
|
||||
40 CONTINUE
|
||||
41 P2=0.0
|
||||
FL2=FL1+1.0
|
||||
FL3=1.0
|
||||
DO 90 LT=1,LPLUS
|
||||
IX1=IX+LT
|
||||
IF(L2-LX)50,70,60
|
||||
50 PLM(IX1)=0.0
|
||||
GO TO 75
|
||||
60 P3=(FL2*Y*P2-FL1*P1)/FL3
|
||||
FL1=FL1+1.0
|
||||
FL2=FL2+2.0
|
||||
FL3=FL3+1.0
|
||||
70 PLM(IX1)=P3
|
||||
P1=P2
|
||||
P2=P3
|
||||
75 L2=L2+1
|
||||
90 CONTINUE
|
||||
IX=IX+LPLUS
|
||||
100 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
287
dwuck4/culib4/POLFCT.FOR
Normal file
287
dwuck4/culib4/POLFCT.FOR
Normal file
|
|
@ -0,0 +1,287 @@
|
|||
c$debug
|
||||
subroutine polfct(max1,maxi,jr,js,theta,Pol,sr
|
||||
1 ,iopen20,iout20,nth,ntheta,ALPHA,IDAT)
|
||||
c -------------------------------------------------------------
|
||||
c max1 initial target multiplicity
|
||||
c maxi final target multiplicity
|
||||
c jr initial projectile multiplicity
|
||||
c js final projectile multiplicity
|
||||
c sr(1...jr, 1...js, 1...max1, 1...maxi)
|
||||
c -------------------------------------------------------------
|
||||
c Double precision statements -------------------------------
|
||||
c implicit real*8 (a-h,o-z)
|
||||
c double complex sr(js,jr,maxi,max1), a(3,3), b(3,3), c(3,3)
|
||||
c 1 , d(3,3,4), e(3,3,3)
|
||||
c real*8 Knn
|
||||
c -------------------------------------------------------------
|
||||
c Single precision statements --------------------------------
|
||||
complex sr(js,jr,maxi,max1), a(3,3), b(3,3), c(3,3)
|
||||
1 , d(3,3,4), e(3,3,3)
|
||||
real*4 Knn
|
||||
c -------------------------------------------------------------
|
||||
parameter (nsig = 4, npol = 10, nay = 4, nty = 3
|
||||
1 , rads = 3.141592/180.)
|
||||
logical iopen20, iout20
|
||||
|
||||
dimension s(2,2,3), ii(nsig), jj(nsig)
|
||||
1 , Pol(npol), Sy(3,3,3), Sij(3,3,4), IDAT(6), ALPHA(15)
|
||||
2 ,csig(nsig), Cij(nsig), Dij(nsig), dsig(nsig)
|
||||
c
|
||||
c spin 1/2 matrices for Spin correlation coefficients
|
||||
c s stored as S_z, S_x and S_y
|
||||
c
|
||||
data s /-1., 0., 0., 1.
|
||||
1 , 0., 1., 1., 0.
|
||||
2 , 0.,-1., 1., 0./
|
||||
C
|
||||
c SY MATRIX FOR SPIN 0, 1/2 and 1
|
||||
c
|
||||
DATA Sy/0.0,0.0,0.0, 0.0,0.0,0.0, 0.0,0.0,0.0
|
||||
1, 0.0,-1.0,0.0, 1.0,0.0,0.0, 0.0,0.0,0.0
|
||||
2, 0.0,-.707106781,0.0, .707106781,0.0,-.707106781
|
||||
3, 0.0,.707106781,0.0/
|
||||
C
|
||||
C SYY = ( 3*SY*SY - S*S )
|
||||
C S22 = ( S^*S^ )*SQRT(3)/4
|
||||
C S21 = ( S^*SZ + SZ*S^)*SQRT(3)/2
|
||||
C S20 = ( 3*SZ*SZ - S*S )/SQRT(2)
|
||||
C
|
||||
DATA Sij/-0.5,0.0,-1.5, 0.0,1.0,0.0, -1.5,0.0,-0.5
|
||||
1, 0.0,0.0,0.0, 0.0,0.0,0.0, 1.73205081,0.0,0.0
|
||||
2, 0.0,0.0,0.0, -1.2247449,0.0,0.0, 0.0,1.2247449,0.0
|
||||
3, 0.70710678,0.0,0.0,0.0,-1.4124214,0.0
|
||||
4, 0.0,0.0,0.70710678/
|
||||
C
|
||||
data ii/1, 2, 3, 1/
|
||||
data jj/1, 2, 3, 2/
|
||||
data zero/0.0/
|
||||
c
|
||||
c write(20,'(1p8e12.4)')sr
|
||||
cs=cos(theta*rads)
|
||||
ss=sin(theta*rads)
|
||||
do 20 n=1,nsig
|
||||
csig(n)=0.0
|
||||
dsig(n)=0.0
|
||||
20 continue
|
||||
do 30 i=1,npol
|
||||
Pol(i) = 0.0
|
||||
30 continue
|
||||
Dnn = 0.0
|
||||
Knn = 0.0
|
||||
c
|
||||
if(jr.gt.3 .or. js.gt.3) go to 1000
|
||||
c
|
||||
c Calculate Dnn = < S_y(initial) * S_y(final) >
|
||||
c Calculate pol = < S_y(final ) >
|
||||
c Calculate asy = < S_y(initial) >
|
||||
c
|
||||
do 200 mx=1,max1
|
||||
do 190 my=1,maxi
|
||||
c
|
||||
do 180 m =1,jr
|
||||
do 170 mp=1,js
|
||||
a(mp,m ) = 0.0
|
||||
b(mp, m) = 0.0
|
||||
c(mp, m) = 0.0
|
||||
if(jr .eq. 3) then
|
||||
do 115 i=1,nay
|
||||
d(mp,m ,i) = 0.0
|
||||
115 continue
|
||||
endif
|
||||
do 130 m1=1,jr
|
||||
do 120 m2=1,js
|
||||
c Dnn coefficient -------------------------------------------
|
||||
c(mp,m )=c(mp,m ) + sr(m2,m1,my,mx) * cmplx(zero, Sy(m2,mp,js))
|
||||
1 *cmplx(zero, Sy(m ,m1,jr))
|
||||
120 continue
|
||||
c Asymmetry --------------------------------------------
|
||||
b(mp,m )=b(mp,m ) + sr(mp,m1,my,mx) * cmplx(zero, Sy(m ,m1,jr))
|
||||
if(jr .eq. 3) then
|
||||
do 125 i=1,nay
|
||||
d(mp,m ,i)=d(mp,m ,i) + sr(mp,m1,my,mx) * Sij(m ,m1,i)
|
||||
125 continue
|
||||
endif
|
||||
130 continue
|
||||
do 140 m2=1,js
|
||||
c Polarization --------------------------------------------
|
||||
a(mp,m )=a(mp,m ) + sr(m2,m ,my,mx) * cmplx(zero, Sy(m2,mp,js))
|
||||
if(js .eq. 3) then
|
||||
do 135 i=1,nty
|
||||
e(mp,m ,i)=e(mp,m ,i) + sr(m2,m ,my,mx) * Sij(m2,mp,1)
|
||||
135 continue
|
||||
endif
|
||||
140 continue
|
||||
c
|
||||
Pol(1) =Pol(1) + conjg(sr(mp,m ,my,mx)) * sr(mp,m ,my,mx)
|
||||
Pol(2) =Pol(2) + conjg(sr(mp,m ,my,mx)) * a(mp,m )
|
||||
Pol(3) =Pol(3) + conjg(sr(mp,m ,my,mx)) * b(mp,m )
|
||||
if(jr .eq. 3) then
|
||||
do 160 i=1,nay
|
||||
pol(i+3)=Pol(i+3) + conjg(sr(mp,m ,my,mx)) * d(mp,m ,i)
|
||||
160 continue
|
||||
endif
|
||||
if(js .eq. 3) then
|
||||
do 165 i=1,nty
|
||||
pol(i+7)=Pol(i+7) + conjg(sr(mp,m ,my,mx)) * e(mp,m ,i)
|
||||
165 continue
|
||||
endif
|
||||
Dnn =Dnn + conjg(sr(mp,m ,my,mx)) * c(mp,m )
|
||||
170 continue
|
||||
180 continue
|
||||
190 continue
|
||||
200 continue
|
||||
c
|
||||
if(Pol(1) .eq. 0.0) go to 1000
|
||||
IF(iout20) THEN
|
||||
if(jr.eq.2 .and. maxi.eq.2) then
|
||||
c
|
||||
c Calculate Knn = < S_y(initial) * I_y(final) >
|
||||
c
|
||||
do 300 mx=1,max1
|
||||
do 290 mp=1,js
|
||||
c
|
||||
do 280 my=1,maxi
|
||||
do 270 m = 1,jr
|
||||
c(m ,my) = 0.0
|
||||
do 260 m1=1,maxi
|
||||
do 250 m2=1,jr
|
||||
c Knn coefficient
|
||||
c(m ,my)=c(m ,my) + sr(mp,m1,m2,mx) * cmplx(zero, Sy(my,m2,2))
|
||||
1 *cmplx(zero, Sy(m1,m ,2))
|
||||
250 continue
|
||||
260 continue
|
||||
Knn = Knn + conjg(sr(mp,m ,my,mx)) * c(m ,my)
|
||||
270 continue
|
||||
280 continue
|
||||
290 continue
|
||||
300 continue
|
||||
endif
|
||||
c
|
||||
if(jr .eq. 2 .and. js .eq.2) then
|
||||
c
|
||||
c Calculate Dij = < S_i(initial) * S_j(final) >
|
||||
c
|
||||
|
||||
do 600 mx=1,max1
|
||||
do 580 my=1,maxi
|
||||
do 500 n=1,nsig
|
||||
i1=ii(n)
|
||||
j1=jj(n)
|
||||
do 490 m =1,jr
|
||||
do 480 mp=1,js
|
||||
a(mp,m )=0.0
|
||||
do 440 m1=1,jr
|
||||
do 420 m2=1,js
|
||||
a(mp,m )=a(mp,m ) + sr(m2,m1,my,mx) * s(m2,mp,i1)*s(m ,m1,j1)
|
||||
420 continue
|
||||
440 continue
|
||||
c
|
||||
c Dij correlation coefficients
|
||||
dsig(n)=dsig(n)+conjg(sr(mp,m ,my,mx))*a(mp,m )
|
||||
480 continue
|
||||
490 continue
|
||||
500 continue
|
||||
580 continue
|
||||
600 continue
|
||||
endif
|
||||
c
|
||||
Dsig(3) = -Dsig(3)
|
||||
do 610 n=1,nsig
|
||||
dsig(n) = dsig(n)/Pol(1)
|
||||
610 continue
|
||||
c
|
||||
if(js .eq. 2 .and. maxi .eq. 2) then
|
||||
c
|
||||
c Spin correlation coefficients (final state target and projectile)
|
||||
c Calculate Cij = < S_y(final) * I_y(final) >
|
||||
c
|
||||
do 800 mx=1,max1
|
||||
do 780 m =1,jr
|
||||
c
|
||||
do 700 n=1,nsig
|
||||
i1=ii(n)
|
||||
j1=jj(n)
|
||||
do 690 my=1,maxi
|
||||
do 680 mp=1,js
|
||||
a(mp,my)=0.0
|
||||
do 640 m1=1,maxi
|
||||
do 620 m2=1,js
|
||||
a(mp,my)=a(mp,my)+sr(m2,m ,m1,mx)*s(m2,mp,i1)*s(m1,my,j1)
|
||||
620 continue
|
||||
640 continue
|
||||
c
|
||||
csig(n)=csig(n)+conjg(sr(mp,m ,my,mx))*a(mp,my)
|
||||
680 continue
|
||||
690 continue
|
||||
700 continue
|
||||
c
|
||||
780 continue
|
||||
800 continue
|
||||
do 820 n=1,nsig
|
||||
csig(n) = csig(n)/Pol(1)
|
||||
820 continue
|
||||
csig(3)=-csig(3)
|
||||
c
|
||||
c rotate operators to outgoing particle direction
|
||||
c
|
||||
c Minus signs on C_zz, C_xx and C_xz make output agree with the data
|
||||
c where the z and x axes for the target are in opposite directions
|
||||
c to those of the projectile
|
||||
c
|
||||
Cij(3) = -(csig(1)*cs**2 + csig(2)*ss**2 + 2.0*csig(4)*cs*ss)
|
||||
Cij(1) = -(csig(1)*ss**2 + csig(2)*cs**2 - 2.0*csig(4)*cs*ss)
|
||||
Cij(4) = -(csig(4)*(cs**2-ss**2) + (csig(2)-csig(1))*cs*ss)
|
||||
Cij(2) = csig(3)
|
||||
endif
|
||||
c
|
||||
c Singlet fraction
|
||||
ssum = (1.0-(csig(1)+csig(2)+csig(3)))/4.0
|
||||
Dij(3) = dsig(1)
|
||||
Dij(1) = dsig(2)
|
||||
Dij(4) = dsig(4)
|
||||
Dij(2) = dsig(3)
|
||||
ENDIF
|
||||
900 continue
|
||||
c
|
||||
do 980 i=2,npol
|
||||
Pol(i) = Pol(i)/Pol(1)
|
||||
980 continue
|
||||
Dnn = Dnn /Pol(1)
|
||||
Knn = Knn /Pol(1)
|
||||
Pol(1) = Pol(1)/float(max1*jr)
|
||||
1000 continue
|
||||
c
|
||||
c --------------------------------------------------------
|
||||
c output to disk file 20 and file 21
|
||||
c
|
||||
if(iopen20) then
|
||||
open(unit = 20, file = 'for020.dat', status = 'unknown')
|
||||
open(unit = 21, file = 'for021.dat', status = 'unknown')
|
||||
iopen20 = .false.
|
||||
endif
|
||||
c
|
||||
if(iout20) then
|
||||
c Write header to file
|
||||
if(nth .eq. 1) then
|
||||
WRITE(20,9010)ALPHA,IDAT
|
||||
write(20,9020) ntheta
|
||||
WRITE(21,9010)ALPHA,IDAT
|
||||
write(21,9021) ntheta
|
||||
endif
|
||||
c
|
||||
write(20,'(2(0pf8.3,1h,), 1pe12.4, 9(1h,,0pf8.4))')
|
||||
1 theta, cs, (Pol(i),i=1,3), Dnn, Knn
|
||||
c
|
||||
write(21,'(0pf8.3,1h,,0pf8.3, 9(1h,,0pf8.4))')
|
||||
1 theta, cs, Cij, Dij, ssum
|
||||
endif
|
||||
c
|
||||
return
|
||||
c
|
||||
9010 FORMAT(' (',15A4,I4.2,2(1H/,I2.2),I4.2,2(1H:,I2.2))
|
||||
9020 FORMAT(' (',i2,',angle cos[th] Sigma Pol Asy'
|
||||
1 ,' Dnn Knn')
|
||||
9021 FORMAT(' (',i2,',angle cos[th] Cxx Cyy Czz'
|
||||
1 ,' Cxz Dxx Dyy Dzz Dxz fsingl')
|
||||
c
|
||||
end
|
||||
812
dwuck4/culib4/POTS.FOR
Normal file
812
dwuck4/culib4/POTS.FOR
Normal file
|
|
@ -0,0 +1,812 @@
|
|||
c***********************************************************************
|
||||
SUBROUTINE POTS(U,V)
|
||||
c
|
||||
c Calculates the potentials or form factors
|
||||
c***********************************************************************
|
||||
c
|
||||
c IMPLICIT REAL*8(A-H,O-Z)
|
||||
COMMON/POTTER/DRX,AFACT(2),VFACT,SFACT,ENG,RM,G(4),ETAX,FKX,ETAKX
|
||||
1 ,RCX,HBARC2,ABETA(3),FLDF(3)
|
||||
2 ,NX,LAMX,KMXX,KX,IBX,LPLUSX,ICON4,NSPC,IDIRAC,ICHK
|
||||
|
||||
CHARACTER*18 B(26)
|
||||
DIMENSION UT(5),CN(16),CP(16),YLAM(16),PLM(8)
|
||||
1 ,XG(8),WG(8),U(800),V(800),LDFRM(3)
|
||||
C DIMENSION UD(800)
|
||||
EQUIVALENCE (YLAM(1),PLM(1))
|
||||
C
|
||||
c
|
||||
DATA b / ' NX=0 No potential', ' NX=1 VOLUME W-S '
|
||||
1, ' NX=2 SURFAC, W-S ', ' NX=3 2ND DERIV ', ' NX=4 L.S VOLUME '
|
||||
2, ' NX=5 L.S SURFACE ', ' NX=6 VOL*R**POWR ', ' NX=7 SUR*R**POWR '
|
||||
3, ' NX=8 EXTERN FORMF', ' NX=9 HARMONIC OSC', ' NX=10 GAUSSIAN '
|
||||
4, ' NX=11 DEFORM VOL ', ' NX=12 DEFORM SURF', ' NX=13 Hulthen '
|
||||
5, ' NX=14 Yukawa Lam ', ' NX=15 Yukawa L*S ', ' NX=16 NO OPTION '
|
||||
6, ' NX=17 NO OPTION ', ' NX=18 NO OPTION ', ' NX=19 NO OPTION '
|
||||
7, ' NX=20 VECTOR ', ' NX=21 SCALAR ', ' NX=22 Not used '
|
||||
8, ' NX=23 Not used ', ' NX=24 Not used ', ' NX=25 Not used '
|
||||
9/
|
||||
C
|
||||
DATA NG,NGX/8,0/
|
||||
C
|
||||
ETA4 = 6.0
|
||||
ETA5 =10.0
|
||||
SQRPI= 1.772453851
|
||||
PI=3.141592654
|
||||
C
|
||||
IVFLAG=0
|
||||
ISFLAG=0
|
||||
FACT=VFACT
|
||||
70 CONTINUE
|
||||
C
|
||||
C READ IN CARD SET 5,6,OR 7 POTENTIAL CARDS
|
||||
C
|
||||
READ (5,9000)FZ,VR,RY,AR,VSOR,VI,RZ,AI,VSOI,PWR
|
||||
C
|
||||
NZ=ABS(FZ)
|
||||
RR=ABS(RY)*AFACT(1)
|
||||
IF(RY.LT.0.0) RR=RR+ABS(RY)*AFACT(2)
|
||||
RI=ABS(RZ)*AFACT(1)
|
||||
IF(RZ.LT.0.0) RI=RI+ABS(RZ)*AFACT(2)
|
||||
IF(ICON4.NE.2.OR.NSPC.LT.3) THEN
|
||||
WRITE(6,9509)B(NZ+1),VR,RY,AR,RR,VSOR
|
||||
WRITE(6,9510) VI,RZ,AI,RI,VSOI,PWR
|
||||
ENDIF
|
||||
C
|
||||
KFLAG=0
|
||||
IF(NX.LT.3) THEN
|
||||
VR=VR*FACT
|
||||
VI=VI*FACT
|
||||
KT=FKX * MAX (RR,RI)+ETA5
|
||||
LPLUSX=MAX0(LPLUSX,KT)
|
||||
KT=(2.3*ETA4* MAX (AR,AI)+ MAX (RR,RI))/DRX
|
||||
ELSE
|
||||
IF(ENG.EQ.0.0) THEN
|
||||
KT=(2.3*ETA4* MAX (AR,AI)+ MAX (RR,RI))/DRX
|
||||
ELSE
|
||||
RM= MAX (RM,RR)
|
||||
RM= MAX (RM,RI)
|
||||
IF(RM.EQ.0.0) RM=1.0
|
||||
VR=VR*FACT
|
||||
VI=VI*FACT
|
||||
KT=(2.3*ETA4/SQRT(FKX**2+2.0*ETAX*FKX/RM))/DRX
|
||||
ENDIF
|
||||
ENDIF
|
||||
KX=MIN0(MAX0(KX,KT),KMXX)
|
||||
83 CONTINUE
|
||||
IF(AR.EQ.0.0) THEN
|
||||
F1=0.0
|
||||
F2=0.0
|
||||
ELSE
|
||||
F2=EXP(-DRX /AR)
|
||||
F1=EXP( RR/AR)
|
||||
ENDIF
|
||||
IF(AI.EQ.0.0) THEN
|
||||
F3=0.0
|
||||
F4=0.0
|
||||
ELSE
|
||||
F4=EXP(-DRX /AI)
|
||||
F3=EXP( RI/AI)
|
||||
ENDIF
|
||||
C
|
||||
IF(NX.GE.3.AND.ENG.EQ.0.0.AND.NZ.LE.5) THEN
|
||||
IF(AR.NE.0.0) VR=VR*(RR/AR)**(PWR+1)
|
||||
IF(AI.NE.0.0) VI=VI*(RI/AI)**(PWR+1)
|
||||
ENDIF
|
||||
IF(NZ.EQ.0) GO TO 6050
|
||||
GO TO ( 100, 200, 300, 400, 500, 600, 700, 800, 900,1000),NZ
|
||||
GO TO (1100,1200,1300,1400,1500,1600,1700,1800,1900,2000),NZ-10
|
||||
GO TO (2100),NZ-20
|
||||
write(6,'(''0Invalid potential option '',i3)')nz
|
||||
|
||||
C
|
||||
C VOLUME WOODS SAXON
|
||||
C
|
||||
100 CONTINUE
|
||||
DO 160 M=1,KX
|
||||
MK=M+M-1
|
||||
F1=F1*F2
|
||||
F3=F3*F4
|
||||
U(MK )=U(MK )-VR*F1/(1.0+F1)
|
||||
U(MK+1)=U(MK+1)-VI*F3/(1.0+F3)
|
||||
160 CONTINUE
|
||||
GO TO 6000
|
||||
C
|
||||
C 1ST DERIVATIVE WOODS SAXON
|
||||
C
|
||||
200 CONTINUE
|
||||
DO 260 M=1,KX
|
||||
MK=M+M-1
|
||||
F1=F1*F2
|
||||
F3=F3*F4
|
||||
U(MK )=U(MK )+VR*F1/(1.0+F1)**2
|
||||
U(MK+1)=U(MK+1)+VI*F3/(1.0+F3)**2
|
||||
260 CONTINUE
|
||||
GO TO 6000
|
||||
C
|
||||
C 2ND DERIVATIVE WOODS SAXON
|
||||
C
|
||||
300 CONTINUE
|
||||
DO 360 M=1,KX
|
||||
MK=M+M-1
|
||||
F1=F1*F2
|
||||
F3=F3*F4
|
||||
U(MK )=U(MK )-VR*F1*(1.0-F1)/(1.0+F1)**3
|
||||
U(MK+1)=U(MK+1)-VI*F3*(1.0-F3)/(1.0+F3)**3
|
||||
360 CONTINUE
|
||||
GO TO 6000
|
||||
C
|
||||
C L.S VOLUME WOODS SAXON
|
||||
C
|
||||
400 CONTINUE
|
||||
IBX=1
|
||||
IF(AR.NE.0.0) VR=VR/AR
|
||||
IF(AI.NE.0.0) VI=VI/AI
|
||||
R=0.0
|
||||
DO 460 M=1,KX
|
||||
R=R+DRX
|
||||
MK=M+M-1
|
||||
F1=F1*F2
|
||||
F3=F3*F4
|
||||
V(MK )=V(MK )-VR*F1/(R*(1.0+F1)**2)
|
||||
V(MK+1)=V(MK+1)-VI*F3/(R*(1.0+F3)**2)
|
||||
460 CONTINUE
|
||||
GO TO 6000
|
||||
C
|
||||
C L.S 1ST DERIVATIVE WOODS SAXON
|
||||
C
|
||||
500 CONTINUE
|
||||
IBX=1
|
||||
IF(AR.NE.0.0) VR=VR/AR
|
||||
IF(AI.NE.0.0) VI=VI/AI
|
||||
R=0.0
|
||||
DO 560 M=1,KX
|
||||
R=R+DRX
|
||||
MK=M+M-1
|
||||
F1=F1*F2
|
||||
F3=F3*F4
|
||||
V(MK )=V(MK )+VR*F1*(1.0-F1)/(R*(1.0+F1)**3)
|
||||
V(MK+1)=V(MK+1)+VI*F3*(1.0-F3)/(R*(1.0+F3)**3)
|
||||
560 CONTINUE
|
||||
GO TO 6000
|
||||
C
|
||||
C WOOD SAXON*R**PWR
|
||||
C
|
||||
600 CONTINUE
|
||||
R=0.0
|
||||
DO 660 M=1,KX
|
||||
R=R+DRX
|
||||
MK=M+M-1
|
||||
F1=F1*F2
|
||||
F3=F3*F4
|
||||
RPWR=R**PWR
|
||||
U(MK )=U(MK )-VR*F1*RPWR/(1.0+F1)
|
||||
U(MK+1)=U(MK+1)-VI*F3*RPWR/(1.0+F3)
|
||||
660 CONTINUE
|
||||
GO TO 6000
|
||||
C
|
||||
C 1ST DERIVATIVE WOOD SAXON*R**PWR
|
||||
C
|
||||
700 CONTINUE
|
||||
R=0.0
|
||||
DO 760 M=1,KX
|
||||
MK=M+M-1
|
||||
R=R+DRX
|
||||
F1=F1*F2
|
||||
F3=F3*F4
|
||||
RPWR=R**PWR
|
||||
U(MK )=U(MK )+VR*F1*RPWR/(1.0+F1)**2
|
||||
U(MK+1)=U(MK+1)+VI*F3*RPWR/(1.0+F3)**2
|
||||
760 CONTINUE
|
||||
GO TO 6000
|
||||
C
|
||||
C EXTERNAL FORM FACTOR
|
||||
C
|
||||
800 CONTINUE
|
||||
IF(NX.GE.3) THEN
|
||||
READ (5,9000)G
|
||||
WRITE(6,9508)G
|
||||
ENDIF
|
||||
READ(5,9000)F1,F2
|
||||
C
|
||||
C F2 = 0 REAL CENTRAL
|
||||
C F2 = 1 IMAG CENTRAL
|
||||
C F2 = 2 REAL SPIN ORBIT
|
||||
C F2 = 3 IMAG SPIN ORBIT
|
||||
C
|
||||
IF(F2.EQ.0.0.OR.F2.EQ.2) THEN
|
||||
F3=VR
|
||||
MK=1
|
||||
ELSE
|
||||
F3=VI
|
||||
MK=2
|
||||
ENDIF
|
||||
IF(F3.EQ.0.0) F3=1.0
|
||||
KT=F1
|
||||
DO 820 M=1,KT,5
|
||||
READ(5,9100)UT
|
||||
IF(M.GT.KMXX) GO TO 820
|
||||
DO 810 I=1,5
|
||||
IF(F2.LT.2.0) THEN
|
||||
U(MK )=U(MK )+UT(I)*F3
|
||||
ELSE
|
||||
V(MK )=V(MK )+UT(I)*F3
|
||||
ENDIF
|
||||
MK=MK+2
|
||||
810 CONTINUE
|
||||
820 CONTINUE
|
||||
C
|
||||
KX=min0(KT,kmxx)
|
||||
|
||||
GO TO 6000
|
||||
C
|
||||
C HARMONIC OSCILLATOR, NORMALIZED N*EXP(-(R/RY)**2/2)
|
||||
C
|
||||
900 CONTINUE
|
||||
READ (5,9000)G
|
||||
WRITE(6,9508)G
|
||||
F1=1.0/RY**2
|
||||
F2=F1/RY
|
||||
F3=0.5
|
||||
F4=SQRPI*0.5
|
||||
L=G(2)
|
||||
IF(L.NE.0) THEN
|
||||
DO 930 I=1,L
|
||||
F3=F3+1.0
|
||||
F4=F4*F3
|
||||
F2=F2*F1
|
||||
930 CONTINUE
|
||||
ENDIF
|
||||
NN=G(1)
|
||||
T1=1.0
|
||||
T2=F4
|
||||
C LAGUERRE POLYNOMIAL COEFFICIENTS = (Abramowitz-Stegun)*(-1)**nn
|
||||
CN(1)=(-1.0)**NN
|
||||
IF(NN.NE.0) THEN
|
||||
DO 940 I=1,NN
|
||||
F3=F3+1.0
|
||||
T1=T1*FLOAT(I)
|
||||
T2=T2*F3
|
||||
CN(I+1)=-CN(I)*F1*FLOAT(NN+1-I)/(FLOAT(I)*F3)
|
||||
940 CONTINUE
|
||||
ENDIF
|
||||
ANORM=SQRT(2.0*F2*T1/T2)*T2/(T1*F4)
|
||||
IF(VR.NE.0.0) ANORM=VR*ANORM
|
||||
KT=10.0*RY/DRX
|
||||
KT=MIN0(KT,KMXX)
|
||||
R=0.0
|
||||
F1=F1/2.0
|
||||
DO 960 M=1,KT
|
||||
MK=M+M-1
|
||||
R=R+DRX
|
||||
R2=R**2
|
||||
F2=CN(1)
|
||||
IF(NN.EQ.0) GO TO 951
|
||||
F3=1.0
|
||||
DO 950 I=1,NN
|
||||
F3=F3*R2
|
||||
F2=F2+CN(I+1)*F3
|
||||
950 CONTINUE
|
||||
951 CONTINUE
|
||||
U(MK )=U(MK )+F2*ANORM*EXP(-F1*R2)*R**L
|
||||
960 CONTINUE
|
||||
GO TO 6000
|
||||
C
|
||||
C EXP(-(R/R0)**2)*R**POWR
|
||||
C
|
||||
1000 CONTINUE
|
||||
IF(VR.NE.0.0) THEN
|
||||
R=0.0
|
||||
DO 1060 M=1,KX
|
||||
MK=M+M-1
|
||||
R=R+DRX
|
||||
U(MK )=U(MK )-VR*EXP(-(R/RY)**2)*R**PWR
|
||||
1060 CONTINUE
|
||||
endif
|
||||
IF(VI.NE.0.0) THEN
|
||||
R=0.0
|
||||
DO 1070 M=1,KX
|
||||
MK=M+M-1
|
||||
R=R+DRX
|
||||
U(MK+1)=U(MK+1)-VI*EXP(-(R/RZ)**2)*R**PWR
|
||||
1070 CONTINUE
|
||||
endif
|
||||
GO TO 6000
|
||||
C
|
||||
C DEFORMED VOLUME OR SURFACE BY YLM EXPANSION
|
||||
C
|
||||
1100 CONTINUE
|
||||
IF(NGX.NE.NG) THEN
|
||||
CALL LEGAUS(2*NG,XG,WG)
|
||||
NGX=NG
|
||||
ENDIF
|
||||
T2=(-1.0)**LAMX
|
||||
IF(ICHK.EQ.0) THEN
|
||||
READ (5,9000) (ABETA(J),FLDF(J) ,J=1,3)
|
||||
WRITE(6,9000)
|
||||
WRITE(6,9512) (ABETA(J),FLDF(J) ,J=1,3)
|
||||
ENDIF
|
||||
LMAX=LAMX+1
|
||||
DO 1101 J=1,3
|
||||
LDFRM(J)=FLDF(J)
|
||||
LMAX=MAX0(LMAX,LDFRM(J)+1)
|
||||
1101 CONTINUE
|
||||
T2=(-1.0)**LAMX
|
||||
C
|
||||
DO 1108 I=1,NG
|
||||
CN(I )=0.0
|
||||
CN(I+NG)=0.0
|
||||
P2=0.0
|
||||
P3=1.0
|
||||
C
|
||||
DO 1106 M=1,LMAX
|
||||
L=M-1
|
||||
FL=L-1
|
||||
IF(L.EQ.0) GO TO 1102
|
||||
P3=((2.0*FL+1.0)*XG(I)*P2-FL*P1)/(FL+1.0)
|
||||
1102 CONTINUE
|
||||
DO 1103 J=1,3
|
||||
IF(ABETA(J).EQ.0.0) GO TO 1103
|
||||
IF(L.NE.LDFRM(J)) GO TO 1103
|
||||
FACTOR=P3*ABETA(J)*SQRT(FLOAT(L+L+1)/(4.0*PI))
|
||||
CN(I )=CN(I )+FACTOR
|
||||
CN(I+NG)=CN(I+8)+FACTOR*(-1.0)**LDFRM(J)
|
||||
1103 CONTINUE
|
||||
IF(L.NE.LAMX) GO TO 1104
|
||||
YLAM(I )= P3*WG(I)*SQRT(FLOAT(L+L+1)*PI)
|
||||
YLAM(I+NG)=YLAM(I )*T2
|
||||
1104 CONTINUE
|
||||
P1=P2
|
||||
P2=P3
|
||||
1106 CONTINUE
|
||||
1108 CONTINUE
|
||||
DO 1170 I=1,2
|
||||
IF(I.EQ.1) THEN
|
||||
IF(VR.EQ.0.0) GO TO 1170
|
||||
VX=VR
|
||||
RX=RR
|
||||
AX=AR
|
||||
F1=1.0
|
||||
IFL=-1
|
||||
ELSE
|
||||
IF(VI.EQ.0.0) GO TO 1170
|
||||
VX=VI
|
||||
RX=RI
|
||||
AX=AI
|
||||
F1=1.0
|
||||
F2=F4
|
||||
IFL=0
|
||||
ENDIF
|
||||
DO 1135 J=1,16
|
||||
CP(J)=EXP((1.0+CN(J))*RX/AX)
|
||||
1135 CONTINUE
|
||||
IF(LAMX.EQ.0) VX=VX/(SQRPI*2.0)
|
||||
J=NZ-10
|
||||
IF(J.EQ.2) GO TO 1151
|
||||
DO 1150 M=1,KX
|
||||
MK=M+M+IFL
|
||||
VTEMP=0.0
|
||||
F1=F1*F2
|
||||
DO 1145 J=1,16
|
||||
F3=F1*CP(J)
|
||||
VTEMP=VTEMP-YLAM(J)*VX*F3/(1.0+F3)
|
||||
1145 CONTINUE
|
||||
U(MK )=U(MK )+VTEMP
|
||||
1150 CONTINUE
|
||||
GO TO 1170
|
||||
1151 CONTINUE
|
||||
DO 1160 M=1,KX
|
||||
MK=M+M+IFL
|
||||
VTEMP=0.0
|
||||
F1=F1*F2
|
||||
DO 1155 J=1,16
|
||||
F3=F1*CP(J)
|
||||
VTEMP=VTEMP+YLAM(J)*VX*F3/(1.0+F3)**2
|
||||
1155 CONTINUE
|
||||
U(MK )=U(MK )+VTEMP
|
||||
1160 CONTINUE
|
||||
1170 CONTINUE
|
||||
GO TO 6000
|
||||
1200 CONTINUE
|
||||
GO TO 1100
|
||||
C
|
||||
C HULTHEN WAVE FUNCTION= NORM*(EXP(-R/RY)-EXP(-R/RZ))/R
|
||||
C
|
||||
1300 CONTINUE
|
||||
READ (5,9000)G
|
||||
WRITE(6,9508)G
|
||||
T1=1.0/RY
|
||||
T2=1.0/RZ
|
||||
T3=T2**2-T1**2
|
||||
T4=SQRT(2.0*T1*(T1+T2)*T2)/(T2-T1)
|
||||
IF(VR.NE.0.0) KT=16.0* MIN (RY,RZ)/DRX
|
||||
IF(VR.EQ.0.0) KT=16.0* MAX (RY,RZ)/DRX
|
||||
KX=MIN0(KX,KMXX)
|
||||
F1=1.0
|
||||
F2=EXP(-DRX *T1)
|
||||
F3=1.0
|
||||
F4=EXP(-DRX *T2)
|
||||
R=0.0
|
||||
DO 1260 M=1,KX
|
||||
MK=M+M-1
|
||||
R=R+DRX
|
||||
F1=F1*F2
|
||||
F3=F3*F4
|
||||
V(M)=T3*F3/(F1-F3)
|
||||
TEMP=1.0
|
||||
IF(VR.NE.0.0) TEMP=V(M)/FACT
|
||||
U(MK )=U(MK )+TEMP*T4*(F1-F3)/R
|
||||
1260 CONTINUE
|
||||
GO TO 6000
|
||||
c
|
||||
c Yukawa L=LAM
|
||||
c
|
||||
c v = V-0*exp(-r/rx)/(r/rx) ay < r
|
||||
c = Wood-Saxon r < ay
|
||||
c
|
||||
1400 CONTINUE
|
||||
lam=lamx
|
||||
if(ry.eq.0.0) ry=1.0
|
||||
if(rz.eq.0.0) rz=1.0
|
||||
if(ar.eq.0.0) ar=drx
|
||||
if(ai.eq.0.0) ai=drx
|
||||
f1=1.0
|
||||
f2=exp(-drx/ry)
|
||||
xr=ar/ry
|
||||
t1=1.0+1.0/xr
|
||||
t2=1.0
|
||||
c Recur Hankel functions
|
||||
do 1420 i=0,lam
|
||||
t0=t1
|
||||
t1=t2
|
||||
t2=float(2*i-1)*t1/xr+t0
|
||||
1420 continue
|
||||
vzr =2.0*vr*t2*exp(-xr)/xr
|
||||
betar=2.0*(float(lam+1)*t2/xr+t1)/t2
|
||||
f3=1.0
|
||||
f4=exp(-drx/rz)
|
||||
xi=ai/rz
|
||||
t1=1.0+1.0/xi
|
||||
t2=1.0
|
||||
c Recur Hankel functions
|
||||
do 1430 i=0,lam
|
||||
t0=t1
|
||||
t1=t2
|
||||
t2=float(2*i-1)*t1/xi+t0
|
||||
1430 continue
|
||||
vzi =2.0*vi*t2*exp(-xi)/xi
|
||||
betai=2.0*(float(lam+1)*t2/xi+t1)/t2
|
||||
c
|
||||
if(vr.ne.0.0) then
|
||||
r =0.0
|
||||
do 1460 m=1,k
|
||||
r=r+drx
|
||||
mk=m+m-1
|
||||
f1=f1*f2
|
||||
f3=f3*f4
|
||||
if(r.lt.ar) then
|
||||
u(mk )=u(mk )-vzr/(1.0+exp(betar*(r/ry-xr)))
|
||||
else
|
||||
xr=r/ry
|
||||
t1=1.0+1.0/xr
|
||||
t2=1.0
|
||||
c Recur Hankel functions
|
||||
do 1450 i=0,lam
|
||||
t0=t1
|
||||
t1=t2
|
||||
t2=float(2*i-1)*t1/xr+t0
|
||||
1450 continue
|
||||
u(mk )=u(mk )-vr*t2*f1/xr
|
||||
endif
|
||||
1460 continue
|
||||
endif
|
||||
if(vi.ne.0.0) then
|
||||
r =0.0
|
||||
do 1480 m=1,k
|
||||
r=r+drx
|
||||
mk=m+m-1
|
||||
if(r.lt.ai) then
|
||||
u(mk+1)=u(mk+1)-vzi/(1.0+exp(betai*(r/rz-xi)))
|
||||
else
|
||||
xi=r/rz
|
||||
t1=1.0+1.0/xi
|
||||
t2=1.0
|
||||
c Recur Hankel functions
|
||||
do 1470 i=0,lam
|
||||
t0=t1
|
||||
t1=t2
|
||||
t2=float(2*i-1)*t1/xi+t0
|
||||
1470 continue
|
||||
u(mk+1)=u(mk+1)-vi*t2*f3/xi
|
||||
endif
|
||||
1480 continue
|
||||
endif
|
||||
go to 6000
|
||||
c
|
||||
c Yukawa L*S
|
||||
c
|
||||
1500 CONTINUE
|
||||
r =0.0
|
||||
if(ry.eq.0.0) ry=1.0
|
||||
if(rz.eq.0.0) rz=1.0
|
||||
if(ar.eq.0.0) ar=1.0
|
||||
if(ai.eq.0.0) ai=1.0
|
||||
f1=1.0
|
||||
f2=exp(-drx/ry)
|
||||
xr=ar/ry
|
||||
betar=2.0*(1.0+3.0/xr+3.0/xr**2)/(1.0+1.0/xr)
|
||||
vzr =2.0*vr*exp(-xr)*(1.0+1.0/xr)/xr**2
|
||||
f3=1.0
|
||||
f4=exp(-drx/rz)
|
||||
xi=ai/rz
|
||||
betai=2.0*(1.0+3.0/xi+3.0/xi**2)/(1.0+1.0/xi)
|
||||
vzi =2.0*vi*exp(-xi)*(1.0+1.0/xi)/xi**2
|
||||
do 1560 m=1,k
|
||||
r=r+drx
|
||||
mk=m+m-1
|
||||
f1=f1*f2
|
||||
f3=f3*f4
|
||||
if(r.lt.ar) then
|
||||
u(mk )=u(mk )-vzr/(1.0+exp(betar*(r/ry-xr)))
|
||||
else
|
||||
u(mk )=u(mk )-vr *f1*(1.0+1.0*ry/r)/(r/ry)**2
|
||||
endif
|
||||
if(r.lt.ai) then
|
||||
u(mk+1)=u(mk+1)-vzi/(1.0+exp(betai*(r/rz-xi)))
|
||||
else
|
||||
u(mk+1)=u(mk+1)-vi *f3*(1.0+1.0*rz/r)/(r/rz)**2
|
||||
endif
|
||||
1560 continue
|
||||
go to 6000
|
||||
1600 CONTINUE
|
||||
1700 CONTINUE
|
||||
go to 6000
|
||||
1800 CONTINUE
|
||||
DO 1860 M=1,KX
|
||||
MK=M+M-1
|
||||
F1=F1*F2
|
||||
F3=F3*F4
|
||||
V(MK )=V(MK )-VR*F1/(1.0+F1)
|
||||
V(MK+1)=V(MK+1)-VI*F3/(1.0+F3)
|
||||
1860 CONTINUE
|
||||
GO TO 6000
|
||||
1900 CONTINUE
|
||||
c
|
||||
c Coulomb excitation for a deformed uniform charge distribution
|
||||
c
|
||||
IF(ICHK.EQ.0) THEN
|
||||
READ (5,9000) (ABETA(J),FLDF(J) ,J=1,3)
|
||||
WRITE(6,9000)
|
||||
WRITE(6,9512) (ABETA(J),FLDF(J) ,J=1,3)
|
||||
ENDIF
|
||||
if(vr.eq.0.0) vr=1.0
|
||||
do 1990 i=1,3
|
||||
beta=abeta(i)
|
||||
if(beta.ne.0.0) then
|
||||
c set flag for unbound stripping evaluation of coulomb ex.
|
||||
ibx=4
|
||||
flam1=beta*sqrt(float(2*lamx+1)/(4.0*pi))
|
||||
flam2=flam1*phasef(lamx)
|
||||
c
|
||||
if(ngx.ne.ng) then
|
||||
ngx=ng
|
||||
call legaus(2*ng,xg,wg)
|
||||
endif
|
||||
c
|
||||
an=0.0
|
||||
do 1920 k=1,ng
|
||||
p1=0.0
|
||||
p2=1.0
|
||||
if(lamx.gt.0) then
|
||||
do 1910 j=1,lamx
|
||||
p3=(float(2*j-1)*xg(k)*p2 - float(j-1)*p1)/float(j)
|
||||
p1=p2
|
||||
p2=p3
|
||||
1910 continue
|
||||
endif
|
||||
plm(k)=p2
|
||||
c
|
||||
c calculate normalization
|
||||
c
|
||||
r1=rcx*(1.0+flam1*p2)
|
||||
r2=rcx*(1.0+flam2*p2)
|
||||
an=an+(r1**3+r2**3)*wg(k)
|
||||
1920 continue
|
||||
c
|
||||
an =an/3.0
|
||||
c
|
||||
r =0.0
|
||||
c
|
||||
do 1940 m=1,kx
|
||||
mk=m+m-1
|
||||
r=r+drx
|
||||
sum=0.0
|
||||
do 1930 k=1,ng
|
||||
r1=rcx*(1.0+flam1*plm(k))
|
||||
r2=rcx*(1.0+flam2*plm(k))
|
||||
c
|
||||
if(r.gt.r1) then
|
||||
s1=r1**(lamx+3)/(r**(lamx+1)*float(lamx+3))
|
||||
else
|
||||
if(lamx.eq.2) then
|
||||
s1=( log(r1/r)+1.0/float(lamx+3))*r**2
|
||||
else
|
||||
s1=(r**lamx/r1**(lamx-2)
|
||||
1 -float(2*lamx+1)*r**2/float(lamx+3))/float(2-lamx)
|
||||
endif
|
||||
endif
|
||||
c
|
||||
if(r.gt.r2) then
|
||||
s2=r2**(lamx+3)/(r**(lamx+1)*float(lamx+3))
|
||||
else
|
||||
if(lamx.eq.2) then
|
||||
s2=( log(r2/r)+1.0/float(lamx+3))*r**2
|
||||
else
|
||||
s2=(r**lamx/r2**(lamx-2)
|
||||
1 -float(2*lamx+1)*r**2/float(lamx+3))/float(2-lamx)
|
||||
endif
|
||||
endif
|
||||
c
|
||||
sum=sum+(s1+s2*phasef(lamx))*wg(k)*plm(k)
|
||||
1930 continue
|
||||
c
|
||||
sum=sum/an
|
||||
if(beta.ne.0.0.and.lamx.ne.0) sum=sum/flam1
|
||||
u(mk )=u(mk )+sum*(vr*etakx/fact)
|
||||
1940 continue
|
||||
endif
|
||||
1990 continue
|
||||
GO TO 6000
|
||||
C
|
||||
C VECTOR POTENTIAL
|
||||
C VSOR, VSOI ARE THE THIRD PARAMETERS
|
||||
C IN THE 3 PARAMETER FERMI MODEL
|
||||
C [1 + VSO?*(R/R?)**2]
|
||||
C
|
||||
2000 CONTINUE
|
||||
IVFLAG=-1
|
||||
R=0.0
|
||||
DO 2060 M=1,KX
|
||||
MK=M+M-1
|
||||
R=R+DRX
|
||||
F1=F1*F2
|
||||
F3=F3*F4
|
||||
U(MK )=U(MK )-VR*F1*(1.0+VSOR*(R/RR)**2)/(1.0+F1)
|
||||
U(MK+1)=U(MK+1)-VI*F3*(1.0+VSOI*(R/RI)**2)/(1.0+F3)
|
||||
2060 CONTINUE
|
||||
GO TO 6020
|
||||
C
|
||||
C SCALAR POTENTIAL
|
||||
C VSOR, VSOI ARE THE FERMI THIRD PARAMETERS
|
||||
C IN THE 3 PARAMETER FERMI MODEL
|
||||
C [1 + VSO?*(R/R?)**2]
|
||||
C
|
||||
2100 CONTINUE
|
||||
ISFLAG=-1
|
||||
VR=VR*(SFACT/VFACT)
|
||||
VI=VI*(SFACT/VFACT)
|
||||
R=0.0
|
||||
DO 2160 M=1,KX
|
||||
MK=M+M-1
|
||||
R=R+DRX
|
||||
F1=F1*F2
|
||||
F3=F3*F4
|
||||
V(MK )=V(MK )-VR*F1*(1.0+VSOR*(R/RR)**2)/(1.0+F1)
|
||||
V(MK+1)=V(MK+1)-VI*F3*(1.0+VSOI*(R/RI)**2)/(1.0+F3)
|
||||
2160 CONTINUE
|
||||
GO TO 6020
|
||||
C
|
||||
C END OF POTENTIALS
|
||||
C
|
||||
6000 CONTINUE
|
||||
IDIRAC=1
|
||||
6020 CONTINUE
|
||||
IF(KFLAG.NE.0.OR.NZ.GT.5) GO TO 6050
|
||||
IF(ABS(VSOR)+ABS(VSOI).EQ.0.0) GO TO 6050
|
||||
NZ=NZ+3
|
||||
KFLAG=1
|
||||
VR=VR*VSOR/45.2
|
||||
VI=VI*VSOI/45.2
|
||||
GO TO 83
|
||||
6050 CONTINUE
|
||||
IF(FZ.GT.0.0) GO TO 70
|
||||
C
|
||||
C PROCESS DIRAC POTENTIALS
|
||||
C
|
||||
C ENTRY WITH U -> K**2 - VFACT*V VFACT = 2.0*W1 /HBARC**2
|
||||
C V -> - SFACT*S SFACT = 2.0*FM1/HBARC**2
|
||||
C
|
||||
IF(IVFLAG.NE.0.AND.ISFLAG.NE.0) THEN
|
||||
IF(IDIRAC.EQ.1) THEN
|
||||
WRITE(6,9515)
|
||||
ENDIF
|
||||
IDIRAC=-1
|
||||
C
|
||||
C KT2=KX+KX
|
||||
C WRITE(20,7777)' ENTRY POTENTIALS'
|
||||
C WRITE(20,7778)(U(I),I=1,KT2)
|
||||
C WRITE(20,7777)
|
||||
C WRITE(20,7778)(V(I),I=1,KT2)
|
||||
W1M1=(VFACT+SFACT)*0.5*HBARC2
|
||||
|
||||
DO 6100 M=1,Kx
|
||||
MK=M+M-1
|
||||
VVR=(U(MK )-FKX**2)/VFACT
|
||||
VVI= U(MK+1) /VFACT
|
||||
VSR= V(MK ) /SFACT
|
||||
VSI= V(MK+1) /SFACT
|
||||
U(MK )=U(MK )+V(MK ) +(VVR**2-VVI**2 - VSR**2+VSI**2)/HBARC2
|
||||
U(MK+1)=U(MK+1)+V(MK+1) +(VVR*VVI - VSR*VSI)*2.0/HBARC2
|
||||
T1 = W1M1 + VVR-VSR
|
||||
T2 = VVI-VSI
|
||||
V(MK )=0.5* LOG (T1**2 + T2**2)
|
||||
V(MK+1)=ATAN2(T2,T1)
|
||||
6100 CONTINUE
|
||||
C WRITE(20,7777)' SECOND POTENTIALS'
|
||||
C WRITE(20,7778)(U(I),I=1,KT2)
|
||||
C WRITE(20,7777)
|
||||
C WRITE(20,7778)(V(I),I=1,KT2)
|
||||
C
|
||||
R=FLOAT(KX+1)*DRX
|
||||
MK=KX+KX-1
|
||||
D2=V(MK )
|
||||
D1=D2
|
||||
A2=V(MK+1)
|
||||
A1=A2
|
||||
IBX=1
|
||||
DO 6150 M=2,KX
|
||||
MK=MK-2
|
||||
R=R-DRX
|
||||
D3=D2
|
||||
D2=D1
|
||||
D1=V(MK )
|
||||
A3=A2
|
||||
A2=A1
|
||||
A1=V(MK+1)
|
||||
C FIRST DERIVATIVE TERMS
|
||||
DPR=(D3-D1)/(2.0*DRX)
|
||||
DPI=(A3-A1)/(2.0*DRX)
|
||||
V(MK+2)=2.0*DPR/R
|
||||
V(MK+3)=2.0*DPI/R
|
||||
C SECOND DERIVATIVE TERMS
|
||||
DPPR=(D3+D1-2.0*D2)/DRX**2
|
||||
DPPI=(A3+A1-2.0*A2)/DRX**2
|
||||
UDR =0.5*DPPR-0.25*(DPR**2-DPI**2)+DPR/R
|
||||
UDI =0.5*DPPI-0.25*(2.0*DPR*DPI )+DPI/R
|
||||
C UD(MK+2)=UDR
|
||||
C UD(MK+3)=UDI
|
||||
U(MK+2)=U(MK+2)+UDR
|
||||
U(MK+3)=U(MK+3)+UDI
|
||||
6150 CONTINUE
|
||||
V(1 )=V(3 )*2.0
|
||||
V(2 )=V(4 )*2.0
|
||||
U(1 )=U(1 )+UDR
|
||||
U(2 )=U(2 )+UDI
|
||||
C WRITE(20,7777)'TERTIARY POTENTIALS'
|
||||
C WRITE(20,7777)'CENTRAL POTENTIAL'
|
||||
C WRITE(20,7778)(U(I),I=1,KT2)
|
||||
C WRITE(20,7777)'SPIN ORBIT POTENTIAL'
|
||||
C WRITE(20,7778)(V(I),I=1,KT2)
|
||||
C WRITE(20,7777)'UD - DARWIN TERM'
|
||||
C WRITE(20,7778)(UD(I),I=1,KT2)
|
||||
C 7777 FORMAT(A30)
|
||||
C 7778 FORMAT(' ',1P10E12.4)
|
||||
ENDIF
|
||||
C
|
||||
IF(IDIRAC.EQ.1) IDIRAC=0
|
||||
RETURN
|
||||
C
|
||||
9000 FORMAT(10F8.4)
|
||||
9100 FORMAT(5E16.7)
|
||||
9508 FORMAT(18X,9H NODES=,F9.4,9H L =,F9.4,9H 2*J =,F9.4
|
||||
1 ,9H 2*S =,F9.4,9H FISW =,F9.4)
|
||||
9509 FORMAT(A18,9H V RL =,F9.4,9H R0RL =,F9.4,9H A RL =,F9.4
|
||||
1 ,9H R RL =,F9.4,9H VSOR =,F9.4)
|
||||
9510 FORMAT(18X,9H V IM =,F9.4,9H R0IM =,F9.4,9H A IM =,F9.4
|
||||
1 ,9H R IM =,F9.4,9H VSOI =,F9.4,9H POWR =,F9.4)
|
||||
9512 FORMAT(18X,9H BETA1=,F9.4,9H LDFR1=,F9.4,9H BETA2=,F9.4
|
||||
1 ,9H LDFR2=,F9.4,9H BETA3=,F9.4,9H LDFR3=,F9.4)
|
||||
9515 FORMAT('0',20('*'),' WARNING, Mixing of Dirac and non-Dirac'
|
||||
1, ' potentials may be hazardous to your calculation'
|
||||
2, 20('*'))
|
||||
END
|
||||
135
dwuck4/culib4/SLATER.FOR
Normal file
135
dwuck4/culib4/SLATER.FOR
Normal file
|
|
@ -0,0 +1,135 @@
|
|||
|
||||
SUBROUTINE SLATR (KT,KMAX,DRF,VB,MINL,FMU,ICODE)
|
||||
c
|
||||
c Calculates expansion of potentials for Cathen
|
||||
c
|
||||
DIMENSION VB(800)
|
||||
C
|
||||
C YUKAWA SLATER EXPANSION
|
||||
C
|
||||
R=0.0
|
||||
IF(ICODE.EQ.2) GO TO 101
|
||||
C
|
||||
C HANKEL FUNCTION*EXP(+FMU*R)
|
||||
C
|
||||
F1=1.0
|
||||
F2=EXP(-FMU*DRF)
|
||||
DO 100 M=1,KMAX
|
||||
R=R+DRF
|
||||
X=FMU*R
|
||||
F1=F1*F2
|
||||
AZ=(1.0-F1*F1)/(2.0*X)
|
||||
B2=1.0/X
|
||||
B1=B2*(1.0+B2)
|
||||
FL=-1.0
|
||||
DO 50 LL=1,MINL
|
||||
B3=FL*B2/X+B1
|
||||
B1=B2
|
||||
B2=B3
|
||||
FL=FL+2.0
|
||||
50 CONTINUE
|
||||
VB(M+KMAX)=B2
|
||||
C
|
||||
C BESSEL FUNCTION*EXP(-FMU*R)
|
||||
C
|
||||
MAX=2.0*X+10.0
|
||||
MAX=MAX0(MAX,MINL+5)
|
||||
A3=0.0
|
||||
A2=1.0
|
||||
FL=MAX+MAX+3
|
||||
DO 70 LL=1,MAX
|
||||
N=MAX+1-LL
|
||||
FL=FL-2.0
|
||||
A1=A3+FL*A2/X
|
||||
IF(N.LT.MINL) GO TO 69
|
||||
IF(ABS(A1).LT.1.0E+20) GO TO 69
|
||||
A1=A1*1.0E-20
|
||||
A2=A2*1.0E-20
|
||||
69 CONTINUE
|
||||
IF(N.EQ.MINL) TEMP=A1
|
||||
A3=A2
|
||||
A2=A1
|
||||
70 CONTINUE
|
||||
VB(M )=TEMP*AZ/A1
|
||||
100 CONTINUE
|
||||
RETURN
|
||||
C
|
||||
C COULOMB SLATER EXPANSION
|
||||
C
|
||||
101 CONTINUE
|
||||
FL=MINL+MINL-1
|
||||
DO 200 M=1,KMAX
|
||||
R=R+DRF
|
||||
A2=1.0
|
||||
DO 105 LL=1,MINL
|
||||
A2=A2*R
|
||||
105 CONTINUE
|
||||
VB(M )=A2/(R*FL)
|
||||
VB(M+KMAX)=1.0/A2
|
||||
200 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE RADIN(KT,KMAX,DRF,FMU,VB,UB,UC,SL,OPT,SI,KMT,SK)
|
||||
c
|
||||
c Calculates slater integrals for Cathen
|
||||
c
|
||||
DIMENSION UB(400),UC(400),VB(800),SI(800),DG(2)
|
||||
DATA XRHO/80./
|
||||
c FLOAT(III)=DFLOAT(III)
|
||||
C
|
||||
KM1=KMAX
|
||||
KM2=KMAX*2
|
||||
KM3=KMAX*3
|
||||
DG(1)=2.0*DRF/3.0
|
||||
DG(2)=2.0*DG(1)
|
||||
F0=EXP( FMU*DRF)
|
||||
MMAX=XRHO/FMU/DRF
|
||||
R2=0.0
|
||||
SUMA=0.0
|
||||
SUMB=0.0
|
||||
SUMC=0.0
|
||||
SUMD=0.0
|
||||
DO 200 M=1,KT
|
||||
MK=M+M-1
|
||||
R2=R2+DRF
|
||||
F2=EXP(-FLOAT(MIN0(MMAX,M)-1)*FMU*DRF)
|
||||
SLL=0.0
|
||||
MX=1
|
||||
R1=0.0
|
||||
DO 100 MM=1,KT
|
||||
R1=R1+DRF
|
||||
MX=3-MX
|
||||
if(iabs(m-mm).lt.mmax) then
|
||||
if(m.lt.mm) then
|
||||
F2=F2/F0
|
||||
TEMP=VB(M)*VB(MM+KM3)*F2
|
||||
elseif(m.gt.mm) then
|
||||
TEMP=VB(MM+KM2)*VB(M+KM1)*F2
|
||||
F2=F2*F0
|
||||
else
|
||||
TEMP=0.5*(VB(M)*VB(M+KM3)+VB(M+KM2)*VB(M+KM1))
|
||||
endif
|
||||
F1=DG(MX)*UB(MM)*UC(MM)*R1**2
|
||||
SLL=SLL+F1*TEMP
|
||||
endif
|
||||
100 CONTINUE
|
||||
SLL=SLL*OPT
|
||||
R22=R2**2
|
||||
IF(M.EQ.KMT) SK=SLL
|
||||
SI(MK)=SI(MK)+SLL
|
||||
SUMA=SUMA+UB(M)*UC(M)*R22
|
||||
SUMB=SUMB+UB(M)*UC(M)*R22**2
|
||||
SUMC=SUMC+SLL*R22
|
||||
SUMD=SUMD+SLL*R22**2
|
||||
200 CONTINUE
|
||||
SUMA=SUMA*DRF
|
||||
SUMB=SUMB*DRF
|
||||
SUMC=SUMC*DRF
|
||||
SUMD=SUMD*DRF
|
||||
SL=SUMC
|
||||
WRITE(6,9100)SUMA,SUMB,SUMC,SUMD
|
||||
RETURN
|
||||
9100 FORMAT(13H0 J0 =,F11.4,7H J1 =,F11.4,7H K0 =,F11.4
|
||||
1 ,7H K1 =,F11.4)
|
||||
END
|
||||
249
dwuck4/culib8/ANGMOM.FOR
Normal file
249
dwuck4/culib8/ANGMOM.FOR
Normal file
|
|
@ -0,0 +1,249 @@
|
|||
c***********************************************************************
|
||||
FUNCTION VCC(JX1,JX2,JX3,MX1,MX2)
|
||||
c
|
||||
c Clebsch-Gordan Coefficient Routine
|
||||
c
|
||||
c***********************************************************************
|
||||
IMPLICIT REAL*8(A-H,O-Z)
|
||||
c EXTERNAL FACTOR
|
||||
COMMON/FACTRL/FACT(0:32)
|
||||
C
|
||||
VCC=0.0
|
||||
J1=JX1
|
||||
J2=JX2
|
||||
J3=JX3
|
||||
M1=MX1
|
||||
M2=MX2
|
||||
IF(J1.LT.J2) GO TO 20
|
||||
IF(J3.LT.J2) GO TO 30
|
||||
ICNTR=0
|
||||
GO TO 40
|
||||
20 IF(J3.LT.J1) GO TO 30
|
||||
ICNTR=-1
|
||||
IT=J1
|
||||
J1=J2
|
||||
J2=IT
|
||||
IT=M1
|
||||
M1=M2
|
||||
M2=IT
|
||||
GO TO 40
|
||||
30 ICNTR=1
|
||||
IT=J2
|
||||
J2=J3
|
||||
J3=IT
|
||||
M2=-M1-M2
|
||||
40 CONTINUE
|
||||
JZ1=(J1+J2-J3)/2
|
||||
IF(JZ1.LT.0) GO TO 150
|
||||
JZ2=(J1+J3-J2)/2
|
||||
IF(JZ2.LT.0) GO TO 150
|
||||
JZ3=(J2+J3-J1)/2
|
||||
IF(JZ3.LT.0) GO TO 150
|
||||
IF(J1-IABS(M1).LT.0) GO TO 150
|
||||
IF(J2-IABS(M2).LT.0) GO TO 150
|
||||
IF(J3-IABS(M1+M2).LT.0) GO TO 150
|
||||
JT1=(J1-J3+M2)/2
|
||||
JT2=(J2-J3-M1)/2
|
||||
NUMIN=MAX0 (JT1,JT2,0)
|
||||
JT3=(J1-M1)/2
|
||||
JT4=(J2+M2)/2
|
||||
NUMAX=MIN0 (JT3,JT4,JZ1)
|
||||
JT5=(J2-M2)/2
|
||||
IF(NUMAX.LT.NUMIN) GO TO 150
|
||||
J4=J1/2
|
||||
J5=J3/2
|
||||
PHAS=PHASEF(NUMIN)
|
||||
DO 100 NU=NUMIN,NUMAX
|
||||
VCC=VCC+PHAS *(YXFCT(JT3-NU,J4)*YXFCT(NU-JT2,J5))
|
||||
1/(FACT(JT4-NU)*FACT(NU-JT1)*FACT(JZ1-NU)*FACT(NU))
|
||||
PHAS=-PHAS
|
||||
100 CONTINUE
|
||||
FCTOR=YXFCT(J4,(J1+M1)/2)*YXFCT(J4,JT3)*YXFCT((J1+J2+J3)/2+1,JZ2)*
|
||||
1YXFCT(J5,(J3+M1+M2)/2)*YXFCT(J5,(J3-M1-M2)/2)*FACT(JZ1)*FACT(JZ3)*
|
||||
2FACT(JT4)*FACT(JT5)*FLOAT(J3+1)
|
||||
VCC=SQRT(FCTOR)*VCC
|
||||
IF(ICNTR)120,150,110
|
||||
110 VCC=VCC*SQRT(FLOAT(J2+1)/FLOAT(J3+1))*PHASEF(JT3)
|
||||
GO TO 150
|
||||
120 VCC=VCC*PHASEF(JZ1)
|
||||
150 RETURN
|
||||
END
|
||||
|
||||
c***********************************************************************
|
||||
FUNCTION PHASEF(N)
|
||||
c
|
||||
c Calculates (-1)**N
|
||||
c
|
||||
c***********************************************************************
|
||||
IMPLICIT REAL*8(A-H,O-Z)
|
||||
c
|
||||
PHASEF=FLOAT(1-2*IABS(N-2*(N/2)))
|
||||
RETURN
|
||||
END
|
||||
|
||||
c***********************************************************************
|
||||
FUNCTION YXFCT(M,N)
|
||||
c
|
||||
C COMPUTES N_FACTORIAL/M_FACTORIAL
|
||||
c
|
||||
c***********************************************************************
|
||||
IMPLICIT REAL*8(A-H,O-Z)
|
||||
c
|
||||
YXFCT=1.0
|
||||
NUMAX=M-N
|
||||
IF(NUMAX)30,100,20
|
||||
20 ICTRL=0
|
||||
FCTOR=N
|
||||
GO TO 40
|
||||
30 ICTRL=1
|
||||
NUMAX=-NUMAX
|
||||
FCTOR=M
|
||||
40 CONTINUE
|
||||
DO 50 NU=1,NUMAX
|
||||
FCTOR=FCTOR+1.0
|
||||
YXFCT=YXFCT*FCTOR
|
||||
50 CONTINUE
|
||||
IF(ICTRL.EQ.0) YXFCT=1.0/YXFCT
|
||||
100 RETURN
|
||||
END
|
||||
|
||||
c***********************************************************************
|
||||
FUNCTION RACAH(J1,J2,J3,J4,J5,J6)
|
||||
c
|
||||
c Calculates Racah coefficients
|
||||
c Spins are input as twice the spin
|
||||
c
|
||||
c***********************************************************************
|
||||
c
|
||||
IMPLICIT REAL*8(A-H,O-Z)
|
||||
logical jy_big
|
||||
c
|
||||
c EXTERNAL FACTOR
|
||||
COMMON/FACTRL/FACT(0:32)
|
||||
c
|
||||
RACAH=0.0
|
||||
Z1=DELR(J1,J2,J5)
|
||||
IF(Z1.EQ.0.0) GO TO 90
|
||||
Z1=DELR(J3,J4,J5)*Z1
|
||||
IF(Z1.EQ.0.0) GO TO 90
|
||||
Z2=DELR(J1,J3,J6)
|
||||
IF(Z2.EQ.0.0) GO TO 90
|
||||
Z2=DELR(J2,J4,J6)*Z2
|
||||
IF(Z2.EQ.0.0) GO TO 90
|
||||
Z1=SQRT(Z1/Z2)*Z2
|
||||
JT1=(J1+J2+J5)/2
|
||||
JT2=(J3+J4+J5)/2
|
||||
JT3=(J1+J3+J6)/2
|
||||
JT4=(J2+J4+J6)/2
|
||||
JZ1=(J1+J2+J3+J4)/2
|
||||
JZ2=(J1+J4+J5+J6)/2
|
||||
JZ3=(J2+J3+J5+J6)/2
|
||||
c
|
||||
NUMIN=MAX0 (JT1,JT2,JT3,JT4)
|
||||
NUMAX=MIN0 (JZ1,JZ2,JZ3)
|
||||
IF(NUMAX.ge.NUMIN) then
|
||||
if(NUMIN-JT4 .gt. JZ1-NUMIN) then
|
||||
jy_big = .true.
|
||||
else
|
||||
jy_big = .false.
|
||||
endif
|
||||
PHASE=PHASEF(NUMIN+JZ1)*Z1
|
||||
DO 80 NU=NUMIN,NUMAX
|
||||
JY1=NU-JT1
|
||||
JY2=NU-JT2
|
||||
JY3=NU-JT3
|
||||
JY4=NU-JT4
|
||||
JY5=JZ1-NU
|
||||
JY6=JZ2-NU
|
||||
JY7=JZ3-NU
|
||||
if(jy_big) then
|
||||
FACTR = YXFCT(JY4,NU+1)/FACT(JY5)
|
||||
else
|
||||
FACTR = YXFCT(JY5,NU+1)/FACT(JY4)
|
||||
endif
|
||||
RACAH=RACAH+PHASE*FACTR
|
||||
1 /(FACT(JY1)*FACT(JY2)*FACT(JY3)*FACT(JY6)*FACT(JY7))
|
||||
PHASE=-PHASE
|
||||
80 CONTINUE
|
||||
endif
|
||||
90 RETURN
|
||||
END
|
||||
|
||||
c***********************************************************************
|
||||
FUNCTION DELR(J1,J2,J3)
|
||||
c
|
||||
c Triangular function
|
||||
c Used by Racah Function
|
||||
c
|
||||
c***********************************************************************
|
||||
IMPLICIT REAL*8(A-H,O-Z)
|
||||
EXTERNAL FACTOR
|
||||
COMMON/FACTRL/FACT(0:32)
|
||||
c
|
||||
JZ1=(J1+J2-J3)/2
|
||||
IF(JZ1.LT.0) GO TO 130
|
||||
JZ2=(J1-J2+J3)/2
|
||||
IF(JZ2.LT.0) GO TO 130
|
||||
JZ3=(J2+J3-J1)/2
|
||||
IF(JZ3.LT.0) GO TO 130
|
||||
JZ4=(J1+J2+J3)/2+1
|
||||
IF(JZ3.LT.JZ2) GO TO 80
|
||||
IF(JZ3.LT.JZ1) GO TO 70
|
||||
DELR=YXFCT(JZ4,JZ3)*FACT(JZ1)*FACT(JZ2)
|
||||
RETURN
|
||||
70 DELR=YXFCT(JZ4,JZ1)*FACT(JZ2)*FACT(JZ3)
|
||||
RETURN
|
||||
80 IF(JZ2.LT.JZ1) GO TO 70
|
||||
DELR=YXFCT(JZ4,JZ2)*FACT(JZ1)*FACT(JZ3)
|
||||
RETURN
|
||||
130 DELR=0.0
|
||||
RETURN
|
||||
END
|
||||
|
||||
c***********************************************************************
|
||||
FUNCTION WINEJ(J1,J2,J3,J4,J5,J6,J7,J8,J9)
|
||||
c
|
||||
c NineJ Symbol Function
|
||||
c
|
||||
c***********************************************************************
|
||||
IMPLICIT REAL*8(A-H,O-Z)
|
||||
c
|
||||
WINEJ=0.0
|
||||
MUMIN=MAX0(IABS(J1-J9),IABS(J2-J6),IABS(J4-J8))
|
||||
MUMAX=MIN0(J1+J9,J2+J6,J4+J8)
|
||||
IF(MUMAX.LT.MUMIN) GO TO 40
|
||||
DO 20 MU=MUMIN,MUMAX,2
|
||||
PROD=RACAH(J1,J4,J9,J8,J7,MU)*RACAH(J2,J5,MU,J4,J8,J6)*
|
||||
1 RACAH(J9,MU,J3,J2,J1,J6)*FLOAT(MU+1)
|
||||
WINEJ=WINEJ+PROD
|
||||
20 CONTINUE
|
||||
WINEJ=WINEJ*PHASEF((J1+J3+J5+J8)/2+J2+J4+J9)
|
||||
40 RETURN
|
||||
END
|
||||
|
||||
BLOCK DATA FACTOR
|
||||
c
|
||||
c Factorial table
|
||||
c
|
||||
IMPLICIT REAL*8(A-H,O-Z)
|
||||
COMMON/FACTRL/FACT(0:32)
|
||||
C
|
||||
DATA FACT/ 1.0000000000E+00, 1.0000000000E+00, 2.0000000000E+00
|
||||
1 , 6.0000000000E+00, 2.4000000000E+01, 1.2000000000E+02
|
||||
2 , 7.2000000000E+02, 5.0400000000E+03, 4.0320000000E+04
|
||||
3 , 3.6288000000E+05, 3.6288000000E+06, 3.9916800000E+07
|
||||
4 , 4.7900160000E+08, 6.2270208000E+09, 8.7178291200E+10
|
||||
5 , 1.3076743680E+12, 2.0922789888E+13, 3.5568742810E+14
|
||||
6 , 6.4023737057E+15, 1.2164510041E+17, 2.4329020082E+18
|
||||
7 , 5.1090942172E+19, 1.1240007278E+21, 2.5852016739E+22
|
||||
8 , 6.2044840173E+23, 1.5511210043E+25, 4.0329146113E+26
|
||||
9 , 1.0888869450E+28, 3.0488834461E+29, 8.8417619937E+30
|
||||
$ , 2.6525285981E+32, 8.2228386542E+33, 2.6313083693E+35/
|
||||
C $ , 8.6833176188D+36, 2.9523279904D+38, 1.0333147966D+40
|
||||
C $ , 3.7199332679D+41, 1.3763753091D+43, 5.2302261747D+44
|
||||
C $ , 2.0397882081D+46, 8.1591528325D+47, 3.3452526613D+49
|
||||
C $ , 1.4050061178D+51, 6.0415263063D+52, 2.6582715748D+54
|
||||
C $ , 1.1962222087D+56, 5.5026221598D+57, 2.5862324151D+59
|
||||
C $ , 1.2413915593D+61, 6.0828186403D+62, 3.0414093202D+64
|
||||
C $ , 1.5511187533D+66/
|
||||
END
|
||||
443
dwuck4/culib8/BIND.FOR
Normal file
443
dwuck4/culib8/BIND.FOR
Normal file
|
|
@ -0,0 +1,443 @@
|
|||
SUBROUTINE BIND(U,F,DR,RM,FNODE,FL,Kin,FK,ETA,V,E,FK2,ISW,IERR,D)
|
||||
C
|
||||
C U = POTENTIAL STORAGE
|
||||
C ODD = - SCALED PART OF V *(2M/HBAR**2)
|
||||
C EVEN = (ENERGY - NON SCALED PART OF V)*(2M/HBAR**2)
|
||||
C F = OUTPUTTED WAVE FUNCTION
|
||||
C DR = RADIAL INCREMENT
|
||||
C RM = MATCHING RADIUS, INPUT IS DEFAULT, OUTPUT IS VALUE USED
|
||||
C FNODE = NO. NODES IN WAVE FCT., EXCLUDING ORIGIN AND INFINITY
|
||||
C FL = ORBITAL ANGULAR MOMENTUM
|
||||
C Kin = MAX NO. OF POINTS + 2048*(MIN POINT)
|
||||
C FK = |WAVE NUMBER| E.G. SIN(FK*R) OR EXP(-FK*R)
|
||||
C ETA = COULOMB PARAMETER
|
||||
C V = SCALE FACTOR FOR ODD POTENTIAL VALUES
|
||||
C E = ENERGY
|
||||
C FK2 = E*(2*M/HBAR**2)
|
||||
C ISW = SEARCH SWITCH
|
||||
C 0 = SEARCH ON V
|
||||
C 1 = SEARCH ON E
|
||||
C 2 = NO SEARCH, FOR E>0 ONLY (PHASE SHIFT IS CALCULATED)
|
||||
C 3 = Search on V, box b.c.
|
||||
C 4 = Search on E. box b.c.
|
||||
C IERR = ERROR FLAG, IS SET IF ERROR OCCURS
|
||||
C D = LAST POINT DATA FOR UNBOUND STRIPPING
|
||||
C D(1),D(2) ARE REAL AND IMAG PARTS OF EXP(2I*DELTA)
|
||||
C D(3),D(4) ARE GL(RMAX) AND FL(RMAX)
|
||||
C D(5),D(6) are real and imaginary K**2
|
||||
C D(10) is ISW
|
||||
C
|
||||
IMPLICIT REAL*8(A-H,O-Z)
|
||||
c
|
||||
parameter (Pi = 3.141592654)
|
||||
logical dplus,dminus,turnpt
|
||||
CHARACTER*2 A
|
||||
DIMENSION U(800),F(400),T(8),D(10)
|
||||
common /ch3files/input,ioutp
|
||||
DATA ICMAX/32/
|
||||
DATA DLAMY,DETX,dinterp,dlammax/.001,.01,0.1,0.3/
|
||||
DATA XFACT, ELOG10, ONE/0.707, 2.302585, 1.0/
|
||||
C
|
||||
C CHANGES TO ALLOW INTEGRATION OF HARD CORE POTENTIALS
|
||||
C THEY ARE KLUDGED TO ALLOW BACKWARD COMPATIBILITY
|
||||
C Kmin is initial point for hard core
|
||||
C
|
||||
if(ioutp .eq. 0) then
|
||||
ioutput = 6
|
||||
else
|
||||
ioutput = ioutp
|
||||
endif
|
||||
Kmin = Kin/2048
|
||||
Kmax = Kin-Kmin*2048
|
||||
Kmin=Kmin+1
|
||||
C
|
||||
CFACT=1.0
|
||||
dv=0.225*v
|
||||
v0=0.0
|
||||
v1=0.0
|
||||
d0 =-1.0e20
|
||||
d1 = 1.0e20
|
||||
dplus =.false.
|
||||
dminus=.false.
|
||||
IXNT=0
|
||||
IPRNT=0
|
||||
IF(IERR.LT.0) IPRNT=1
|
||||
IERR=0
|
||||
ICNT=ICMAX
|
||||
IF(ISW.EQ.2) ICNT=0
|
||||
FLP=FL*(FL+1.0)
|
||||
DR2=DR**2/12.0
|
||||
LL=FL+1.0
|
||||
ITER=0
|
||||
C
|
||||
C CALCULATE OUTER BOUNDARY CONDITION
|
||||
C
|
||||
10 CONTINUE
|
||||
RMAX=DR*FLOAT(Kmax)
|
||||
IF(FK2.GT.0.0) THEN
|
||||
C POSITIVE ENERGY BOUNDARY CONDITION
|
||||
IF(ISW.EQ.0.OR.ISW.EQ.1.OR.ISW.EQ.2) THEN
|
||||
c
|
||||
c get functions at Rmax - dr and Rmax
|
||||
c
|
||||
M=MAX0(LL+1,3)
|
||||
T(2)=FK*RMAX
|
||||
T(1)=T(2)-FK*DR
|
||||
CALL COU(T(1),T(2),ETA,M ,DR,F( 1),F(21),F(41),F(61),F(81))
|
||||
SCALE=ABS(F(LL+60))
|
||||
T(8)=F(LL+60)/SCALE
|
||||
T(7)=F(LL+40)/SCALE
|
||||
T(6)=F(LL+20)/SCALE
|
||||
T(5)=F(LL )/SCALE
|
||||
D(4)=F(LL+20)
|
||||
D(3)=F(LL+60)
|
||||
c
|
||||
c Calculate surface term for width
|
||||
c
|
||||
c calculate Surf = d(k*u'/u)/dk = (u'/u) +kR*[(u''/u) - (u'/u)**2]
|
||||
c
|
||||
c Ratio = (u'/u)
|
||||
c
|
||||
Ratio = (((FL+1.0)**2 + ETA)/t(2)
|
||||
1 - sqrt((FL+1.0)**2 + ETA**2)*F(LL+61)/F(LL+60))/(FL+1.0)
|
||||
Surf = ( (1. - T(2)*Ratio)*Ratio
|
||||
1 -T(2)*(1.0 - FL*(FL+1.0)/T(2)**2 - 2.0*ETA/T(2)))/(2.0*fk)
|
||||
c
|
||||
c write(ioutput,'(a,1p4e12.4)')' Surf =',Surf
|
||||
c
|
||||
ELSEIF(ISW.EQ.3.OR.ISW.EQ.4) THEN
|
||||
T(8)=0.0
|
||||
T(7)=1.0E-15
|
||||
SCALE=1.0
|
||||
ELSE
|
||||
IERR=1
|
||||
WRITE(ioutput,'(''0Illegal FISW parameter, ='',i3)')isw
|
||||
RETURN
|
||||
C
|
||||
ENDIF
|
||||
ELSE
|
||||
C NEGATIVE ENERGY BOUNDARY CONDITION
|
||||
IF(ISW.EQ.0.OR.ISW.EQ.1) THEN
|
||||
T(8)=1.0E-15
|
||||
T(7)=T(8)*EXP(FK*DR+ETA* LOG(1.0+DR/RMAX))
|
||||
SCALE=1.0
|
||||
C BOX BOUNDARY CONDITIONS
|
||||
ELSEIF(ISW.EQ.3.OR.ISW.EQ.4) THEN
|
||||
T(8)=0.0
|
||||
T(7)=1.0E-15
|
||||
SCALE=1.0
|
||||
ENDIF
|
||||
ENDIF
|
||||
40 CONTINUE
|
||||
width = 0.0
|
||||
fnorm0 = 0.5*t(8)**2 + t(7)**2
|
||||
F(Kmax )=T(8)
|
||||
F(Kmax-1)=T(7)
|
||||
RMAX=RMAX-DR
|
||||
K1 = Kmax-2
|
||||
turnpt=.true.
|
||||
KM=Kmax
|
||||
C
|
||||
C INTEGRATE FROM INFINITY TO TURNING POINT
|
||||
C
|
||||
50 continue
|
||||
R=RMAX
|
||||
FNCT=0.0
|
||||
IF(ISW.NE.2) THEN
|
||||
G5=U(2*Kmax-4)-FLP/R**2
|
||||
IF(G5.LT.0.0) THEN
|
||||
IFLAG=1
|
||||
ELSE
|
||||
IFLAG=0
|
||||
ENDIF
|
||||
Q6=1.0+DR2*(U(2*Kmax-2)-FLP/(R+DR)**2)
|
||||
Q5=1.0+DR2*G5
|
||||
F6=T(8)
|
||||
F5=T(7)
|
||||
W2=0.0
|
||||
FNORM2=fnorm0
|
||||
C
|
||||
DO 100 M=K1,Kmin,-1
|
||||
MM = M
|
||||
MK=2*M-1
|
||||
R=R-DR
|
||||
G4=U(MK+1)+V*U(MK )-FLP/R**2
|
||||
Q4=1.0+DR2*G4
|
||||
F4=((12.0-10.0*Q5)*F5-Q6*F6)/Q4
|
||||
Q6=Q5
|
||||
Q5=Q4
|
||||
G6=G5
|
||||
G5=G4
|
||||
if(f6*f5.lt.0.0) fnct=fnct+1.0
|
||||
F6=F5
|
||||
F5=F4
|
||||
F(M)=F4
|
||||
IF(G6*G5.LT.0.0) IFLAG=IFLAG+1
|
||||
if((.not.turnpt.and.f5.lt.f6).or.IFLAG.GE.2) GO TO 110
|
||||
FNORM2=FNORM2+F5**2
|
||||
W2=W2+U(MK+2)*F5**2
|
||||
100 CONTINUE
|
||||
C
|
||||
C If no classical turning point is found, then find first maximum,
|
||||
C then if none, use external matching radius.
|
||||
C
|
||||
if(turnpt) then
|
||||
turnpt=.false.
|
||||
go to 50
|
||||
else
|
||||
MM = INT(RM/DR)
|
||||
endif
|
||||
105 continue
|
||||
F5=F(MM )
|
||||
F6=F(MM+1)
|
||||
110 CONTINUE
|
||||
C
|
||||
C INTEGRATE FROM ORIGIN TO TURNING POINT
|
||||
C
|
||||
if(isw.lt.2) fnct = 0.0
|
||||
KM=MM+1
|
||||
120 CONTINUE
|
||||
ENDIF
|
||||
c End of (Isw ne. 2)
|
||||
KS=FL/3.3+2.0
|
||||
W1=0.0
|
||||
FNORM1=0.0
|
||||
F2=0.0
|
||||
Q2=0.0
|
||||
R =0.0
|
||||
C
|
||||
DO 200 M=Kmin,KM
|
||||
MK=M+M-1
|
||||
R=R+DR
|
||||
Q3=1.0+DR2*(U(MK+1)+V*U(MK )-FLP/R**2)
|
||||
IF(M.GT.KS) THEN
|
||||
F3=((12.0-10.0*Q2)*F2-Q1*F1)/Q3
|
||||
ELSE
|
||||
F3=R**LL
|
||||
ENDIF
|
||||
Q1=Q2
|
||||
Q2=Q3
|
||||
F1=F2
|
||||
F2=F3
|
||||
IF(ICNT.EQ.0) F(M)=F3
|
||||
FNORM1=FNORM1+F1**2
|
||||
W1=W1+U(MK)*F1**2
|
||||
C NODE COUNT
|
||||
IF(F1*F2.LT.0.0) FNCT=FNCT+1.0
|
||||
200 CONTINUE
|
||||
F12=(F1+F2)*0.5
|
||||
IF(F1*F2.lt.0.0.and.F12*F2.lt.0.0) FNCT=FNCT-1.0
|
||||
C
|
||||
FN=FNODE-FNCT
|
||||
IF(ISW.EQ.2) GO TO 500
|
||||
F56=(F5+F6)*0.5
|
||||
DET=(F1*F6-F5*F2)/(F12*F56*DR)
|
||||
FNORM1=FNORM1/F2**2
|
||||
FNORM2=FNORM2/F6**2
|
||||
FNORM=FNORM1+FNORM2
|
||||
ITER=ITER+1
|
||||
IF(ICNT.EQ.0) GO TO 500
|
||||
ICNT=ICNT-1
|
||||
IF(ICNT.EQ.0) THEN
|
||||
WRITE(ioutput,'(''0BOUND STATE SEARCH FAILS IN'',I3,
|
||||
1 '' ITERATIONS'')')ICMAX
|
||||
IERR=1
|
||||
ENDIF
|
||||
IF(ICNT.EQ.18) CFACT=CFACT*XFACT
|
||||
IF(ICNT.EQ.12) CFACT=CFACT*XFACT
|
||||
RM=(FLOAT(KM)-0.5)*DR
|
||||
IF((ISW.EQ.3.OR.ISW.EQ.4).AND.E.GT.0.0) THEN
|
||||
RSCALE=RMAX
|
||||
ELSE
|
||||
RSCALE=RM*1.5
|
||||
ENDIF
|
||||
ESCALE= ABS(((fnode+1.0)*3.0+fl)/(FK2*RSCALE**2))
|
||||
DLAMX =DLAMY*ESCALE
|
||||
vold=v
|
||||
eold=e
|
||||
IF(ISW.EQ.0.OR.ISW.EQ.3) THEN
|
||||
C
|
||||
C CHOOSE NEXT GUESS FOR WELL DEPTH
|
||||
C
|
||||
IF(FN.NE.0.0) THEN
|
||||
c Node count incorrect
|
||||
c dlam= 1.625*cfact*fn*escale
|
||||
dlam= (cfact*((fnode+0.5*fl+0.5)**2
|
||||
1 - (fnct+0.5*fl+0.5)**2) )
|
||||
if(dlam.lt.-abs(dv/v)) then
|
||||
dlam = abs(dv/v)*sign(one,dlam)
|
||||
else
|
||||
dlam = min(dlam,dlammax*sign(one,dlam))
|
||||
endif
|
||||
a='Vn'
|
||||
ELSE
|
||||
if(det.gt.0.0) then
|
||||
dplus =.true.
|
||||
if(det.lt.d1) then
|
||||
v1=v
|
||||
d1=det
|
||||
endif
|
||||
else
|
||||
dminus=.true.
|
||||
if(det.gt.d0) then
|
||||
v0=v
|
||||
d0=det
|
||||
endif
|
||||
endif
|
||||
IF(dplus.and.dminus.and.abs(det).gt.dinterp) THEN
|
||||
c Interpolation search
|
||||
if(abs(d1/d0).gt.5.0 .or. abs(d1/d0).lt.0.2) then
|
||||
DLAM = (v0+v1)/(2.0*v) - 1.0
|
||||
else
|
||||
DLAM = ((d1*v0-d0*v1)/((d1-d0)*v) - 1.0)
|
||||
endif
|
||||
a='Vi'
|
||||
ELSE
|
||||
c Variational search
|
||||
DLAM= -DET/(V*DR*(W1/F12**2+W2/F56**2))
|
||||
IF(ABS(DLAM).GT.dlammax) DLAM=SIGN(dlammax,DLAM)
|
||||
a='Vv'
|
||||
ENDIF
|
||||
IXNT=IXNT+1
|
||||
ENDIF
|
||||
flam=1.0+dlam
|
||||
V=V*FLAM
|
||||
DLAMX=DLAMY
|
||||
C
|
||||
C CHOOSE NEXT GUESS FOR BINDING ENERGY
|
||||
C
|
||||
ELSEIF(ISW.EQ.1.OR.ISW.EQ.4) THEN
|
||||
IF(FN.NE.0.0) THEN
|
||||
c Node count incorrect
|
||||
c DLAM= 1.625*cfact*fn*sign(escale,e)
|
||||
DLAM= -0.75*cfact*((fnct +0.5*fl+0.5)**2
|
||||
1 -(fnode+0.5*fl+0.5)**2)*(3.2/rscale)**2/fk2
|
||||
a='En'
|
||||
ELSE
|
||||
if(det.gt.0.0) then
|
||||
dplus =.true.
|
||||
if(det.lt.d1) then
|
||||
v1=e
|
||||
d1=det
|
||||
endif
|
||||
else
|
||||
dminus=.true.
|
||||
if(det.gt.d0) then
|
||||
v0=e
|
||||
d0=det
|
||||
endif
|
||||
endif
|
||||
IF(dplus.and.dminus.and.abs(det).gt.dinterp) THEN
|
||||
c Interpolation search
|
||||
DLAM= ((d1*v0-d0*v1)/((d1-d0)*e) - 1.0)
|
||||
a='Ei'
|
||||
ELSE
|
||||
c Variational search
|
||||
DLAM= -cfact*DET/(DR*FK2*FNORM)
|
||||
a='Ev'
|
||||
IF(ABS(DLAM).GT.ESCALE) DLAM = SIGN(ESCALE,DLAM)
|
||||
ENDIF
|
||||
ENDIF
|
||||
FLAM=1.0+DLAM
|
||||
TEMP=SQRT(ABS(FLAM))
|
||||
FK=FK*TEMP
|
||||
ETA=ETA/TEMP
|
||||
TEMP=FK2*FLAM-FK2
|
||||
FK2=FK2+TEMP
|
||||
E=E*FLAM
|
||||
DO 485 M=1,Kmax
|
||||
MK=M+M-1
|
||||
U(MK+1)=U(MK+1)+TEMP
|
||||
485 CONTINUE
|
||||
ENDIF
|
||||
c diagnostic printout
|
||||
c if(icnt+1.eq.icmax) write(ioutput,8888)
|
||||
c 8888 format(' Iter',' Nodes',5x,' Det',9x,'Fnorm',9x,'Old E'
|
||||
c 1, 9x,'New E',9x,'Old V',9x,'New V',9x,' Flam',9x,' RM')
|
||||
c WRITE(ioutput,8889)A,ITER,FNCT,DET,FNORM,eold,E
|
||||
c 1 ,vold,V,1.0+DLAM,rm
|
||||
c 8889 FORMAT(' ',A2,I6,F6.0,8(2X,1PE12.5))
|
||||
c
|
||||
IF(ABS(DET).LT.DETX .AND. ABS(DLAM).LT.DLAMX) THEN
|
||||
ICNT=0
|
||||
ENDIF
|
||||
GO TO 10
|
||||
C
|
||||
500 CONTINUE
|
||||
C
|
||||
C NORMALIZE WAVE FUNCTION
|
||||
C
|
||||
IF(FK2.LT.0.0.OR.ISW.EQ.3.OR.ISW.EQ.4) THEN
|
||||
C
|
||||
C NEGATIVE ENERGY AND BOX B.C.
|
||||
C
|
||||
FNORM=SQRT(FNORM*DR)
|
||||
ELSEIF(FK.GT.0.0.AND.(ISW.EQ.0.OR.ISW.EQ.1)) THEN
|
||||
C POSITIVE ENERGY AND PI/2 PHASE SHIFT
|
||||
C
|
||||
D(1)=0.0
|
||||
D(2)=1.0
|
||||
VOL=(FNORM1+FNORM2)*DR*F6**2
|
||||
c Volume and surface terms are still divided by SCALE**2
|
||||
WIDTH=2.0*E/(FK*(VOL+SURF))
|
||||
IF(WIDTH.LT.0.0) then
|
||||
WRITE(ioutput,'(''0 Negative width '',20(1H*)/)')
|
||||
endif
|
||||
WIDTH=ABS(WIDTH)
|
||||
TEMP=( LOG(WIDTH)-2.0* LOG(SCALE))/ELOG10
|
||||
I1=TEMP-1.0
|
||||
A1=EXP(ELOG10*(TEMP-FLOAT(I1)))
|
||||
WRITE(ioutput,9502)A1,I1,VOL*SCALE**2,SURF*SCALE**2
|
||||
FNORM=1.0/SQRT(WIDTH*FK/(2.0*E))/F6
|
||||
C
|
||||
ELSEIF(FK.GT.0.0.AND.ISW.EQ.2) THEN
|
||||
C
|
||||
C FIND B.C. FOR E > 0 AND NO SEARCH (ISW = 2)
|
||||
C
|
||||
DET=T(5)*T(8)-T(6)*T(7)
|
||||
A1=(F1 *T(8)-F2 *T(7))/DET
|
||||
B1=(T(5)*F2 -T(6)*F1 )/DET
|
||||
DET=1.0/SQRT(A1**2+B1**2)
|
||||
A1=A1*DET
|
||||
B1=B1*DET
|
||||
C A1=COS(DELTA), B1=SIN(DELTA)
|
||||
C (D1,D2) = (exp(2i*delta) - 1)/(2i) = exp(i*delta)*sin(delta)
|
||||
WRITE(ioutput,9501)A1,B1
|
||||
D(1)=B1*A1
|
||||
D(2)=B1*B1
|
||||
FNORM=FK/SCALE
|
||||
F2=1.0/DET
|
||||
F6=1.0
|
||||
DET=0.0
|
||||
ENDIF
|
||||
C
|
||||
TEMP=1.0/(F2*FNORM)
|
||||
R=0.0
|
||||
DO 510 M=1,KM
|
||||
R=R+DR
|
||||
F(M)=F(M)*TEMP/R
|
||||
510 CONTINUE
|
||||
IF(KM.LT.Kmax) THEN
|
||||
KM=KM+1
|
||||
TEMP=1.0/(F6*FNORM)
|
||||
DO 520 M=KM,Kmax
|
||||
R=R+DR
|
||||
F(M)=F(M)*TEMP/R
|
||||
520 CONTINUE
|
||||
ENDIF
|
||||
IF(IPRNT.EQ.0.OR.IERR.NE.0) then
|
||||
WRITE(ioutput,9500)V,DET,FNCT,RM,E,ITER
|
||||
endif
|
||||
c
|
||||
D(5) = fk2
|
||||
D(6) = (fk2/e)*width/2.0/scale**2
|
||||
D(10)=ISW
|
||||
c
|
||||
RETURN
|
||||
c
|
||||
9500 FORMAT(21X,6HV =,F9.4,3X,6HDET =,F9.4,3X,6HNODES=,F9.4,3X,
|
||||
1 6HRM =,F9.4,3X,6HE =,F9.4,3X,6HITER.=,I4 )
|
||||
9501 FORMAT(21X,6HCOSD =,1pe12.4,12x,9H SIND =,1pe12.4)
|
||||
9502 FORMAT(24H0SINGLE PARTICLE WIDTH = ,F7.4,1HE,I3,' MEV '
|
||||
1,13HVOLUME TERM = ,1PE12.4,5X,14HSURFACE TERM = ,1PE12.4)
|
||||
END
|
||||
201
dwuck4/culib8/COU.FOR
Normal file
201
dwuck4/culib8/COU.FOR
Normal file
|
|
@ -0,0 +1,201 @@
|
|||
|
||||
c***********************************************************************
|
||||
SUBROUTINE COU(R,RP,ETA,L,H,F,FP,G,GP,S)
|
||||
c
|
||||
c Coulomb Function Subroutine
|
||||
c
|
||||
c Calculates the functions at 2 points, R and RP for convenience
|
||||
c in matching to the output of some integration formulae.
|
||||
c
|
||||
c R First argument
|
||||
c RP Second argument
|
||||
c E Coulomb parameter, eta
|
||||
c L Number of angular momenta = lmax+1
|
||||
c H Integration step size, usually = 0.10
|
||||
c F Regular function at R
|
||||
c FP Regular function at RP
|
||||
c G Irregular function at R
|
||||
c GP Irregular function at RP
|
||||
c S Coulomb phase
|
||||
c
|
||||
c***********************************************************************
|
||||
c
|
||||
IMPLICIT REAL*8(A-H,O-Z)
|
||||
DIMENSION F(51),FP(51),G(51),GP(51),S(51)
|
||||
C
|
||||
LL=L
|
||||
IF(LL.LT.50) THEN
|
||||
ELP=50.
|
||||
J=50
|
||||
ELSE
|
||||
ELP=LL
|
||||
J=LL
|
||||
ENDIF
|
||||
A=ATAN (ETA/ELP)
|
||||
B=SQRT (ETA**2+ELP**2)
|
||||
Y=A*(ELP-0.5)+ETA*( LOG(B)-1.)-SIN (A)/(12.*B)
|
||||
1 +SIN (3.*A)/(360.*B**3)-SIN (5.*A)/(1260.*B**5)
|
||||
2 +SIN (7.*A)/(1680.*B**7)-SIN (9.*A)/(1188.*B**9)
|
||||
C
|
||||
K=J-1
|
||||
DO 100 I=1,K
|
||||
IF(J.LE.LL) S(J)=Y
|
||||
ELP=ELP-1.
|
||||
J=J-1
|
||||
Y=Y-ATAN (ETA/ELP)
|
||||
100 CONTINUE
|
||||
S(1)=Y
|
||||
DEL1=R-2.0*ETA
|
||||
RMAX=.41666667*(ETA**2+4.*ETA+3.)
|
||||
IF(RMAX.LT.10.0) RMAX=10.0
|
||||
DEL=R-RMAX
|
||||
IF(ETA.GE.5.0.AND.ABS (DEL1).LT.ABS (DEL)) THEN
|
||||
DEL=DEL1
|
||||
I1=2
|
||||
C Transition line expansion
|
||||
X=2.0*ETA
|
||||
T1=ETA**2
|
||||
T2=T1**2
|
||||
T3=ETA** .666666667
|
||||
T4=T3**2
|
||||
T5=T4**2
|
||||
T6=T3*T5
|
||||
T7=T4*T6
|
||||
T8=T3*T7
|
||||
T9=ETA** .166666667
|
||||
Y=1.22340402*T9*(1.+.495957017E-1/T4-.888888889E-2/T1
|
||||
1 +.245519918E-2/T6-.910895806E-3/T2+.845362E-3/T8)
|
||||
Z=-.707881773/T9*(1.-.172826039/T3+.317460317E-3/T1
|
||||
1 -.358121485E-2/T5+.311782468E-3/T2-.907396643E-3/T7)
|
||||
ELSE
|
||||
C
|
||||
IF(DEL.GE.0.0.OR.ETA.EQ.0.0) THEN
|
||||
X=R
|
||||
I1=1
|
||||
ELSE
|
||||
X=RMAX
|
||||
I1=2
|
||||
ENDIF
|
||||
C Asymptotic expansion
|
||||
T1=ETA**2
|
||||
T2=2.*X
|
||||
T4=ETA/T2
|
||||
SS=1.
|
||||
TS=0.
|
||||
SL=0.
|
||||
TL=1.-ETA/X
|
||||
SSS=1.
|
||||
STS=0.
|
||||
SSL=0.
|
||||
STL=TL
|
||||
EN=0.
|
||||
DO 700 K=1,25
|
||||
IF(ABS (SS/SSS).GT.1.0E-10) THEN
|
||||
T5=EN+1.
|
||||
T6=T5+EN
|
||||
T7=EN*T5
|
||||
T8=T6*T4/T5
|
||||
T9=(T1-T7)/(T2*T5)
|
||||
T5=T8*SS-T9*TS
|
||||
TS=T8*TS+T9*SS
|
||||
SS=T5
|
||||
T5=T8*SL-T9*TL-SS/X
|
||||
TL=T8*TL+T9*SL-TS/X
|
||||
SL=T5
|
||||
SSS=SSS+SS
|
||||
STS=STS+TS
|
||||
SSL=SSL+SL
|
||||
STL=STL+TL
|
||||
EN=EN+1.
|
||||
ENDIF
|
||||
700 CONTINUE
|
||||
C
|
||||
T3=X-ETA* LOG(T2)+S(1)
|
||||
T8=SIN (T3)
|
||||
T9=COS (T3)
|
||||
Y=SSS*T9-STS*T8
|
||||
Z=SSL*T9-STL*T8
|
||||
ENDIF
|
||||
C
|
||||
DO 810 I=1,I1
|
||||
IF(I.EQ.I1) THEN
|
||||
G(1) = Y
|
||||
W = Z
|
||||
DEL = RP - R
|
||||
ENDIF
|
||||
C Runge-Kutta integration
|
||||
N=ABS (DEL/H)+1.0
|
||||
DX=DEL/FLOAT(N)
|
||||
T1=DX/2.
|
||||
T2=DX/8.
|
||||
T3=2.0*ETA
|
||||
DO 805 J=1,N
|
||||
T4=DX*(T3/X-1.)*Y
|
||||
X=X+T1
|
||||
T5=DX*(T3/X-1.)*(Y+T1*Z+T2*T4)
|
||||
X=X+T1
|
||||
T6=DX*(T3/X-1.)*(Y+DX*Z+T1*T5)
|
||||
Y=Y+DX*(Z+(T4+2.*T5)/6.)
|
||||
Z=Z+(T4+4.*T5+T6)/6.
|
||||
805 CONTINUE
|
||||
810 CONTINUE
|
||||
GP(1)=Y
|
||||
C
|
||||
T1=ETA**2
|
||||
T8=SQRT (1.+T1)
|
||||
G(2)=((1./R+ETA)*G(1)-W)/T8
|
||||
GP(2)=((1./RP+ETA)*Y-Z)/T8
|
||||
T2=1.
|
||||
T3=2.
|
||||
C Recur irregular function upwards
|
||||
DO 910 I=3,LL
|
||||
T4=T2+T3
|
||||
T5=T2*T3
|
||||
T6=T3*SQRT (T2**2+T1)
|
||||
T7=T2*SQRT (T3**2+T1)
|
||||
G (I)=(T4*(ETA+T5/R )*G (I-1)-T6*G (I-2))/T7
|
||||
GP(I)=(T4*(ETA+T5/RP)*GP(I-1)-T6*GP(I-2))/T7
|
||||
T2=T2+1.
|
||||
T3=T3+1.
|
||||
910 CONTINUE
|
||||
N=MAX0(L+11, INT(2.0*R+11.0) )
|
||||
I1=N
|
||||
Y =1.0E-20
|
||||
YP=Y
|
||||
Z =0.
|
||||
ZP=Z
|
||||
C Recur regular function downwards
|
||||
DO 930 I=1,I1
|
||||
T2=N
|
||||
T3=T2+1.
|
||||
T4=T2+T3
|
||||
T5=T2*T3
|
||||
T6=T2*SQRT (T3**2+T1)
|
||||
T7=T3*SQRT (T2**2+T1)
|
||||
X =(T4*(ETA+T5/R )*Y -T6*Z )/T7
|
||||
XP=(T4*(ETA+T5/RP)*YP-T6*ZP)/T7
|
||||
IF(N.LE.LL) THEN
|
||||
F (N)=X
|
||||
FP(N)=XP
|
||||
ELSE
|
||||
c Scale for l > lmax
|
||||
IF(ABS (X).GT.1.0) THEN
|
||||
Y =Y *1.0E-20
|
||||
YP=YP*1.0E-20
|
||||
X =X *1.0E-20
|
||||
XP=XP*1.0E-20
|
||||
ENDIF
|
||||
ENDIF
|
||||
N=N-1
|
||||
Z =Y
|
||||
ZP=YP
|
||||
Y =X
|
||||
YP=XP
|
||||
930 CONTINUE
|
||||
Z =1./(T8*(F (1)*G (2)-F (2)*G (1)))
|
||||
ZP=1./(T8*(FP(1)*GP(2)-FP(2)*GP(1)))
|
||||
DO 950 I=1,LL
|
||||
F (I)=F (I)*Z
|
||||
950 FP(I)=FP(I)*ZP
|
||||
RETURN
|
||||
END
|
||||
264
dwuck4/culib8/DSTRIP.FOR
Normal file
264
dwuck4/culib8/DSTRIP.FOR
Normal file
|
|
@ -0,0 +1,264 @@
|
|||
|
||||
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
|
||||
82
dwuck4/culib8/DWPLOT.FOR
Normal file
82
dwuck4/culib8/DWPLOT.FOR
Normal file
|
|
@ -0,0 +1,82 @@
|
|||
|
||||
SUBROUTINE DWPLOT(NTH0,NLOG,SIGPLT,DTHETA,THETA1)
|
||||
C
|
||||
C THIS IS A NEW VERSION OF THE PRINTER PLOT ROUTINE, June 1992
|
||||
C
|
||||
IMPLICIT REAL*8 (A-H,O-Z)
|
||||
Parameter (len = 100, pi = 3.141592)
|
||||
DIMENSION SIGPLT(*)
|
||||
CHARACTER*1 temp
|
||||
1, BLANK /' '/, ASTER /'*'/, FENCE /'|'/, APLUS /'+'/
|
||||
CHARACTER*(len+1) dstore
|
||||
CHARACTER*(len+3) astore
|
||||
c
|
||||
common/ch3files/input, ioutp
|
||||
C
|
||||
ioutput = 6
|
||||
if(ioutp .ne. 0) ioutput = ioutp
|
||||
nth = abs(nth0)
|
||||
if(nlog.gt.0) then
|
||||
MAXN= 0
|
||||
DO 30 I=1,NTH
|
||||
IF(SIGPLT(I).LE.0.0) SIGPLT(I)=1.0E-20
|
||||
SIGPLT(I)= LOG10(SIGPLT(I))
|
||||
MAXN=MAX0(MAXN,INT(SIGPLT(I) + 100.0)-NLOG)
|
||||
30 CONTINUE
|
||||
MAXN = MAXN - 100 + 1
|
||||
nlogp= nlog
|
||||
else
|
||||
MAXN = -1
|
||||
nlogp= 2
|
||||
endif
|
||||
c Write header line
|
||||
do 40 j=1,len+3
|
||||
40 astore(j:j) = BLANK
|
||||
do 45 j=0,nlogp
|
||||
indx = j*(len/nlogp) + 1
|
||||
45 write(astore(indx:indx+2),'(i3)')MAXN +j
|
||||
WRITE(ioutput,9000)astore
|
||||
c
|
||||
DO 100 I=1,NTH
|
||||
tint = THETA1 + (i-1)*DTHETA
|
||||
C Coose between angle or cos(angle) data
|
||||
if(nth0.lt.0) then
|
||||
if (tint.gt. 1.0) tint = 1.0
|
||||
if (tint.lt.-1.0) tint =-1.0
|
||||
theta = acos(tint)*180./pi
|
||||
else
|
||||
theta = tint
|
||||
endif
|
||||
cs = cos(theta*pi/180.)
|
||||
IF(I.EQ.1.OR.I.EQ.NTH) THEN
|
||||
TEMP=APLUS
|
||||
ELSE
|
||||
TEMP=BLANK
|
||||
ENDIF
|
||||
DSTORE( 1: 1) = APLUS
|
||||
DSTORE(len+1:len+1) = APLUS
|
||||
DO 70 J=2,LEN
|
||||
DSTORE(j:j) = TEMP
|
||||
70 CONTINUE
|
||||
if(nlog.le.0) dstore(len/2+1:len/2+1) = APLUS
|
||||
C
|
||||
IF(I .EQ. 1 .OR. I .EQ. NTH) THEN
|
||||
DO 80 J=0,NLOGP
|
||||
indx = j*(len/nlogp) +1
|
||||
DSTORE(indx:indx) = FENCE
|
||||
80 CONTINUE
|
||||
ENDIF
|
||||
C
|
||||
INDX= (SIGPLT(I)-float(MAXN))*float((LEN/NLOGP)) + 1.5
|
||||
IF(INDX.GE.1) DSTORE(indx:indx) = ASTER
|
||||
C
|
||||
WRITE(ioutput,9002)THETA,DSTORE,THETA,cs
|
||||
100 CONTINUE
|
||||
C Write trailer line
|
||||
WRITE(ioutput,9000)astore
|
||||
c
|
||||
RETURN
|
||||
c
|
||||
9000 FORMAT(' THETA ',A103 ,' THETA ','cos(theta)')
|
||||
9002 FORMAT(' ',F8.2 ,' ',A101, F8.2, f10.4 )
|
||||
END
|
||||
168
dwuck4/culib8/ELSIG.FOR
Normal file
168
dwuck4/culib8/ELSIG.FOR
Normal file
|
|
@ -0,0 +1,168 @@
|
|||
c$debug
|
||||
c***********************************************************************
|
||||
SUBROUTINE ELSIG(dtemp,d,plm,SigPlt,angle,fk,eta,rsig,alpha
|
||||
1 ,idat,is,icon,lplus,isym)
|
||||
c
|
||||
c Subroutine to print out elastic scattering cross sections
|
||||
c***********************************************************************
|
||||
c
|
||||
IMPLICIT REAL*8(A-H,O-Z)
|
||||
complex*16 SUM(25),dtemp(*),d(*)
|
||||
logical isym(2), i_open20, i_out20
|
||||
DIMENSION plm(1000),SigPlt(200)
|
||||
1,angle(3),fk(2),eta(2),rsig(2),alpha(15),idat(6),is(2),icon(20)
|
||||
2,POL(12)
|
||||
|
||||
DATA NX, N2, Pi/200, 1, 3.141592654/
|
||||
c
|
||||
i_open20 = .false.
|
||||
i_out20 = .false.
|
||||
C
|
||||
NTHETA=angle(1)
|
||||
theta1=angle(2)
|
||||
dtheta=angle(3)
|
||||
IF(NTHETA.EQ.0) return
|
||||
c
|
||||
ICNT=0
|
||||
IC1=0
|
||||
DO 200 N=1,N2
|
||||
ISS=IS(N)+1
|
||||
IS2=IS(N)
|
||||
IQ=LPLUS*ISS**2
|
||||
C Clear Amplitude Storage
|
||||
DO 3 IP=1,IQ
|
||||
DTEMP(IP)=0.0
|
||||
3 CONTINUE
|
||||
C
|
||||
C CONSTRUCT TABLE OF SCATTERING AMPLITUDES WITH ANG-MOM COEFFICENTS
|
||||
C
|
||||
DO 25 LL=1,LPLUS
|
||||
L=LL-1
|
||||
LK=LL+LL-1
|
||||
L2=LK-1
|
||||
FL=LK
|
||||
J1=L2-IS2
|
||||
J2=L2+IS2
|
||||
IQ=IC1+LL
|
||||
c
|
||||
DO 20 JJ2=J1,J2,2
|
||||
IP=LL
|
||||
DO 15 MS2=-IS2,IS2,2
|
||||
VCI=VCC(L2,IS2,JJ2,0,MS2)*FL
|
||||
DO 14 MS1=-IS2,IS2,2
|
||||
ML2=MS2-MS1
|
||||
ML=IABS(ML2/2)
|
||||
IF(ML .LE. L) THEN
|
||||
VCF=VCC(L2,IS2,JJ2,ML2,MS1)
|
||||
DTEMP(IP)=DTEMP(IP)+D(IQ)
|
||||
1 *VCI*VCF*SQRT(YXFCT(L+ML,L-ML))
|
||||
ENDIF
|
||||
IP=IP+LPLUS
|
||||
14 CONTINUE
|
||||
15 CONTINUE
|
||||
IQ=IQ+LPLUS
|
||||
20 CONTINUE
|
||||
25 CONTINUE
|
||||
IC1=IC1+LPLUS*ISS
|
||||
C
|
||||
C CALCULATE ELASTIC CROSS SECTION
|
||||
C
|
||||
THETA=THETA1
|
||||
if(ETA(N) .ne. 0.0) then
|
||||
WRITE(6,9027)
|
||||
else
|
||||
WRITE(6,9028)
|
||||
endif
|
||||
DO 100 NTH=1,NTHETA
|
||||
CALL LGNDR(PLM,ISS,LPLUS,THETA)
|
||||
Nss = ISS**2
|
||||
DO 30 I=1,Nss
|
||||
SUM(I)=0.0
|
||||
30 CONTINUE
|
||||
DO 40 LL=1,LPLUS
|
||||
IP=LL
|
||||
DO 35 I=1,ISS
|
||||
DO 34 J=1,ISS
|
||||
MP = iabs(J-I)*LPLUS+LL
|
||||
index = (I-1)*ISS + J
|
||||
Phas = 1.0
|
||||
if(I .lt. J) Phas = phasef(I-J)
|
||||
SUM(index) = SUM(index) + DTEMP(IP)*PLM(MP)*Phas
|
||||
IP=IP+LPLUS
|
||||
34 CONTINUE
|
||||
35 CONTINUE
|
||||
40 CONTINUE
|
||||
C
|
||||
C CALCULATE COULOMB AMPLITUDE
|
||||
C
|
||||
if(theta.lt.0.0625
|
||||
1 .or. (isym(N) .and. abs(theta-180.).lt. 0.0625)) then
|
||||
CL=0.0
|
||||
SL=0.0
|
||||
else
|
||||
ARG =THETA*(Pi/360.)
|
||||
S =SIN(ARG)**2
|
||||
ARG =ETA(N)*LOG(S)
|
||||
FFACT=ETA(N)/(2.0*FK(N)*S)
|
||||
CL = COS(ARG)*FFACT
|
||||
SL = SIN(ARG)*FFACT
|
||||
if(isym(N) .and. is(N).eq.0) then
|
||||
ARG =THETA*(Pi/360.)
|
||||
C =COS(ARG)**2
|
||||
ARG =ETA(N)*LOG(C)
|
||||
GFACT=ETA(N)/(2.0*FK(N)*C)
|
||||
CL =CL+COS(ARG)*GFACT
|
||||
SL =SL+SIN(ARG)*GFACT
|
||||
endif
|
||||
endif
|
||||
c Add Coulomb amplitude
|
||||
DO 60 I=1,ISS
|
||||
index = (I-1)*ISS + I
|
||||
SUM(index) = SUM(index) - cmplx(CL, -SL)
|
||||
60 CONTINUE
|
||||
c
|
||||
CALL POLFCT(1,1,ISS,ISS, theta,POL,SUM
|
||||
1 ,i_open20,i_out20, nth,nthetra, ALPHA,IDAT)
|
||||
if(eta(n).eq.0.0) then
|
||||
Ratio = 1.0
|
||||
SigPlt(NTH) = Pol(1)
|
||||
else
|
||||
if(theta.lt.0.0625
|
||||
1 .or. (isym(N) .and. abs(theta-180.).lt.0.0625)) then
|
||||
Ratio = 1.0
|
||||
Pol(1) = 0.0
|
||||
else
|
||||
Ratio = Pol(1)/(CL**2+SL**2)
|
||||
endif
|
||||
SigPlt(nth) = Ratio
|
||||
endif
|
||||
cs = cos(theta*(Pi/180.))
|
||||
if(ETA(N) .ne. 0.0) then
|
||||
WRITE(6,9030)THETA,Ratio,(POL(I),I=1,7),THETA,cs
|
||||
else
|
||||
WRITE(6,9031)THETA, (POL(I),I=1,7),THETA,cs
|
||||
endif
|
||||
90 CONTINUE
|
||||
THETA=THETA+DTHETA
|
||||
100 CONTINUE
|
||||
WRITE(6,9002)RSIG(N)
|
||||
NTH=MIN0(NTHETA,NX)
|
||||
c
|
||||
IF(ICON(6).ne.0) then
|
||||
WRITE(6,9999)ALPHA,(IDAT(I),I=1,3)
|
||||
CALL DWPLOT(NTH,ICON(6),SigPlt,DTHETA,THETA1)
|
||||
endif
|
||||
200 continue
|
||||
RETURN
|
||||
c
|
||||
9002 FORMAT('0REACSIG ',1PE13.4)
|
||||
9027 FORMAT('0 Theta Sig(1)/Coul Sigma(1) ',' Pol '
|
||||
1 ,' Asy ',' Ayy ',' A22 ',' A21 '
|
||||
2 ,' A20 ',' Theta ','Cos(Theta)')
|
||||
9028 FORMAT('0 Theta Sigma(1) ',' Pol '
|
||||
1 ,' Asy ',' Ayy ',' A22 ',' A21 '
|
||||
2 ,' A20 ',' Theta ','Cos(Theta)')
|
||||
9030 FORMAT(0PF8.2,2X,1P2E13.4,0P6F10.4,0PF10.2,0pf10.3)
|
||||
9031 FORMAT(0PF8.2,2X,1P1E13.4,0P6F10.4,0PF10.2,0pf10.3)
|
||||
9999 FORMAT('1',15A4,I4,2('/',I2.2),I4,2('.',I2.2))
|
||||
END
|
||||
64
dwuck4/culib8/FNLOC5.FOR
Normal file
64
dwuck4/culib8/FNLOC5.FOR
Normal file
|
|
@ -0,0 +1,64 @@
|
|||
|
||||
c***********************************************************************
|
||||
SUBROUTINE FNLOC5(U,V,W,PNLOC,FK2,FK,ETA,RC,DR,KT)
|
||||
c
|
||||
c Non-locality correction factor for the distorted waves
|
||||
c
|
||||
c***********************************************************************
|
||||
c
|
||||
IMPLICIT REAL*8(A-H,O-Z)
|
||||
DIMENSION U(800),V(800),W(800)
|
||||
FACP=PNLOC**2/8.0
|
||||
IF(FACP.EQ.0.0) GO TO 410
|
||||
C
|
||||
WRITE(6,9900)PNLOC
|
||||
IF(PNLOC.GT.0.0) THEN
|
||||
R=0.0
|
||||
ETAK=2.0*ETA*FK
|
||||
ELSE
|
||||
R1=DR*FLOAT(KT+1)
|
||||
ENDIF
|
||||
CTEMP1=0.0
|
||||
CTEMP2=0.0
|
||||
T1=0.0
|
||||
T2=0.0
|
||||
C
|
||||
DO 400 M=1,KT
|
||||
IF(PNLOC.GT.0.0) THEN
|
||||
C PNLOC POSITIVE GIVES USUAL NON-LOCAL FACTOR WITH GAUSSIAN SHAPE
|
||||
MK=M+M-1
|
||||
R=R+DR
|
||||
IF(R.GT.RC) THEN
|
||||
VCOUL=ETAK/R
|
||||
ELSE
|
||||
VCOUL=0.5*ETAK*(3.0-(R/RC)**2)/RC
|
||||
ENDIF
|
||||
CTEMP1=-FACP*U(MK )+FACP*(FK2-VCOUL)
|
||||
CTEMP2=-FACP*U(MK+1)
|
||||
T1=U(MK )
|
||||
T2=U(MK+1)
|
||||
ELSE
|
||||
C PNLOC NEGATIVE GIVES DIRAC TYPE DARWIN FACTOR BASED ON SPIN ORBI
|
||||
MK=KT+KT-M-M+1
|
||||
R2=R1
|
||||
R1=R1-DR
|
||||
CTEMP1=CTEMP1+PNLOC*(R2*T1+R1*V(MK ))*(DR*0.125)
|
||||
CTEMP2=CTEMP2+PNLOC*(R2*T2+R1*V(MK+1))*(DR*0.125)
|
||||
T1=V(MK )
|
||||
T2=V(MK+1)
|
||||
ENDIF
|
||||
C
|
||||
FACT=EXP(CTEMP1)
|
||||
UT1=FACT*COS(CTEMP2)
|
||||
UT2=FACT*SIN(CTEMP2)
|
||||
UF1 =UT1*W(MK )-UT2*W(MK+1)
|
||||
UF2 =UT1*W(MK+1)+UT2*W(MK )
|
||||
W(MK )=UF1
|
||||
W(MK+1)=UF2
|
||||
c WRITE(20,7777)R1,T1,T2,UT1,UT2
|
||||
c 7777 FORMAT(' R =',F6.2,' POT =',1P2E12.4,' FACTOR =',1P2E12.4)
|
||||
400 CONTINUE
|
||||
410 CONTINUE
|
||||
RETURN
|
||||
9900 FORMAT('0Non-locality correction is applied, parameter =',f8.3)
|
||||
END
|
||||
84
dwuck4/culib8/GAUSSR.FOR
Normal file
84
dwuck4/culib8/GAUSSR.FOR
Normal file
|
|
@ -0,0 +1,84 @@
|
|||
|
||||
c***********************************************************************
|
||||
SUBROUTINE GAUSSR(NMAX,INDEX,ALFA,AG,WG,IERR,CUTOFF)
|
||||
C
|
||||
c Gauss-Hermite and gauss-laguerre point and weight routine
|
||||
c***********************************************************************
|
||||
C
|
||||
C IF ALFA IS INTEGER -- GAUSS-LAGUERRE
|
||||
C IF ALFA IS INTEGER + 1/2 -- GAUSS-HERMITE
|
||||
C
|
||||
IMPLICIT REAL*8(A-H,O-Z)
|
||||
DIMENSION AG(100),WG(100)
|
||||
data eps/1.e-6/
|
||||
DATA PI,SQRPI/3.14159265,1.77245385/
|
||||
c
|
||||
INDEX=0
|
||||
FI=NMAX
|
||||
FKI=4.0*(FI+(ALFA+1.0)*0.5)
|
||||
FLN= LOG(FI)
|
||||
C
|
||||
K=ALFA
|
||||
JJ=(ALFA-FLOAT(K))*2.0
|
||||
DY=0.0
|
||||
IF(JJ.NE.0) GO TO 19
|
||||
FNORM=1.0
|
||||
IF(K.EQ.0) GO TO 11
|
||||
DO 10 J=1,K
|
||||
FNORM=FNORM*(ALFA+FI+1.0-FLOAT(J))
|
||||
10 CONTINUE
|
||||
11 CONTINUE
|
||||
GO TO 25
|
||||
19 CONTINUE
|
||||
FNORM=SQRPI/2.0
|
||||
DO 20 J=1,NMAX
|
||||
FNORM=FNORM*(1.0+ALFA/FLOAT(J))
|
||||
20 CONTINUE
|
||||
K=ALFA+1.0
|
||||
IF(K.EQ.0) GO TO 25
|
||||
DO 22 J=1,K
|
||||
FNORM=FNORM*(FLOAT(J)-0.5)
|
||||
22 CONTINUE
|
||||
25 CONTINUE
|
||||
Y=0.0
|
||||
Z1=0.0
|
||||
Z2=0.0
|
||||
C
|
||||
DO 80 J=1,NMAX
|
||||
FJ=J
|
||||
FKJ=4.0*(FJ+(ALFA+1.0)*0.5)
|
||||
Z=((FJ+0.5*ALFA-0.25)*PI)**2/FKI
|
||||
Z=Z*(1.0+Z*(1.0+PI* LOG(FJ)*FLN/(8.0*(FI+FLN-FJ+eps)))/(3.0*FKI))
|
||||
DELZ=Z-Z1
|
||||
Z1=Z
|
||||
Z=Y+DELZ
|
||||
Z3=Z
|
||||
DO 74 M=1,20
|
||||
A1=0.0
|
||||
A2=1.0
|
||||
DO 70 K=1,NMAX
|
||||
FK=K
|
||||
A3=((2.0*FK+ALFA-1.0-Z)*A2-(FK+ALFA-1.0)*A1)/FK
|
||||
A1=A2
|
||||
A2=A3
|
||||
B2=(FK*A2-(FK+ALFA)*A1)/Z
|
||||
70 CONTINUE
|
||||
Y=Z-A2/B2
|
||||
IF(ABS((Z-Y)/Z).LT.3.E-14) GO TO 75
|
||||
Z=Y
|
||||
74 CONTINUE
|
||||
IERR=J
|
||||
75 CONTINUE
|
||||
DZ=Z-Z2
|
||||
Z2=Z
|
||||
DZ=((FNORM/Z)/B2)/B2
|
||||
IF(DZ.LT.CUTOFF.AND.DZ.LT.DY) GO TO 100
|
||||
DY=DZ
|
||||
INDEX=J
|
||||
AG(J)=Y
|
||||
WG(J)=DZ
|
||||
IF(JJ.NE.0) AG(J)=SQRT(Y)
|
||||
80 CONTINUE
|
||||
100 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
48
dwuck4/culib8/LEGAUS.FOR
Normal file
48
dwuck4/culib8/LEGAUS.FOR
Normal file
|
|
@ -0,0 +1,48 @@
|
|||
|
||||
c***********************************************************************
|
||||
SUBROUTINE LEGAUS(LL,X,W)
|
||||
C
|
||||
c Gauss-Legendre point and weight routine for an even no. of points.
|
||||
c***********************************************************************
|
||||
C
|
||||
C ll= order i.e. the total number of points -1< x <1
|
||||
C x = points, calculates and stores only for 0< x <1
|
||||
C w = weights
|
||||
C
|
||||
IMPLICIT REAL*8(A-H,O-Z)
|
||||
DIMENSION X(100),W(100)
|
||||
c
|
||||
c starting values for recursion
|
||||
c
|
||||
Z3=-1.6/FLOAT(LL+1)
|
||||
Z2=3.0*Z3
|
||||
Z1=5.0*Z3
|
||||
c
|
||||
NL=(LL+1)/2
|
||||
DO 200 L=1,NL
|
||||
ZOLD=0.0
|
||||
Z=Z1+3.0*(Z3-Z2)
|
||||
DO 50 J=1,10
|
||||
P1=0.0
|
||||
P2=1.0
|
||||
DO 30 I=1,LL
|
||||
P3=(FLOAT(I+I-1)*Z*P2-FLOAT(I-1)*P1)/FLOAT(I)
|
||||
P1=P2
|
||||
P2=P3
|
||||
30 CONTINUE
|
||||
DP=FLOAT(LL)*(P1-Z*P2)/(1.0-Z*Z)
|
||||
Z=Z-P2/DP
|
||||
IF(ABS(Z-ZOLD)/Z.LT.1.0E-10) GO TO 51
|
||||
ZOLD=Z
|
||||
50 CONTINUE
|
||||
WRITE(6,9100)L
|
||||
9100 FORMAT(28H0NO CONVERGENCE FOR ZERO NO.,I4)
|
||||
51 CONTINUE
|
||||
X(L)=Z
|
||||
W(L)=2.0/((1.0-Z*Z)*DP*DP)
|
||||
Z1=Z2
|
||||
Z2=Z3
|
||||
Z3=Z
|
||||
200 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
50
dwuck4/culib8/LGNDR.FOR
Normal file
50
dwuck4/culib8/LGNDR.FOR
Normal file
|
|
@ -0,0 +1,50 @@
|
|||
|
||||
c***********************************************************************
|
||||
SUBROUTINE LGNDR(PLM,MPLUS,LPLUS,THET)
|
||||
c
|
||||
c Calculates Legendre polynomials Plm
|
||||
c
|
||||
c mplus number of m's >0
|
||||
c lplus number of l's >0
|
||||
c thet angle in degrees
|
||||
c***********************************************************************
|
||||
c
|
||||
IMPLICIT REAL*8(A-H,O-Z)
|
||||
|
||||
DIMENSION PLM(459)
|
||||
c
|
||||
THETA=THET /57.295779
|
||||
Y=COS(THETA)
|
||||
Z=SIN(THETA)
|
||||
IX=0
|
||||
DO 100 M=1,MPLUS
|
||||
LX=M-1
|
||||
L2=0
|
||||
P3=1.0
|
||||
FL1=LX
|
||||
IF(LX.EQ.0) GO TO 41
|
||||
DO 40 LT=1,LX
|
||||
FL1=FL1+1.0
|
||||
P3=P3*FL1*Z/2.0
|
||||
40 CONTINUE
|
||||
41 P2=0.0
|
||||
FL2=FL1+1.0
|
||||
FL3=1.0
|
||||
DO 90 LT=1,LPLUS
|
||||
IX1=IX+LT
|
||||
IF(L2-LX)50,70,60
|
||||
50 PLM(IX1)=0.0
|
||||
GO TO 75
|
||||
60 P3=(FL2*Y*P2-FL1*P1)/FL3
|
||||
FL1=FL1+1.0
|
||||
FL2=FL2+2.0
|
||||
FL3=FL3+1.0
|
||||
70 PLM(IX1)=P3
|
||||
P1=P2
|
||||
P2=P3
|
||||
75 L2=L2+1
|
||||
90 CONTINUE
|
||||
IX=IX+LPLUS
|
||||
100 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
326
dwuck4/culib8/POLFCT.FOR
Normal file
326
dwuck4/culib8/POLFCT.FOR
Normal file
|
|
@ -0,0 +1,326 @@
|
|||
c$debug
|
||||
subroutine polfct(max1,maxi,jr,js,theta,Pol,sr
|
||||
1 ,iopen20,iout20,nth,ntheta,ALPHA,IDAT)
|
||||
c -------------------------------------------------------------
|
||||
c max1 initial target multiplicity
|
||||
c maxi final target multiplicity
|
||||
c jr initial projectile multiplicity
|
||||
c js final projectile multiplicity
|
||||
c sr(1...js, 1...jr, 1...maxi, 1...max1), m storage order: -s...+s
|
||||
c -------------------------------------------------------------
|
||||
c Double precision statements -------------------------------
|
||||
implicit real*8 (a-h,o-z)
|
||||
double complex sr(js,jr,maxi,max1), a(3,3), b(3,3), c(3,3)
|
||||
1 , d(3,3,4), e(3,3,3), s(2,2,3), Sy(3,3,3)
|
||||
real*8 Knn
|
||||
c -------------------------------------------------------------
|
||||
c Single precision statements --------------------------------
|
||||
c complex sr(js,jr,maxi,max1), a(3,3), b(3,3), c(3,3)
|
||||
c 1 , d(3,3,4), e(3,3,3), s(2,2,3), Sy(3,3,3)
|
||||
c real*4 Knn
|
||||
c -------------------------------------------------------------
|
||||
parameter (nsig = 5, npol = 10, nay = 4, npy = 3
|
||||
1 , rads = 3.141592/180.)
|
||||
logical iopen20, iout20
|
||||
|
||||
dimension ii(nsig), jj(nsig)
|
||||
1 ,csig(nsig), Cij(nsig), dsig(nsig), Dij(nsig)
|
||||
2 , Pol(npol), Sij(3,3,4), IDAT(6), ALPHA(15)
|
||||
c
|
||||
c spin 1/2 matrices for Spin correlation coefficients
|
||||
c s stored as S_z, S_x and S_y
|
||||
c
|
||||
data s /(-1.,0.), (0.,0.), ( 0.,0.), (1.,0.)
|
||||
1 ,( 0.,0.), (1.,0.), ( 1.,0.), (0.,0.)
|
||||
2 ,( 0.,0.), (1.,0.), (-1.,0.), (0.,0.)/
|
||||
C
|
||||
c SY MATRIX FOR SPIN 0, 1/2 and 1
|
||||
c
|
||||
DATA Sy/(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.)
|
||||
1 ,(0.,0.),(0.,0.),(0.,0.),(0.,0.)
|
||||
1 ,(0.,0.),(0.,-1.),(0.,0.),(0., 1.),(0.,0.)
|
||||
3 ,(0.,0.),(0., 0.),(0.,0.),(0., 0.)
|
||||
2 ,(0.,0.),(0.,-.707106781),(0.,0.)
|
||||
5 ,(0., .707106781),(0.,0.),(0.,-.707106781)
|
||||
3 ,(0.,0.),(0.,.707106781),(0.,0.)/
|
||||
C
|
||||
C SYY = ( 3*SY*SY - S*S )
|
||||
C S22 = ( S^*S^ )*SQRT(3)/4
|
||||
C S21 = ( S^*SZ + SZ*S^)*SQRT(3)/2
|
||||
C S20 = ( 3*SZ*SZ - S*S )/SQRT(2)
|
||||
C
|
||||
DATA Sij/-0.5,0.0,-1.5, 0.0,1.0,0.0, -1.5,0.0,-0.5
|
||||
1, 0.0,0.0,0.0, 0.0,0.0,0.0, 1.73205081,0.0,0.0
|
||||
2, 0.0,0.0,0.0, -1.2247449,0.0,0.0, 0.0,1.2247449,0.0
|
||||
3, 0.70710678,0.0,0.0,0.0,-1.4124214,0.0
|
||||
4, 0.0,0.0,0.70710678/
|
||||
C
|
||||
c zz xx yy zx xz
|
||||
data ii/1, 2, 3, 1, 2/
|
||||
data jj/1, 2, 3, 2, 1/
|
||||
c
|
||||
c Array Pol(npol) contains
|
||||
c
|
||||
c Pol(1) Cross section
|
||||
c Pol(2) Vector Polarization
|
||||
c Pol(3) Vector Asymmetry
|
||||
c Pol(4-7) Tensor Asymmetry
|
||||
c Pol(8-10) Tensor Polarization
|
||||
c
|
||||
c write(20,'(1p8e12.4)')sr
|
||||
cs=cos(theta*rads)
|
||||
ss=sin(theta*rads)
|
||||
do 20 n=1,nsig
|
||||
csig(n)=0.0
|
||||
dsig(n)=0.0
|
||||
20 continue
|
||||
do 30 i=1,npol
|
||||
Pol(i) = 0.0
|
||||
30 continue
|
||||
Dnn = 0.0
|
||||
Knn = 0.0
|
||||
Tpol = 0.0
|
||||
c
|
||||
if(jr.gt.3 .or. js.gt.3) go to 2000
|
||||
c
|
||||
c
|
||||
do 200 mx=1,max1
|
||||
do 190 my=1,maxi
|
||||
c
|
||||
do 180 m =1,jr
|
||||
do 170 mp=1,js
|
||||
a(mp,m ) = 0.0
|
||||
b(mp, m) = 0.0
|
||||
c(mp, m) = 0.0
|
||||
if(jr .eq. 3) then
|
||||
do 115 i=1,nay
|
||||
d(mp,m ,i) = 0.0
|
||||
115 continue
|
||||
endif
|
||||
if(js .eq. 3) then
|
||||
do 116 i=1,npy
|
||||
e(mp,m ,i) = 0.0
|
||||
116 continue
|
||||
endif
|
||||
do 130 m1=1,jr
|
||||
c Asymmetry --------------------------------------------
|
||||
c Calculate asy = < S_y(initial) >
|
||||
b(mp,m )=b(mp,m ) + sr(mp,m1,my,mx) * Sy(m ,m1,jr)
|
||||
if(jr .eq. 3) then
|
||||
c Calculate Tensor asymmetry = <Sij(initial)>
|
||||
do 125 i=1,nay
|
||||
d(mp,m ,i)=d(mp,m ,i) + sr(mp,m1,my,mx) * Sij(m ,m1,i)
|
||||
125 continue
|
||||
endif
|
||||
130 continue
|
||||
do 140 m2=1,js
|
||||
c Polarization --------------------------------------------
|
||||
c Calculate pol = < S_y(final ) >
|
||||
a(mp,m )=a(mp,m ) + sr(m2,m ,my,mx) * Sy(m2,mp,js)
|
||||
if(js .eq. 3) then
|
||||
c Calculate Tensor polarization = <Sij(final)>
|
||||
do 135 i=1,npy
|
||||
e(mp,m ,i)=e(mp,m ,i) + sr(m2,m ,my,mx) * Sij(m2,mp,i+1)
|
||||
135 continue
|
||||
endif
|
||||
140 continue
|
||||
c
|
||||
Pol(1) =Pol(1) + conjg(sr(mp,m ,my,mx)) * sr(mp,m ,my,mx)
|
||||
Pol(2) =Pol(2) + conjg(sr(mp,m ,my,mx)) * a(mp,m )
|
||||
Pol(3) =Pol(3) + conjg(sr(mp,m ,my,mx)) * b(mp,m )
|
||||
if(jr .eq. 3) then
|
||||
do 160 i=1,nay
|
||||
Pol(i+3)=Pol(i+3) + conjg(sr(mp,m ,my,mx)) * d(mp,m ,i)
|
||||
160 continue
|
||||
endif
|
||||
if(js .eq. 3) then
|
||||
do 165 i=1,npy
|
||||
Pol(i+7)=Pol(i+7) + conjg(sr(mp,m ,my,mx)) * e(mp,m ,i)
|
||||
165 continue
|
||||
endif
|
||||
170 continue
|
||||
180 continue
|
||||
190 continue
|
||||
200 continue
|
||||
do 245 i=2,npol
|
||||
Pol(i) = Pol(i)/Pol(1)
|
||||
245 continue
|
||||
Sigma = Pol(1)
|
||||
Pol(1) = Pol(1)/float(max1*jr)
|
||||
c
|
||||
IF(iout20) THEN
|
||||
if(Sigma .eq. 0.0) go to 1000
|
||||
if(jr.eq.2 .and. maxi.eq.2) then
|
||||
c
|
||||
c Calculate target polarization I_n = <I_y(final)>
|
||||
c
|
||||
if(maxi .ge. 2 .and. maxi .le. 3) then
|
||||
do 240 m =1,jr
|
||||
do 235 mp=1,js
|
||||
do 230 mx=1,max1
|
||||
do 225 my=1,maxi
|
||||
a(my,mx) = 0.0
|
||||
do 220 m1=1,maxi
|
||||
a(my,mx) = a(my,mx) + Sy(m1,my,maxi) * sr(mp,m ,m1,mx)
|
||||
220 continue
|
||||
Tpol = Tpol + conjg(sr(mp,m ,my,mx))*a(my,mx)
|
||||
225 continue
|
||||
230 continue
|
||||
235 continue
|
||||
240 continue
|
||||
end if
|
||||
Tpol = Tpol /Sigma
|
||||
c
|
||||
c
|
||||
c Calculate Knn = < S_y(initial) * I_y(final) >
|
||||
c
|
||||
do 300 mx=1,max1
|
||||
do 290 mp=1,js
|
||||
c
|
||||
do 280 my=1,maxi
|
||||
do 270 m = 1,jr
|
||||
c(m ,my) = 0.0
|
||||
do 260 m1=1,maxi
|
||||
do 250 m2=1,jr
|
||||
c Knn coefficient
|
||||
c(m ,my)=c(m ,my) + sr(mp,m1,m2,mx) * Sy(my,m2,2)*Sy(m1,m ,2)
|
||||
250 continue
|
||||
260 continue
|
||||
Knn = Knn + conjg(sr(mp,m ,my,mx)) * c(m ,my)
|
||||
270 continue
|
||||
280 continue
|
||||
290 continue
|
||||
300 continue
|
||||
endif
|
||||
Knn = Knn /Sigma
|
||||
c
|
||||
if(jr .eq. 2 .and. js .eq.2) then
|
||||
c
|
||||
c Calculate Dij = < S_i(initial) * S_j(final) >
|
||||
c
|
||||
|
||||
do 600 mx=1,max1
|
||||
do 580 my=1,maxi
|
||||
do 500 n=1,nsig
|
||||
i1=ii(n)
|
||||
j1=jj(n)
|
||||
do 490 m =1,jr
|
||||
do 480 mp=1,js
|
||||
a(mp,m )=0.0
|
||||
do 440 m1=1,jr
|
||||
do 420 m2=1,js
|
||||
a(mp,m )=a(mp,m ) + sr(m2,m1,my,mx) * s(m2,mp,i1)*s(m ,m1,j1)
|
||||
420 continue
|
||||
440 continue
|
||||
c
|
||||
c Dij correlation coefficients
|
||||
dsig(n)=dsig(n)+conjg(sr(mp,m ,my,mx))*a(mp,m )
|
||||
480 continue
|
||||
490 continue
|
||||
500 continue
|
||||
580 continue
|
||||
600 continue
|
||||
endif
|
||||
c
|
||||
Dsig(3) = -Dsig(3)
|
||||
do 610 n=1,nsig
|
||||
dsig(n) = dsig(n)/Sigma
|
||||
610 continue
|
||||
c
|
||||
if(js .eq. 2 .and. maxi .eq. 2) then
|
||||
c
|
||||
c Spin correlation coefficients (final state target and projectile)
|
||||
c Calculate Cij = < S_y(final) * I_y(final) >
|
||||
c
|
||||
do 800 mx=1,max1
|
||||
do 780 m =1,jr
|
||||
c
|
||||
do 700 n=1,nsig
|
||||
i1=ii(n)
|
||||
j1=jj(n)
|
||||
do 690 my=1,maxi
|
||||
do 680 mp=1,js
|
||||
a(mp,my)=0.0
|
||||
do 640 m1=1,maxi
|
||||
do 620 m2=1,js
|
||||
a(mp,my)=a(mp,my)+sr(m2,m ,m1,mx)*s(m2,mp,i1)*s(m1,my,j1)
|
||||
620 continue
|
||||
640 continue
|
||||
c
|
||||
csig(n)=csig(n)+conjg(sr(mp,m ,my,mx))*a(mp,my)
|
||||
680 continue
|
||||
690 continue
|
||||
700 continue
|
||||
c
|
||||
780 continue
|
||||
800 continue
|
||||
do 820 n=1,nsig
|
||||
csig(n) = csig(n)/Sigma
|
||||
820 continue
|
||||
csig(3)=-csig(3)
|
||||
c
|
||||
c rotate operators to outgoing particle direction
|
||||
c
|
||||
c Minus signs on C_zz, C_xx and C_xz make output agree with the data
|
||||
c where the z and x axes for the target are in opposite directions
|
||||
c to those of the projectile
|
||||
c
|
||||
Cij(3) = -(csig(1)*cs**2 + csig(2)*ss**2
|
||||
1 + (csig(4)+csig(5))*cs*ss)
|
||||
Cij(1) = -(csig(1)*ss**2 + csig(2)*cs**2
|
||||
1 - (csig(4)+csig(5))*cs*ss)
|
||||
Cij(4) = -(csig(4)*cs**2-csig(5)*ss**2 + (csig(2)-csig(1))*cs*ss)
|
||||
Cij(5) = -(csig(5)*cs**2-csig(4)*ss**2 + (csig(2)-csig(1))*cs*ss)
|
||||
Cij(2) = csig(3)
|
||||
endif
|
||||
c
|
||||
c Singlet fraction
|
||||
ssum = (1.0-(csig(1)+csig(2)+csig(3)))/4.0
|
||||
c
|
||||
Dij(3) = dsig(1)
|
||||
Dij(1) = dsig(2)
|
||||
Dij(4) = dsig(4)
|
||||
Dij(5) = dsig(5)
|
||||
Dij(2) = dsig(3)
|
||||
c Calculate Dnn = < S_y(initial) * S_y(final) >
|
||||
Dnn = Dij(2)
|
||||
1000 continue
|
||||
ENDIF
|
||||
2000 continue
|
||||
c
|
||||
c --------------------------------------------------------
|
||||
c output to disk file 20 and file 21
|
||||
c
|
||||
if(iopen20) then
|
||||
open(unit = 20, file = 'for020.dat', status = 'unknown')
|
||||
open(unit = 21, file = 'for021.dat', status = 'unknown')
|
||||
iopen20 = .false.
|
||||
endif
|
||||
c
|
||||
if(iout20) then
|
||||
c Write header to file
|
||||
if(nth .eq. 1) then
|
||||
WRITE(20,9010)ALPHA,IDAT
|
||||
write(20,9020) ntheta
|
||||
WRITE(21,9010)ALPHA,IDAT
|
||||
write(21,9021) ntheta
|
||||
endif
|
||||
c
|
||||
write(20,'(2(0pf8.3,1h,) ,1pe12.4, 10(:1h,,0pf7.4))')
|
||||
1 theta, cs, (Pol(i),i=1,3), Dnn, Knn, Tpol
|
||||
c
|
||||
write(21,'(0pf8.3,1h,,0pf8.3, 12(:1h,,0pf7.4))')
|
||||
1 theta, cs, Cij, Dij, ssum
|
||||
endif
|
||||
c
|
||||
c
|
||||
return
|
||||
c
|
||||
9010 FORMAT(' (',15A4,I4.2,2(1H/,I2.2),I4.2,2(1H:,I2.2))
|
||||
9020 FORMAT(' (',i2,',angle cos[th] Sigma Pol Asy'
|
||||
1 ,' Dnn Knn Inn')
|
||||
9021 FORMAT(' (',i2,',angle cos[th] Cxx Cyy Czz Czx'
|
||||
1 ,' Cxz Dxx Dyy Dzz Dzx Dxz fsingl')
|
||||
c
|
||||
end
|
||||
|
||||
726
dwuck4/culib8/POTS.FOR
Normal file
726
dwuck4/culib8/POTS.FOR
Normal file
|
|
@ -0,0 +1,726 @@
|
|||
|
||||
c***********************************************************************
|
||||
SUBROUTINE POTS(U,V)
|
||||
c
|
||||
c Calculates the potentials or form factors
|
||||
c***********************************************************************
|
||||
c
|
||||
IMPLICIT REAL*8(A-H,O-Z)
|
||||
COMMON/POTTER/DRX,AFACT(2),VFACT,SFACT,ENG,RM,G(4),ETAX,FKX,ETAKX
|
||||
1 ,RCX,HBARC2,ABETA(3),FLDF(3)
|
||||
2 ,NX,LAMX,KMXX,KX,IBX,LPLUSX,ICON4,NSPC,IDIRAC,ICHK
|
||||
|
||||
CHARACTER*18 B(21),C(22)
|
||||
DIMENSION UT(5),CN(16),CP(16),YLAM(16),PLM(8)
|
||||
1 ,XG(8),WG(8),U(800),V(800),LDFRM(3)
|
||||
C DIMENSION UD(800)
|
||||
EQUIVALENCE (B(1),C(2)),(YLAM(1),PLM(1))
|
||||
C
|
||||
DATA C( 1) /' NX=0 No potential'/
|
||||
DATA B( 1) /' NX=1 VOLUME W-S '/
|
||||
DATA B( 2) /' NX=2 SURFACE W-S '/
|
||||
DATA B( 3) /' NX=3 2ND DERIV '/
|
||||
DATA B( 4) /' NX=4 L*S VOLUME '/
|
||||
DATA B( 5) /' NX=5 L*S SURFACE '/
|
||||
DATA B( 6) /' NX=6 VOL *R**POWR'/
|
||||
DATA B( 7) /' NX=7 SURF*R**POWR'/
|
||||
DATA B( 8) /' NX=8 EXTERN FORMF'/
|
||||
DATA B( 9) /' NX=9 HARMONIC OSC'/
|
||||
DATA B(10) /' NX=10 GAUSSIAN '/
|
||||
DATA B(11) /' NX=11 DEFORM VOL '/
|
||||
DATA B(12) /' NX=12 DEFORM SURF'/
|
||||
DATA B(13) /' NX=13 HULTHEN '/
|
||||
DATA B(14) /' NX=14 NO OPTION '/
|
||||
DATA B(15) /' NX=15 NO OPTION '/
|
||||
DATA B(16) /' NX=16 NO OPTION '/
|
||||
DATA B(17) /' NX=17 NO OPTION '/
|
||||
DATA B(18) /' NX=18 Volume L*S '/
|
||||
DATA B(19) /' NX=19 COUL EXCIT '/
|
||||
DATA B(20) /' NX=20 VECTOR '/
|
||||
DATA B(21) /' NX=21 SCALAR '/
|
||||
|
||||
C
|
||||
DATA NG,NGX/8,0/
|
||||
C
|
||||
ETA4 = 6.0
|
||||
ETA5 =10.0
|
||||
SQRPI= 1.772453851
|
||||
PI=3.141592654
|
||||
C
|
||||
IVFLAG=0
|
||||
ISFLAG=0
|
||||
FACT=VFACT
|
||||
70 CONTINUE
|
||||
C
|
||||
C READ IN CARD SET 5,6,OR 7 POTENTIAL CARDS
|
||||
C
|
||||
READ (5,9000)FZ,VR,RY,AR,VSOR,VI,RZ,AI,VSOI,PWR
|
||||
C
|
||||
NZ=ABS(FZ)
|
||||
RR=ABS(RY)*AFACT(1)
|
||||
IF(RY.LT.0.0) RR=RR+ABS(RY)*AFACT(2)
|
||||
RI=ABS(RZ)*AFACT(1)
|
||||
IF(RZ.LT.0.0) RI=RI+ABS(RZ)*AFACT(2)
|
||||
IF(ICON4.NE.2.OR.NSPC.LT.3) THEN
|
||||
WRITE(6,9509)B(NZ),VR,RY,AR,RR,VSOR
|
||||
WRITE(6,9510) VI,RZ,AI,RI,VSOI,PWR
|
||||
ENDIF
|
||||
C NZ= 1 VOLUME WOODS-SAXON
|
||||
C NZ= 2 SURFACE WOODS-SAXON
|
||||
C NZ= 3 SECOND DERIVATIVE WOODS-SAXON
|
||||
C NZ= 4 L*S POTENTIAL FOR WOODS-SAXON VOLUME
|
||||
C NZ= 5 L*S POTENTIAL FOR WOODS-SAXON SURFACE
|
||||
C NZ= 6 WOOD-SAXON*R**PWR
|
||||
C NZ= 7 1ST-DER WOOD-SAXON*R**PWR
|
||||
C NZ= 8 FORMF8 EXTERNAL FORM FACTOR
|
||||
C NZ= 9 HARMONIC OSCILLATOR
|
||||
C NZ=10 GAUSSIAN*R**PWR
|
||||
C NZ=11 DEFORMED VOLUME
|
||||
C NZ=12 DEFORMED SURFACE
|
||||
C NZ=13 Hulthen
|
||||
C Nz=18 Volume L*S
|
||||
C NZ=19 COULOMB-EXCITATION
|
||||
C NZ=20 VECTOR DIRAC
|
||||
C NZ=21 SCALAR DIRAC
|
||||
C
|
||||
KFLAG=0
|
||||
IF(NX.LT.3) THEN
|
||||
VR=VR*FACT
|
||||
VI=VI*FACT
|
||||
KT=FKX * MAX (RR,RI)+ETA5
|
||||
LPLUSX=MAX0(LPLUSX,KT)
|
||||
KT=(2.3*ETA4* MAX (AR,AI)+ MAX (RR,RI))/DRX
|
||||
ELSE
|
||||
IF(ENG.EQ.0.0) THEN
|
||||
KT=(2.3*ETA4* MAX (AR,AI)+ MAX (RR,RI))/DRX
|
||||
ELSE
|
||||
RM= MAX (RM,RR)
|
||||
RM= MAX (RM,RI)
|
||||
IF(RM.EQ.0.0) RM=1.0
|
||||
VR=VR*FACT
|
||||
VI=VI*FACT
|
||||
KT=(2.3*ETA4/SQRT(FKX**2+2.0*ETAX*FKX/RM))/DRX
|
||||
ENDIF
|
||||
ENDIF
|
||||
KX=MIN0(MAX0(KX,KT),KMXX)
|
||||
83 CONTINUE
|
||||
IF(AR.EQ.0.0) THEN
|
||||
F1=0.0
|
||||
F2=0.0
|
||||
ELSE
|
||||
F2=EXP(-DRX /AR)
|
||||
F1=EXP( RR/AR)
|
||||
ENDIF
|
||||
IF(AI.EQ.0.0) THEN
|
||||
F3=0.0
|
||||
F4=0.0
|
||||
ELSE
|
||||
F4=EXP(-DRX /AI)
|
||||
F3=EXP( RI/AI)
|
||||
ENDIF
|
||||
C
|
||||
IF(NX.GE.3.AND.ENG.EQ.0.0.AND.NZ.LE.5) THEN
|
||||
IF(AR.NE.0.0) VR=VR*(RR/AR)**(PWR+1)
|
||||
IF(AI.NE.0.0) VI=VI*(RI/AI)**(PWR+1)
|
||||
ENDIF
|
||||
IF(NZ.EQ.0) GO TO 6050
|
||||
GO TO (100,200,300,400,500,600,700,800,900,1000,1100,1200
|
||||
1,1300,1400,1500,1600,1700,1800,1900,2000,2100),NZ
|
||||
C
|
||||
C VOLUME WOODS SAXON
|
||||
C
|
||||
100 CONTINUE
|
||||
DO 160 M=1,KX
|
||||
MK=M+M-1
|
||||
F1=F1*F2
|
||||
F3=F3*F4
|
||||
U(MK )=U(MK )-VR*F1/(1.0+F1)
|
||||
U(MK+1)=U(MK+1)-VI*F3/(1.0+F3)
|
||||
160 CONTINUE
|
||||
GO TO 6000
|
||||
C
|
||||
C 1ST DERIVATIVE WOODS SAXON
|
||||
C
|
||||
200 CONTINUE
|
||||
DO 260 M=1,KX
|
||||
MK=M+M-1
|
||||
F1=F1*F2
|
||||
F3=F3*F4
|
||||
U(MK )=U(MK )+VR*F1/(1.0+F1)**2
|
||||
U(MK+1)=U(MK+1)+VI*F3/(1.0+F3)**2
|
||||
260 CONTINUE
|
||||
GO TO 6000
|
||||
C
|
||||
C 2ND DERIVATIVE WOODS SAXON
|
||||
C
|
||||
300 CONTINUE
|
||||
DO 360 M=1,KX
|
||||
MK=M+M-1
|
||||
F1=F1*F2
|
||||
F3=F3*F4
|
||||
U(MK )=U(MK )-VR*F1*(1.0-F1)/(1.0+F1)**3
|
||||
U(MK+1)=U(MK+1)-VI*F3*(1.0-F3)/(1.0+F3)**3
|
||||
360 CONTINUE
|
||||
GO TO 6000
|
||||
C
|
||||
C L.S VOLUME WOODS SAXON
|
||||
C
|
||||
400 CONTINUE
|
||||
IBX=1
|
||||
IF(AR.NE.0.0) VR=VR/AR
|
||||
IF(AI.NE.0.0) VI=VI/AI
|
||||
R=0.0
|
||||
DO 460 M=1,KX
|
||||
R=R+DRX
|
||||
MK=M+M-1
|
||||
F1=F1*F2
|
||||
F3=F3*F4
|
||||
V(MK )=V(MK )-VR*F1/(R*(1.0+F1)**2)
|
||||
V(MK+1)=V(MK+1)-VI*F3/(R*(1.0+F3)**2)
|
||||
460 CONTINUE
|
||||
GO TO 6000
|
||||
C
|
||||
C L.S 1ST DERIVATIVE WOODS SAXON
|
||||
C
|
||||
500 CONTINUE
|
||||
IBX=1
|
||||
IF(AR.NE.0.0) VR=VR/AR
|
||||
IF(AI.NE.0.0) VI=VI/AI
|
||||
R=0.0
|
||||
DO 560 M=1,KX
|
||||
R=R+DRX
|
||||
MK=M+M-1
|
||||
F1=F1*F2
|
||||
F3=F3*F4
|
||||
V(MK )=V(MK )+VR*F1*(1.0-F1)/(R*(1.0+F1)**3)
|
||||
V(MK+1)=V(MK+1)+VI*F3*(1.0-F3)/(R*(1.0+F3)**3)
|
||||
560 CONTINUE
|
||||
GO TO 6000
|
||||
C
|
||||
C WOOD SAXON*R**PWR
|
||||
C
|
||||
600 CONTINUE
|
||||
R=0.0
|
||||
DO 660 M=1,KX
|
||||
R=R+DRX
|
||||
MK=M+M-1
|
||||
F1=F1*F2
|
||||
F3=F3*F4
|
||||
RPWR=R**PWR
|
||||
U(MK )=U(MK )-VR*F1*RPWR/(1.0+F1)
|
||||
U(MK+1)=U(MK+1)-VI*F3*RPWR/(1.0+F3)
|
||||
660 CONTINUE
|
||||
GO TO 6000
|
||||
C
|
||||
C 1ST DERIVATIVE WOOD SAXON*R**PWR
|
||||
C
|
||||
700 CONTINUE
|
||||
R=0.0
|
||||
DO 760 M=1,KX
|
||||
MK=M+M-1
|
||||
R=R+DRX
|
||||
F1=F1*F2
|
||||
F3=F3*F4
|
||||
RPWR=R**PWR
|
||||
U(MK )=U(MK )+VR*F1*RPWR/(1.0+F1)**2
|
||||
U(MK+1)=U(MK+1)+VI*F3*RPWR/(1.0+F3)**2
|
||||
760 CONTINUE
|
||||
GO TO 6000
|
||||
C
|
||||
C EXTERNAL FORM FACTOR
|
||||
C
|
||||
800 CONTINUE
|
||||
IF(NX.GE.3) THEN
|
||||
READ (5,9000)G
|
||||
WRITE(6,9508)G
|
||||
ENDIF
|
||||
READ(5,9000)F1,F2
|
||||
C
|
||||
C F2 = 0 REAL CENTRAL
|
||||
C F2 = 1 IMAG CENTRAL
|
||||
C F2 = 2 REAL SPIN ORBIT
|
||||
C F2 = 3 IMAG SPIN ORBIT
|
||||
C
|
||||
IF(F2.EQ.0.0.OR.F2.EQ.2) THEN
|
||||
F3=VR
|
||||
MK=1
|
||||
ELSE
|
||||
F3=VI
|
||||
MK=2
|
||||
ENDIF
|
||||
IF(F3.EQ.0.0) F3=1.0
|
||||
KT=F1
|
||||
DO 820 M=1,KT,5
|
||||
READ(5,9100)UT
|
||||
IF(M.GT.KMXX) GO TO 820
|
||||
DO 810 I=1,5
|
||||
IF(F2.LT.2.0) THEN
|
||||
U(MK )=U(MK )+UT(I)*F3
|
||||
ELSE
|
||||
V(MK )=V(MK )+UT(I)*F3
|
||||
ENDIF
|
||||
MK=MK+2
|
||||
810 CONTINUE
|
||||
820 continue
|
||||
kmxx2 = 2*kmxx
|
||||
if(abs(FZ) .ne. float(NZ)) then
|
||||
read (5,9100)(U(i+kmxx2),i=1,10)
|
||||
IBX = U(5+kmxx2)
|
||||
endif
|
||||
C
|
||||
KX=min0(KT,kmxx)
|
||||
|
||||
GO TO 6000
|
||||
C
|
||||
C HARMONIC OSCILLATOR, NORMALIZED N*EXP(-(R/RY)**2/2)
|
||||
C
|
||||
900 CONTINUE
|
||||
READ (5,9000)G
|
||||
WRITE(6,9508)G
|
||||
F1=1.0/RY**2
|
||||
F2=F1/RY
|
||||
F3=0.5
|
||||
F4=SQRPI*0.5
|
||||
L=G(2)
|
||||
IF(L.NE.0) THEN
|
||||
DO 930 I=1,L
|
||||
F3=F3+1.0
|
||||
F4=F4*F3
|
||||
F2=F2*F1
|
||||
930 CONTINUE
|
||||
ENDIF
|
||||
NN=G(1)
|
||||
T1=1.0
|
||||
T2=F4
|
||||
C LAGUERRE POLYNOMIAL COEFFICIENTS = (Abramowitz-Stegun)*(-1)**nn
|
||||
CN(1)=(-1.0)**NN
|
||||
IF(NN.NE.0) THEN
|
||||
DO 940 I=1,NN
|
||||
F3=F3+1.0
|
||||
T1=T1*FLOAT(I)
|
||||
T2=T2*F3
|
||||
CN(I+1)=-CN(I)*F1*FLOAT(NN+1-I)/(FLOAT(I)*F3)
|
||||
940 CONTINUE
|
||||
ENDIF
|
||||
ANORM=SQRT(2.0*F2*T1/T2)*T2/(T1*F4)
|
||||
IF(VR.NE.0.0) ANORM=VR*ANORM
|
||||
KT=10.0*RY/DRX
|
||||
KT=MIN0(KT,KMXX)
|
||||
R=0.0
|
||||
F1=F1/2.0
|
||||
DO 960 M=1,KT
|
||||
MK=M+M-1
|
||||
R=R+DRX
|
||||
R2=R**2
|
||||
F2=CN(1)
|
||||
IF(NN.EQ.0) GO TO 951
|
||||
F3=1.0
|
||||
DO 950 I=1,NN
|
||||
F3=F3*R2
|
||||
F2=F2+CN(I+1)*F3
|
||||
950 CONTINUE
|
||||
951 CONTINUE
|
||||
U(MK )=U(MK )+F2*ANORM*EXP(-F1*R2)*R**L
|
||||
960 CONTINUE
|
||||
GO TO 6000
|
||||
C
|
||||
C EXP(-(R/R0)**2)*R**POWR
|
||||
C
|
||||
1000 CONTINUE
|
||||
IF(VR.NE.0.0) THEN
|
||||
R=0.0
|
||||
DO 1060 M=1,KX
|
||||
MK=M+M-1
|
||||
R=R+DRX
|
||||
U(MK )=U(MK )-VR*EXP(-(R/RY)**2)*R**PWR
|
||||
1060 CONTINUE
|
||||
endif
|
||||
IF(VI.NE.0.0) THEN
|
||||
R=0.0
|
||||
DO 1070 M=1,KX
|
||||
MK=M+M-1
|
||||
R=R+DRX
|
||||
U(MK+1)=U(MK+1)-VI*EXP(-(R/RZ)**2)*R**PWR
|
||||
1070 CONTINUE
|
||||
endif
|
||||
GO TO 6000
|
||||
C
|
||||
C DEFORMED VOLUME OR SURFACE BY YLM EXPANSION
|
||||
C
|
||||
1100 CONTINUE
|
||||
IF(NGX.NE.NG) THEN
|
||||
CALL LEGAUS(2*NG,XG,WG)
|
||||
NGX=NG
|
||||
ENDIF
|
||||
T2=(-1.0)**LAMX
|
||||
IF(ICHK.EQ.0) THEN
|
||||
READ (5,9000) (ABETA(J),FLDF(J) ,J=1,3)
|
||||
WRITE(6,9000)
|
||||
WRITE(6,9512) (ABETA(J),FLDF(J) ,J=1,3)
|
||||
ENDIF
|
||||
LMAX=LAMX+1
|
||||
DO 1101 J=1,3
|
||||
LDFRM(J)=FLDF(J)
|
||||
LMAX=MAX0(LMAX,LDFRM(J)+1)
|
||||
1101 CONTINUE
|
||||
T2=(-1.0)**LAMX
|
||||
C
|
||||
DO 1108 I=1,NG
|
||||
CN(I )=0.0
|
||||
CN(I+NG)=0.0
|
||||
P2=0.0
|
||||
P3=1.0
|
||||
C
|
||||
DO 1106 M=1,LMAX
|
||||
L=M-1
|
||||
FL=L-1
|
||||
IF(L.EQ.0) GO TO 1102
|
||||
P3=((2.0*FL+1.0)*XG(I)*P2-FL*P1)/(FL+1.0)
|
||||
1102 CONTINUE
|
||||
DO 1103 J=1,3
|
||||
IF(ABETA(J).EQ.0.0) GO TO 1103
|
||||
IF(L.NE.LDFRM(J)) GO TO 1103
|
||||
FACTOR=P3*ABETA(J)*SQRT(FLOAT(L+L+1)/(4.0*PI))
|
||||
CN(I )=CN(I )+FACTOR
|
||||
CN(I+NG)=CN(I+8)+FACTOR*(-1.0)**LDFRM(J)
|
||||
1103 CONTINUE
|
||||
IF(L.NE.LAMX) GO TO 1104
|
||||
YLAM(I )= P3*WG(I)*SQRT(FLOAT(L+L+1)*PI)
|
||||
YLAM(I+NG)=YLAM(I )*T2
|
||||
1104 CONTINUE
|
||||
P1=P2
|
||||
P2=P3
|
||||
1106 CONTINUE
|
||||
1108 CONTINUE
|
||||
DO 1170 I=1,2
|
||||
IF(I.EQ.1) THEN
|
||||
IF(VR.EQ.0.0) GO TO 1170
|
||||
VX=VR
|
||||
RX=RR
|
||||
AX=AR
|
||||
F1=1.0
|
||||
IFL=-1
|
||||
ELSE
|
||||
IF(VI.EQ.0.0) GO TO 1170
|
||||
VX=VI
|
||||
RX=RI
|
||||
AX=AI
|
||||
F1=1.0
|
||||
F2=F4
|
||||
IFL=0
|
||||
ENDIF
|
||||
DO 1135 J=1,16
|
||||
CP(J)=EXP((1.0+CN(J))*RX/AX)
|
||||
1135 CONTINUE
|
||||
IF(LAMX.EQ.0) VX=VX/(SQRPI*2.0)
|
||||
J=NZ-10
|
||||
IF(J.EQ.2) GO TO 1151
|
||||
DO 1150 M=1,KX
|
||||
MK=M+M+IFL
|
||||
VTEMP=0.0
|
||||
F1=F1*F2
|
||||
DO 1145 J=1,16
|
||||
F3=F1*CP(J)
|
||||
VTEMP=VTEMP-YLAM(J)*VX*F3/(1.0+F3)
|
||||
1145 CONTINUE
|
||||
U(MK )=U(MK )+VTEMP
|
||||
1150 CONTINUE
|
||||
GO TO 1170
|
||||
1151 CONTINUE
|
||||
DO 1160 M=1,KX
|
||||
MK=M+M+IFL
|
||||
VTEMP=0.0
|
||||
F1=F1*F2
|
||||
DO 1155 J=1,16
|
||||
F3=F1*CP(J)
|
||||
VTEMP=VTEMP+YLAM(J)*VX*F3/(1.0+F3)**2
|
||||
1155 CONTINUE
|
||||
U(MK )=U(MK )+VTEMP
|
||||
1160 CONTINUE
|
||||
1170 CONTINUE
|
||||
GO TO 6000
|
||||
1200 CONTINUE
|
||||
GO TO 1100
|
||||
C
|
||||
C HULTHEN WAVE FUNCTION= NORM*(EXP(-R/RY)-EXP(-R/RZ))/R
|
||||
C
|
||||
1300 CONTINUE
|
||||
READ (5,9000)G
|
||||
WRITE(6,9508)G
|
||||
T1=1.0/RY
|
||||
T2=1.0/RZ
|
||||
T3=T2**2-T1**2
|
||||
T4=SQRT(2.0*T1*(T1+T2)*T2)/(T2-T1)
|
||||
IF(VR.NE.0.0) KT=16.0* MIN (RY,RZ)/DRX
|
||||
IF(VR.EQ.0.0) KT=16.0* MAX (RY,RZ)/DRX
|
||||
KX=MIN0(KX,KMXX)
|
||||
F1=1.0
|
||||
F2=EXP(-DRX *T1)
|
||||
F3=1.0
|
||||
F4=EXP(-DRX *T2)
|
||||
R=0.0
|
||||
DO 1260 M=1,KX
|
||||
MK=M+M-1
|
||||
R=R+DRX
|
||||
F1=F1*F2
|
||||
F3=F3*F4
|
||||
V(M)=T3*F3/(F1-F3)
|
||||
TEMP=1.0
|
||||
IF(VR.NE.0.0) TEMP=V(M)/FACT
|
||||
U(MK )=U(MK )+TEMP*T4*(F1-F3)/R
|
||||
1260 CONTINUE
|
||||
GO TO 6000
|
||||
1400 CONTINUE
|
||||
1500 CONTINUE
|
||||
1600 CONTINUE
|
||||
1700 CONTINUE
|
||||
go to 6000
|
||||
1800 CONTINUE
|
||||
DO 1860 M=1,KX
|
||||
MK=M+M-1
|
||||
F1=F1*F2
|
||||
F3=F3*F4
|
||||
V(MK )=V(MK )-VR*F1/(1.0+F1)
|
||||
V(MK+1)=V(MK+1)-VI*F3/(1.0+F3)
|
||||
1860 CONTINUE
|
||||
GO TO 6000
|
||||
1900 CONTINUE
|
||||
c
|
||||
c Coulomb excitation for a deformed uniform charge distribution
|
||||
c
|
||||
IF(ICHK.EQ.0) THEN
|
||||
READ (5,9000) (ABETA(J),FLDF(J) ,J=1,3)
|
||||
WRITE(6,9000)
|
||||
WRITE(6,9512) (ABETA(J),FLDF(J) ,J=1,3)
|
||||
ENDIF
|
||||
if(vr.eq.0.0) vr=1.0
|
||||
do 1990 i=1,3
|
||||
beta=abeta(i)
|
||||
if(beta.ne.0.0) then
|
||||
c set flag for unbound stripping evaluation of coulomb ex.
|
||||
ibx=4
|
||||
flam1=beta*sqrt(float(2*lamx+1)/(4.0*pi))
|
||||
flam2=flam1*phasef(lamx)
|
||||
c
|
||||
if(ngx.ne.ng) then
|
||||
ngx=ng
|
||||
call legaus(2*ng,xg,wg)
|
||||
endif
|
||||
c
|
||||
an=0.0
|
||||
do 1920 k=1,ng
|
||||
p1=0.0
|
||||
p2=1.0
|
||||
if(lamx.gt.0) then
|
||||
do 1910 j=1,lamx
|
||||
p3=(float(2*j-1)*xg(k)*p2 - float(j-1)*p1)/float(j)
|
||||
p1=p2
|
||||
p2=p3
|
||||
1910 continue
|
||||
endif
|
||||
plm(k)=p2
|
||||
c
|
||||
c calculate normalization
|
||||
c
|
||||
r1=rcx*(1.0+flam1*p2)
|
||||
r2=rcx*(1.0+flam2*p2)
|
||||
an=an+(r1**3+r2**3)*wg(k)
|
||||
1920 continue
|
||||
c
|
||||
an =an/3.0
|
||||
c
|
||||
r =0.0
|
||||
c
|
||||
do 1940 m=1,kx
|
||||
mk=m+m-1
|
||||
r=r+drx
|
||||
sum=0.0
|
||||
do 1930 k=1,ng
|
||||
r1=rcx*(1.0+flam1*plm(k))
|
||||
r2=rcx*(1.0+flam2*plm(k))
|
||||
c
|
||||
if(r.gt.r1) then
|
||||
s1=r1**(lamx+3)/(r**(lamx+1)*float(lamx+3))
|
||||
else
|
||||
if(lamx.eq.2) then
|
||||
s1=( log(r1/r)+1.0/float(lamx+3))*r**2
|
||||
else
|
||||
s1=(r**lamx/r1**(lamx-2)
|
||||
1 -float(2*lamx+1)*r**2/float(lamx+3))/float(2-lamx)
|
||||
endif
|
||||
endif
|
||||
c
|
||||
if(r.gt.r2) then
|
||||
s2=r2**(lamx+3)/(r**(lamx+1)*float(lamx+3))
|
||||
else
|
||||
if(lamx.eq.2) then
|
||||
s2=( log(r2/r)+1.0/float(lamx+3))*r**2
|
||||
else
|
||||
s2=(r**lamx/r2**(lamx-2)
|
||||
1 -float(2*lamx+1)*r**2/float(lamx+3))/float(2-lamx)
|
||||
endif
|
||||
endif
|
||||
c
|
||||
sum=sum+(s1+s2*phasef(lamx))*wg(k)*plm(k)
|
||||
1930 continue
|
||||
c
|
||||
sum=sum/an
|
||||
if(beta.ne.0.0.and.lamx.ne.0) sum=sum/flam1
|
||||
u(mk )=u(mk )+sum*(vr*etakx/fact)
|
||||
1940 continue
|
||||
endif
|
||||
1990 continue
|
||||
GO TO 6000
|
||||
C
|
||||
C VECTOR POTENTIAL
|
||||
C VSOR, VSOI ARE THE THIRD PARAMETERS
|
||||
C IN THE 3 PARAMETER FERMI MODEL
|
||||
C [1 + VSO?*(R/R?)**2]
|
||||
C
|
||||
2000 CONTINUE
|
||||
IVFLAG=-1
|
||||
R=0.0
|
||||
DO 2060 M=1,KX
|
||||
MK=M+M-1
|
||||
R=R+DRX
|
||||
F1=F1*F2
|
||||
F3=F3*F4
|
||||
U(MK )=U(MK )-VR*F1*(1.0+VSOR*(R/RR)**2)/(1.0+F1)
|
||||
U(MK+1)=U(MK+1)-VI*F3*(1.0+VSOI*(R/RI)**2)/(1.0+F3)
|
||||
2060 CONTINUE
|
||||
GO TO 6020
|
||||
C
|
||||
C SCALAR POTENTIAL
|
||||
C VSOR, VSOI ARE THE FERMI THIRD PARAMETERS
|
||||
C IN THE 3 PARAMETER FERMI MODEL
|
||||
C [1 + VSO?*(R/R?)**2]
|
||||
C
|
||||
2100 CONTINUE
|
||||
ISFLAG=-1
|
||||
VR=VR*(SFACT/VFACT)
|
||||
VI=VI*(SFACT/VFACT)
|
||||
R=0.0
|
||||
DO 2160 M=1,KX
|
||||
MK=M+M-1
|
||||
R=R+DRX
|
||||
F1=F1*F2
|
||||
F3=F3*F4
|
||||
V(MK )=V(MK )-VR*F1*(1.0+VSOR*(R/RR)**2)/(1.0+F1)
|
||||
V(MK+1)=V(MK+1)-VI*F3*(1.0+VSOI*(R/RI)**2)/(1.0+F3)
|
||||
2160 CONTINUE
|
||||
GO TO 6020
|
||||
C
|
||||
C END OF POTENTIALS
|
||||
C
|
||||
6000 CONTINUE
|
||||
IDIRAC=1
|
||||
6020 CONTINUE
|
||||
IF(KFLAG.NE.0.OR.NZ.GT.5) GO TO 6050
|
||||
IF(ABS(VSOR)+ABS(VSOI).EQ.0.0) GO TO 6050
|
||||
NZ=NZ+3
|
||||
KFLAG=1
|
||||
VR=VR*VSOR/45.2
|
||||
VI=VI*VSOI/45.2
|
||||
GO TO 83
|
||||
6050 CONTINUE
|
||||
IF(FZ.GT.0.0) GO TO 70
|
||||
C
|
||||
C PROCESS DIRAC POTENTIALS
|
||||
C
|
||||
C ENTRY WITH U -> K**2 - VFACT*V VFACT = 2.0*W1 /HBARC**2
|
||||
C V -> - SFACT*S SFACT = 2.0*FM1/HBARC**2
|
||||
C
|
||||
IF(IVFLAG.NE.0.AND.ISFLAG.NE.0) THEN
|
||||
IF(IDIRAC.EQ.1) THEN
|
||||
WRITE(6,9515)
|
||||
ENDIF
|
||||
IDIRAC=-1
|
||||
C
|
||||
C KT2=KX+KX
|
||||
C WRITE(20,7777)' ENTRY POTENTIALS'
|
||||
C WRITE(20,7778)(U(I),I=1,KT2)
|
||||
C WRITE(20,7777)
|
||||
C WRITE(20,7778)(V(I),I=1,KT2)
|
||||
W1M1=(VFACT+SFACT)*0.5*HBARC2
|
||||
|
||||
DO 6100 M=1,Kx
|
||||
MK=M+M-1
|
||||
VVR=(U(MK )-FKX**2)/VFACT
|
||||
VVI= U(MK+1) /VFACT
|
||||
VSR= V(MK ) /SFACT
|
||||
VSI= V(MK+1) /SFACT
|
||||
U(MK )=U(MK )+V(MK ) +(VVR**2-VVI**2 - VSR**2+VSI**2)/HBARC2
|
||||
U(MK+1)=U(MK+1)+V(MK+1) +(VVR*VVI - VSR*VSI)*2.0/HBARC2
|
||||
T1 = W1M1 + VVR-VSR
|
||||
T2 = VVI-VSI
|
||||
V(MK )=0.5* LOG (T1**2 + T2**2)
|
||||
V(MK+1)=ATAN2(T2,T1)
|
||||
6100 CONTINUE
|
||||
C WRITE(20,7777)' SECOND POTENTIALS'
|
||||
C WRITE(20,7778)(U(I),I=1,KT2)
|
||||
C WRITE(20,7777)
|
||||
C WRITE(20,7778)(V(I),I=1,KT2)
|
||||
C
|
||||
R=FLOAT(KX+1)*DRX
|
||||
MK=KX+KX-1
|
||||
D2=V(MK )
|
||||
D1=D2
|
||||
A2=V(MK+1)
|
||||
A1=A2
|
||||
IBX=1
|
||||
DO 6150 M=2,KX
|
||||
MK=MK-2
|
||||
R=R-DRX
|
||||
D3=D2
|
||||
D2=D1
|
||||
D1=V(MK )
|
||||
A3=A2
|
||||
A2=A1
|
||||
A1=V(MK+1)
|
||||
C FIRST DERIVATIVE TERMS
|
||||
DPR=(D3-D1)/(2.0*DRX)
|
||||
DPI=(A3-A1)/(2.0*DRX)
|
||||
V(MK+2)=2.0*DPR/R
|
||||
V(MK+3)=2.0*DPI/R
|
||||
C SECOND DERIVATIVE TERMS
|
||||
DPPR=(D3+D1-2.0*D2)/DRX**2
|
||||
DPPI=(A3+A1-2.0*A2)/DRX**2
|
||||
UDR =0.5*DPPR-0.25*(DPR**2-DPI**2)+DPR/R
|
||||
UDI =0.5*DPPI-0.25*(2.0*DPR*DPI )+DPI/R
|
||||
C UD(MK+2)=UDR
|
||||
C UD(MK+3)=UDI
|
||||
U(MK+2)=U(MK+2)+UDR
|
||||
U(MK+3)=U(MK+3)+UDI
|
||||
6150 CONTINUE
|
||||
V(1 )=V(3 )*2.0
|
||||
V(2 )=V(4 )*2.0
|
||||
U(1 )=U(1 )+UDR
|
||||
U(2 )=U(2 )+UDI
|
||||
C WRITE(20,7777)'TERTIARY POTENTIALS'
|
||||
C WRITE(20,7777)'CENTRAL POTENTIAL'
|
||||
C WRITE(20,7778)(U(I),I=1,KT2)
|
||||
C WRITE(20,7777)'SPIN ORBIT POTENTIAL'
|
||||
C WRITE(20,7778)(V(I),I=1,KT2)
|
||||
C WRITE(20,7777)'UD - DARWIN TERM'
|
||||
C WRITE(20,7778)(UD(I),I=1,KT2)
|
||||
C 7777 FORMAT(A30)
|
||||
C 7778 FORMAT(' ',1P10E12.4)
|
||||
ENDIF
|
||||
C
|
||||
IF(IDIRAC.EQ.1) IDIRAC=0
|
||||
RETURN
|
||||
C
|
||||
9000 FORMAT(10F8.4)
|
||||
9100 FORMAT(5E16.7)
|
||||
9508 FORMAT(18X,9H NODES=,F9.4,9H L =,F9.4,9H 2*J =,F9.4
|
||||
1 ,9H 2*S =,F9.4,9H FISW =,F9.4)
|
||||
9509 FORMAT(A18,9H V RL =,F9.4,9H R0RL =,F9.4,9H A RL =,F9.4
|
||||
1 ,9H R RL =,F9.4,9H VSOR =,F9.4)
|
||||
9510 FORMAT(18X,9H V IM =,F9.4,9H R0IM =,F9.4,9H A IM =,F9.4
|
||||
1 ,9H R IM =,F9.4,9H VSOI =,F9.4,9H POWR =,F9.4)
|
||||
9512 FORMAT(18X,9H BETA1=,F9.4,9H LDFR1=,F9.4,9H BETA2=,F9.4
|
||||
1 ,9H LDFR2=,F9.4,9H BETA3=,F9.4,9H LDFR3=,F9.4)
|
||||
9515 FORMAT('0',20('*'),' WARNING, Mixing of Dirac and non-Dirac'
|
||||
1, ' potentials may be hazardous to your calculation'
|
||||
2, 20('*'))
|
||||
END
|
||||
137
dwuck4/culib8/SLATER.FOR
Normal file
137
dwuck4/culib8/SLATER.FOR
Normal file
|
|
@ -0,0 +1,137 @@
|
|||
|
||||
c***********************************************************************
|
||||
SUBROUTINE SLATR (KT,KMAX,DRF,VB,MINL,FMU,ICODE)
|
||||
c
|
||||
c computes the slater integrals for the microscopic inelastic cases.
|
||||
c***********************************************************************
|
||||
IMPLICIT REAL*8(A-H,O-Z)
|
||||
DIMENSION VB(800)
|
||||
C
|
||||
C YUKAWA SLATER EXPANSION
|
||||
C
|
||||
KM =KMAX
|
||||
R=0.0
|
||||
IF(ICODE.EQ.2) GO TO 101
|
||||
C
|
||||
C HANKEL FUNCTION*EXP(+FMU*R)
|
||||
C
|
||||
F1=1.0
|
||||
F2=EXP(-FMU*DRF)
|
||||
DO 100 M=1,KT
|
||||
R=R+DRF
|
||||
X=FMU*R
|
||||
F1=F1*F2
|
||||
AZ=(1.0-F1*F1)/(2.0*X)
|
||||
B2=1.0/X
|
||||
B1=B2*(1.0+B2)
|
||||
FL=-1.0
|
||||
DO 50 LL=1,MINL
|
||||
B3=FL*B2/X+B1
|
||||
B1=B2
|
||||
B2=B3
|
||||
FL=FL+2.0
|
||||
50 CONTINUE
|
||||
VB(M+KM )=B2
|
||||
C
|
||||
C BESSEL FUNCTION*EXP(-FMU*R)
|
||||
C
|
||||
MAX=2.0*X+10.0
|
||||
MAX=MAX0(MAX,MINL+5)
|
||||
A3=0.0
|
||||
A2=1.0
|
||||
FL=MAX+MAX+3
|
||||
DO 70 LL=1,MAX
|
||||
N=MAX+1-LL
|
||||
FL=FL-2.0
|
||||
A1=A3+FL*A2/X
|
||||
IF(N.LT.MINL) GO TO 69
|
||||
IF(ABS(A1).LT.1.0E+20) GO TO 69
|
||||
A1=A1*1.0E-20
|
||||
A2=A2*1.0E-20
|
||||
69 CONTINUE
|
||||
IF(N.EQ.MINL) TEMP=A1
|
||||
A3=A2
|
||||
A2=A1
|
||||
70 CONTINUE
|
||||
VB(M )=TEMP*AZ/A1
|
||||
100 CONTINUE
|
||||
RETURN
|
||||
C
|
||||
C COULOMB SLATER EXPANSION
|
||||
C
|
||||
101 CONTINUE
|
||||
FL=MINL+MINL-1
|
||||
DO 200 M=1,KT
|
||||
R=R+DRF
|
||||
A2=1.0
|
||||
DO 105 LL=1,MINL
|
||||
A2=A2*R
|
||||
105 CONTINUE
|
||||
VB(M )=A2/(R*FL)
|
||||
VB(M+KM )=1.0/A2
|
||||
200 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
CDWK407
|
||||
SUBROUTINE RADIN(KT,KMAX,DRF,FMU,VB,UB,UC,SL,OPT,SI,KMT,SK)
|
||||
IMPLICIT REAL*8(A-H,O-Z)
|
||||
DIMENSION UB(400),UC(400),VB(800),SI(800),DG(2)
|
||||
DATA XRHO/80./
|
||||
FLOAT(III)=DFLOAT(III)
|
||||
C
|
||||
KM =KMAX
|
||||
KM2=KMAX*2
|
||||
KM3=KMAX*3
|
||||
DG(1)=2.0*DRF/3.0
|
||||
DG(2)=2.0*DG(1)
|
||||
F0=EXP( FMU*DRF)
|
||||
MMAX=XRHO/FMU/DRF
|
||||
R2=0.0
|
||||
SUMA=0.0
|
||||
SUMB=0.0
|
||||
SUMC=0.0
|
||||
SUMD=0.0
|
||||
DO 200 M=1,KT
|
||||
MK=M+M-1
|
||||
R2=R2+DRF
|
||||
F2=EXP(-FLOAT(MIN0(MMAX,M)-1)*FMU*DRF)
|
||||
SLL=0.0
|
||||
MX=1
|
||||
R1=0.0
|
||||
DO 100 MM=1,KT
|
||||
R1=R1+DRF
|
||||
MX=3-MX
|
||||
IF(IABS(M-MM).GT.MMAX) GO TO 100
|
||||
F1=DG(MX)*UB(MM)*UC(MM)*R1**2
|
||||
IF(M.GT.MM) GO TO 80
|
||||
IF(M.EQ.MM) GO TO 90
|
||||
F2=F2/F0
|
||||
TEMP=VB(M)*VB(MM+KM3)*F2
|
||||
GO TO 95
|
||||
80 CONTINUE
|
||||
TEMP=VB(MM+KM2)*VB(M+KM )*F2
|
||||
F2=F2*F0
|
||||
GO TO 95
|
||||
90 TEMP=0.5*(VB(M)*VB(M+KM3)+VB(M+KM2)*VB(M+KM ))
|
||||
95 CONTINUE
|
||||
SLL=SLL+F1*TEMP
|
||||
100 CONTINUE
|
||||
SLL=SLL*OPT
|
||||
R22=R2**2
|
||||
IF(M.EQ.KMT) SK=SLL
|
||||
SI(MK)=SI(MK)+SLL
|
||||
SUMA=SUMA+UB(M)*UC(M)*R22
|
||||
SUMB=SUMB+UB(M)*UC(M)*R22**2
|
||||
SUMC=SUMC+SLL*R22
|
||||
SUMD=SUMD+SLL*R22**2
|
||||
200 CONTINUE
|
||||
SUMA=SUMA*DRF
|
||||
SUMB=SUMB*DRF
|
||||
SUMC=SUMC*DRF
|
||||
SUMD=SUMD*DRF
|
||||
SL=SUMC
|
||||
WRITE(6,9100)SUMA,SUMB,SUMC,SUMD
|
||||
RETURN
|
||||
9100 FORMAT(13H0 J0 =,F11.4,7H J1 =,F11.4,7H K0 =,F11.4
|
||||
1 ,7H K1 =,F11.4)
|
||||
END
|
||||
BIN
dwuck4/dw4_doc.pdf
Normal file
BIN
dwuck4/dw4_doc.pdf
Normal file
Binary file not shown.
Loading…
Reference in New Issue
Block a user