NLSL: anxlk.f90 Source File

NLSL

- Main Page
- Modules
- Data Types List
- Files

- File List
- File Members

anxlk.f90
Go to the documentation of this file.
1 c VERSION 1.3 (NLS version) 1/13/93
2 c**********************************************************************
3 c ====================
4 c subroutine ANXLK
5 c ====================
6 c
7 c This subroutine calculates the xlk coefficients for
8 c the potential-dependent part of the diffusion operator
9 c for use in the SLE matrix calculation (MATRL, MATRF).
10 c Array xlk (in /eprdat/) should be dimensioned to at least
11 c (5,5), so that it can accommodate even L,K values from 0
12 c to 8 (twice the highest possible L of a potential coefficient)
13 c
14 c Notes:
15 c The summation over the X(L,K)'s proceeds from 0 to 2*lptmx
16 c X(L,K) is nonzero only for even L,K
17 c X(L,K) = X(L,-K) [similar to potential coefficients]
18 c
19 c This code has been updated to include the possibility of a
20 c nonaxial diffusion tensor (Rx .ne. Ry .ne. Rz). It was
21 c developed from subroutine CALXLK by D.J. Schneider which was
22 c based on the original subroutine matr written by G.Moro.
23 c
24 c
25 c written by DEB 8-JUL-92
26 c
27 c Includes:
28 c rndoff.inc
29 c eprprm.inc
30 c
31 c Uses:
32 c w3j.f
33 c
34 c**********************************************************************
35 c
36 subroutine anxlk(rp,rm,rz)
37 c
38 use rnddbl
39 use eprprm
40 c
41 implicit none
42 double precision rp,rm,rz
43 c
44 integer k,kx,kptf,k1f,k1i,k1,k1abs,k1x,k2,k2abs,k2f,k2i,k2x,
45 # l,lx,l1,l1x,l2,l2x
46 double precision factl,wig1,rj2u,rjuju,term
47 c
48 double precision w3j
49 external w3j
50 c
51 c######################################################################
52 c
53 c
54 do lx=1,5
55 do kx=1,5
56 xlk(lx,kx)=0.0d0
57 end do
58 end do
59 c
60 c----------------------------------------------------------------------
61 c exit if no potential
62 c----------------------------------------------------------------------
63 c
64 if(ipt.eq.0) return
65 c
66 c---------------------------------------------------------------------
67 c calculate xlk coefficients
68 c----------------------------------------------------------------------
69 c
70 c --- loop over L
71 c
72 do 100 l=0,lptmx*2,2
73 lx=1+l/2
74 factl=dble(2*l+1)
75 kptf=min(l,2*kptmx+2)
76 c
77 c --- loop over K ---
78 c
79 do 90 k=0,kptf,2
80 kx=1+k/2
81 c
82 c------------------------------
83 c (J*R*J)U term
84 c------------------------------
85 c
86 rj2u=cpot(lx,kx)*( rp*dble(l*(l+1)-k*k) + rz*dble(k*k) )
87 if (k+2.le.l .and. k+2.le.kptmx) rj2u=rj2u+rm*cpot(lx,kx+1)
88 # * dsqrt(dble((l+k+1)*(l+k+2)*(l-k-1)*(l-k) ) )
89 if (k-2.ge.0) rj2u=rj2u+rm*cpot(lx,kx-1)
90 # * dsqrt(dble((l-k+1)*(l-k+2)*(l+k-1)*(l+k) ) )
91 if (k-2.lt.0) rj2u=rj2u+rm*cpot(lx,kx+1)
92 # * dsqrt(dble((l-k+1)*(l-k+2)*(l+k-1)*(l+k) ) )
93 xlk(lx,kx)=-0.5d0*rj2u
94 c
95 c------------------------------
96 c (JU)*R*(JU) term
97 c------------------------------
98 c
99 rjuju = 0.0d0
100 c
101 c --- loop over L1
102 c
103 do 80 l1=0,lptmx,2
104 l1x=1+l1/2
105 k1f=min(l1,kptmx)
106 k1i=-k1f
107 c
108 c --- loop over L2
109 c
110 do 70 l2=0,lptmx,2
111 l2x=1+l2/2
112 if(l1+l2.ge.l) then
113 wig1=w3j(l1,l,l2,0,0,0)
114 else
115 wig1=0.0d0
116 go to 70
117 end if
118 c
119 c --- loop over K1
120 c
121 do 60 k1=k1i,k1f,2
122 k1abs=abs(k1)
123 k1x=1+k1abs/2
124 c
125 c ---- loop over K2
126 c
127 k2i=max(k-k1-2,-kptmx,-l2)
128 k2f=min(k-k1+2,kptmx,l2)
129 c
130 do 50 k2=k2i,k2f,2
131 k2abs=abs(k2)
132 k2x=1+k2abs/2
133 c
134 c ------- (J_+ U)(J_+ U) term
135 c
136 if( (k2.eq.k-k1-2) .and. (abs(k1+1).le.l1)
137 # .and.(abs(k2+1).le.l2) ) then
138 term=rm*w3j(l1,l,l2,k1+1,-k,k2+1)* dsqrt(
139 # dble((l1-k1)*(l1+k1+1)*(l2-k2)*(l2+k2+1)) )
140 c
141 c ------- (J_- U)(J_- U) term
142 c
143 else if ( (k2.eq.k-k1+2) .and. (abs(k1-1).le.l1)
144 # .and. (abs(k2-1).le.l2) ) then
145 term=rm*w3j(l1,l,l2,k1-1,-k,k2-1)* dsqrt(
146 # dble((l1+k1)*(l1-k1+1)*(l2+k2)*(l2-k2+1)) )
147 c
148 c ------- (J_+ U)(J_- U) term
149 c
150 else if (k2.eq.k-k1) then
151 if((abs(k1+1).le.l1).and.(abs(k2-1).le.l2)) then
152 term=rp*w3j(l1,l,l2,k1+1,-k,k2-1)*
153 # dsqrt(dble((l1-k1)*(l1+k1+1)*(l2+k2)*(l2-k2+1)))
154 else
155 term=0.0d0
156 end if
157 c
158 c ------ (Jz U)(Jz U) term
159 c
160 if (k2abs.le.l2)
161 # term=term+rz*dble(k1*k2)*w3j(l1,l,l2,k1,-k,k2)
162 c
163 else
164 term=0.0d0
165 end if
166 c
167 rjuju=rjuju+cpot(l1x,k1x)*cpot(l2x,k2x)*wig1*term
168 c
169 50 continue
170 60 continue
171 70 continue
172 80 continue
173 xlk(lx,kx)=xlk(lx,kx)-0.25d0*factl*rjuju
174 90 continue
175 100 continue
176 c
177 do 120 lx=1,5
178 do 110 kx=1,5
179 if (abs(xlk(lx,kx)).lt.rndoff) xlk(lx,kx)=0.0d0
180 110 continue
181 120 continue
182 c
183 return
184 end
eprprm::ipt
integer, save ipt
Definition: eprprm.f90:82
eprprm::cpot
double precision, dimension(5, 5), save cpot
Definition: eprprm.f90:78
anxlk
subroutine anxlk(rp, rm, rz)
Definition: anxlk.f90:37
eprprm::lptmx
integer, save lptmx
Definition: eprprm.f90:82
eprprm::kptmx
integer, save kptmx
Definition: eprprm.f90:82
eprprm::xlk
double precision, dimension(5, 5), save xlk
Definition: eprprm.f90:78
rnddbl
Definition: rnddbl.f90:77
eprprm
Definition: eprprm.f90:51
rnddbl::rndoff
double precision, parameter rndoff
Definition: rnddbl.f90:86