NLSL: pstvec.f90 Source File

NLSL

- Main Page
- Modules
- Data Types List
- Files

- File List
- File Members

pstvec.f90
Go to the documentation of this file.
1 c NLSL Version 1.4 10/10/94
2 c**********************************************************************
3 c =========================
4 c subroutine PSTVEC
5 c =========================
6 c *** Pruning version ***
7 c
8 c Calculates the starting vector for EPRLL
9 c
10 c This differs from the standalone version in the addition of
11 c the parameter ierr. It is used to report non-convergence of
12 c Bessel function evaluations instead of halting when such
13 c errors occur.
14 c
15 c Notes:
16 c 1) The orientational integral is evaluated numerically
17 c using the Curtis-Clenshaw-Romberg algorithm.
18 c For details, see Bruno's thesis, p. 554.
19 c
20 c written by DJS 10-SEP-87
21 c
22 c NB: Modified so that nelv is kept in common eprdat instead of
23 c passed as a subroutine argument. DEB 22-OCT-91
24 c
25 c Uses:
26 c ipar.f
27 c ccrint.f
28 c
29 c**********************************************************************
30 c
31 subroutine pstvec(bss,v,ierr)
32 c
33 use nlsdim
34 use eprprm
35 use errmsg
36 use rnddbl
37 c
38 implicit none
39 integer lr,kr,iberr
40 common /ifzdat/lr,kr,iberr
41 c
42 integer bss(5,mxdim),ierr
43 double precision v(2,mxdim)
44 c
45 integer i,id,ioldlr,ioldkr,ioldmr,ioldpnr,iparlr,ipnr,ipnrsg,
46 # iqnr,jkr,jmr,krsgn,mr,mrsgn,nrow,nup
47 double precision cnl,stv,stvlk,stvm,factor,dsq2,vnorm
48 logical evenl,evenk,newlr,newkr,newmr,newpnr
49 c
50 double precision ACCRCY,SMALL
51 parameter(accrcy=1.0d-8,small=1.0d-10)
52 c
53 double precision ONE,ZERO
54 parameter(one=1.0d0,zero=0.0d0)
55 c
56 integer ipar
57 double precision fz
58 external fz,ipar
59 c
60 c######################################################################
61 c
62 c.... Debugging purposes only!
63 c open (unit=20,file='nlpvec.tst',status='unknown',
64 c # access='sequential',form='formatted')
65 c............................
66 c
67 dsq2=sqrt(2.0d0)
68 c
69 nrow=0
70 nelv=0
71 vnorm=zero
72 c
73 c----------------------------------------------------------------------
74 c *** loop over rows ***
75 c----------------------------------------------------------------------
76 c
77 ioldlr=-1
78 ioldkr=kmn-1
79 ioldmr=mmn-1
80 ioldpnr=-in2-1
81 c
82 do 100 nrow=1,ndim
83 lr=bss(1,nrow)
84 krsgn=bss(2,nrow)
85 mrsgn=bss(3,nrow)
86 ipnrsg=bss(4,nrow)
87 iqnr=bss(5,nrow)
88 c
89 newlr=lr.ne.ioldlr
90 newkr=newlr.or.(krsgn.ne.ioldkr)
91 newmr=newkr.or.(mrsgn.ne.ioldmr)
92 newpnr=newmr.or.(ipnrsg.ne.ioldpnr)
93 c
94 if(newlr) then
95 ioldlr=lr
96 iparlr=ipar(lr)
97 if (iparlr.eq.1) then
98 evenl=.true.
99 cnl=dsqrt(dble(2*lr+1))
100 else
101 evenl=.false.
102 cnl=zero
103 end if
104 end if
105 c
106 if (newkr) then
107 ioldkr=krsgn
108 kr=abs(krsgn)
109 jkr=isign(1,krsgn)
110 if (krsgn.eq.0) jkr=iparlr
111 evenk=ipar(kr).eq.1
112 c
113 if (evenl.and.evenk) then
114 c
115 c --- No potential: Only elements are for L,K=0
116 c
117 if(lptmx.eq.0) then
118 if((lr.eq.0).and.(kr.eq.0)) then
119 stvlk=one
120 else
121 stvlk=zero
122 end if
123 c
124 c --- Axial potential: Only elements are for K=0
125 c
126 else if((kptmx.eq.0).and.(kr.ne.0)) then
127 stvlk=zero
128 c
129 c --- Integration to find vector element
130 c
131 else
132 call ccrint(zero,one,accrcy,small,stvlk,nup,fz,id)
133 if (iberr.ne.0) ierr=badbess
134 if(kr.ne.0) then
135 factor=one
136 do 500 i=lr-kr+1,lr+kr
137 factor=factor*dble(i)
138 500 continue
139 factor=one/dsqrt(factor)
140 else
141 factor=one/dsq2
142 end if
143 stvlk=factor*stvlk*cnl
144 end if
145 else
146 stvlk=zero
147 end if
148 end if
149 c
150 if (newmr) then
151 ioldmr=mrsgn
152 mr=abs(mrsgn)
153 jmr=isign(1,mrsgn)
154 if (mrsgn.eq.0) jmr=0
155 c
156 if (mr.ne.0) then
157 stvm=zero
158 else
159 stvm=stvlk
160 end if
161 end if
162 c
163 if (newpnr) then
164 ioldpnr=ipnrsg
165 if (mr.eq.0) then
166 ipnr=abs(ipnrsg)
167 jmr=isign(1,ipnrsg)
168 if (ipnr.eq.0) jmr=iparlr
169 else
170 ipnr=ipnrsg
171 end if
172 c
173 if (ipnr.ne.0.or.jmr.ne.1 .or.jkr.ne.1) then
174 stv=zero
175 else
176 stv=stvm
177 end if
178 end if
179 c
180 v(1,nrow)=stv
181 vnorm=vnorm+stv*stv
182 c
183 c.................... Debugging purposes only!
184 c if (abs(v(1,nrow)).gt.RNDOFF) then
185 c write(20,7000) lr,krsgn,mrsgn,ipnrsg,iqnr,v(1,nrow)
186 c 7000 format('Re <v|',4(i3,','),i3,'> = ',2g14.7)
187 c end if
188 c.............................................
189 c
190 100 continue
191 c
192 c----------------------------------------------------------------------
193 c normalize starting vector and zero out imaginary part
194 c----------------------------------------------------------------------
195 c
196 nelv=0
197 vnorm=one/dsqrt(vnorm)
198 do i=1,ndim
199 v(1,i)=v(1,i)*vnorm
200 if(abs(v(1,i)).gt.rndoff) then
201 nelv=nelv+1
202 else
203 v(1,i)=zero
204 end if
205 v(2,i)=zero
206 end do
207 c
208 c----------------------------------------------------------------------
209 c zero out remainder of vector
210 c----------------------------------------------------------------------
211 c
212 do i=ndim+1,mxdim
213 v(1,i)=zero
214 v(2,i)=zero
215 end do
216 c
217 c..........Debugging purposes only!
218 c close(20)
219 c...................................
220 c
221 return
222 end
eprprm::ndim
integer, pointer, save ndim
Definition: eprprm.f90:69
errmsg::badbess
integer, parameter badbess
Definition: errmsg.f90:51
eprprm::lptmx
integer, save lptmx
Definition: eprprm.f90:82
eprprm::mmn
integer, pointer, save mmn
Definition: eprprm.f90:69
eprprm::nelv
integer, save nelv
Definition: eprprm.f90:82
eprprm::kptmx
integer, save kptmx
Definition: eprprm.f90:82
pstvec
subroutine pstvec(bss, v, ierr)
Definition: pstvec.f90:32
ccrint
subroutine ccrint(bndlow, bndhi, epsiln, small, sum, neval, f, id)
Definition: ccrints.f90:32
eprprm::kmn
integer, pointer, save kmn
Definition: eprprm.f90:69
eprprm::in2
integer, pointer, save in2
Definition: eprprm.f90:69
rnddbl
Definition: rnddbl.f90:77
eprprm
Definition: eprprm.f90:51
nlsdim
Definition: nlsdim.f90:36
nlsdim::mxdim
integer, parameter mxdim
Definition: nlsdim.f90:39
rnddbl::rndoff
double precision, parameter rndoff
Definition: rnddbl.f90:86
errmsg
Definition: errmsg.f90:46