LCPQ/qp2
9
1
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-12-22 19:43:32 +01:00
Code Releases Activity

Removed labels in loc.f

Browse Source
This commit is contained in:
Anthony Scemama 2022-11-19 16:16:04 +01:00
parent 8245c7b3f7
commit 2798183c6d
2 changed files with 163 additions and 142 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
src/ao_one_e_ints/pseudopot.f90
View File

@ -1095,9 +1095,9 @@ double precision function overlap_orb_ylm_grid(nptsgrid,r_orb,npower_orb,center_
implicit none implicit none
!! PSEUDOS !! PSEUDOS
integer nptsgridmax,nptsgrid integer nptsgridmax,nptsgrid
double precision coefs_pseudo,ptsgrid
parameter(nptsgridmax=50) parameter(nptsgridmax=50)
common/pseudos/coefs_pseudo(nptsgridmax),ptsgrid(nptsgridmax,3) double precision coefs_pseudo(nptsgridmax),ptsgrid(nptsgridmax,3)
common/pseudos/coefs_pseudo,ptsgrid
!!!!! !!!!!
integer npower_orb(3),l,m,i integer npower_orb(3),l,m,i
double precision x,g_orb,two_pi,dx,dphi,term,orb_phi,ylm_real,sintheta,r_orb,phi,center_orb(3) double precision x,g_orb,two_pi,dx,dphi,term,orb_phi,ylm_real,sintheta,r_orb,phi,center_orb(3)
@ -1235,10 +1235,10 @@ end
subroutine initpseudos(nptsgrid) subroutine initpseudos(nptsgrid)
implicit none implicit none
integer nptsgridmax,nptsgrid,ik integer nptsgridmax,nptsgrid,ik
double precision coefs_pseudo,ptsgrid
double precision p,q,r,s double precision p,q,r,s
parameter(nptsgridmax=50) parameter(nptsgridmax=50)
common/pseudos/coefs_pseudo(nptsgridmax),ptsgrid(nptsgridmax,3) double precision :: coefs_pseudo(nptsgridmax),ptsgrid(nptsgridmax,3)
common/pseudos/coefs_pseudo,ptsgrid
p=1.d0/dsqrt(2.d0) p=1.d0/dsqrt(2.d0)
q=1.d0/dsqrt(3.d0) q=1.d0/dsqrt(3.d0)

153
src/utils/loc.f
View File

@ -29,23 +29,26 @@ C conv=1.d-6
* 5x,'following the principle of maximum overlap with a set of', * 5x,'following the principle of maximum overlap with a set of',
* i3,' reference vectors'/5x,'required convergence on rotation ', * i3,' reference vectors'/5x,'required convergence on rotation ',
* 'angle =',f13.10///5x,'Starting overlap matrix'/) * 'angle =',f13.10///5x,'Starting overlap matrix'/)
do 6 i=1,m do i=1,m
write (6,145) i write (6,145) i
6 write (6,150) (s(i,j),j=1,n) write (6,150) (s(i,j),j=1,n)
end do
8 mm=m-1 8 mm=m-1
if (m.lt.n) mm=m if (m.lt.n) mm=m
iter=0 iter=0
do 20 j=1,n do j=1,n
do 16 i=1,n do i=1,n
t(i,j)=0.d0 t(i,j)=0.d0
16 continue end do
do 18 i=1,m do i=1,m
18 w(i,j)=s(i,j) w(i,j)=s(i,j)
20 t(j,j)=1.d0 enddo
t(j,j)=1.d0
enddo
sum=0.d0 sum=0.d0
do 10 i=1,m do i=1,m
sum=sum+s(i,i)*s(i,i) sum=sum+s(i,i)*s(i,i)
10 continue end do
sum=sum/m sum=sum/m
if (zprt) write (6,12) sum if (zprt) write (6,12) sum
12 format (//5x,'Average square overlap =',f10.6) 12 format (//5x,'Average square overlap =',f10.6)
@ -54,18 +57,18 @@ C conv=1.d-6
j=1 j=1
21 if (j.ge.last) goto 30 21 if (j.ge.last) goto 30
sum=0.d0 sum=0.d0
do i=1,n
do 22 i=1,n sum=sum+s(i,j)*s(i,j)
22 sum=sum+s(i,j)*s(i,j) enddo
if (sum.gt.small) goto 28 if (sum.gt.small) goto 28
do 24 i=1,n do i=1,n
sij=s(i,j) sij=s(i,j)
s(i,j)=-s(i,last) s(i,j)=-s(i,last)
s(i,last)=sij s(i,last)=sij
tij=t(i,j) tij=t(i,j)
t(i,j)=-t(i,last) t(i,j)=-t(i,last)
t(i,last)=tij t(i,last)=tij
24 continue end do
last=last-1 last=last-1
goto 21 goto 21
28 j=j+1 28 j=j+1
@ -101,17 +104,18 @@ C conv=1.d-6
sine=1.d0 sine=1.d0
34 delta=sine*(a*sine+b*cosine) 34 delta=sine*(a*sine+b*cosine)
if (zprt.and.delta.lt.0.d0) write (6,71) i,j,a,b,sine,cosine,delta if (zprt.and.delta.lt.0.d0) write (6,71) i,j,a,b,sine,cosine,delta
do 35 k=1,m do k=1,m
p=s(k,i)*cosine-s(k,j)*sine p=s(k,i)*cosine-s(k,j)*sine
q=s(k,i)*sine+s(k,j)*cosine q=s(k,i)*sine+s(k,j)*cosine
s(k,i)=p s(k,i)=p
35 s(k,j)=q s(k,j)=q
do 40 k=1,n enddo
do k=1,n
p=t(k,i)*cosine-t(k,j)*sine p=t(k,i)*cosine-t(k,j)*sine
q=t(k,i)*sine+t(k,j)*cosine q=t(k,i)*sine+t(k,j)*cosine
t(k,i)=p t(k,i)=p
t(k,j)=q t(k,j)=q
40 continue enddo
45 d=dabs(sine) 45 d=dabs(sine)
if (d.le.amax) goto 50 if (d.le.amax) goto 50
imax=i imax=i
@ -132,36 +136,43 @@ C conv=1.d-6
* 'in subroutine maxovl ***'//) * 'in subroutine maxovl ***'//)
stop stop
100 continue 100 continue
do 120 j=1,n do j=1,n
if (s(j,j).gt.0.d0) goto 120 if (s(j,j).gt.0.d0) cycle
do 105 i=1,m do i=1,m
105 s(i,j)=-s(i,j) s(i,j)=-s(i,j)
do 110 i=1,n enddo
110 t(i,j)=-t(i,j) do i=1,n
120 continue t(i,j)=-t(i,j)
enddo
enddo
sum=0.d0 sum=0.d0
do 125 i=1,m do i=1,m
125 sum=sum+s(i,i)*s(i,i) sum=sum+s(i,i)*s(i,i)
enddo
sum=sum/m sum=sum/m
do 122 i=1,m do i=1,m
do 122 j=1,n do j=1,n
sw=s(i,j) sw=s(i,j)
s(i,j)=w(i,j) s(i,j)=w(i,j)
122 w(i,j)=sw w(i,j)=sw
enddo
enddo
if (.not.zprt) return if (.not.zprt) return
write (6,12) sum write (6,12) sum
write (6,130) write (6,130)
130 format (//5x,'transformation matrix') 130 format (//5x,'transformation matrix')
do 140 i=1,n do i=1,n
write (6,145) i write (6,145) i
140 write (6,150) (t(i,j),j=1,n) write (6,150) (t(i,j),j=1,n)
enddo
145 format (i8) 145 format (i8)
150 format (2x,10f12.8) 150 format (2x,10f12.8)
write (6,160) write (6,160)
160 format (//5x,'new overlap matrix'/) 160 format (//5x,'new overlap matrix'/)
do 170 i=1,m do i=1,m
write (6,145) i write (6,145) i
170 write (6,150) (w(i,j),j=1,n) write (6,150) (w(i,j),j=1,n)
enddo
return return
end end
@ -193,17 +204,19 @@ C conv=1.d-6
8 mm=m-1 8 mm=m-1
if (m.lt.n) mm=m if (m.lt.n) mm=m
iter=0 iter=0
do 20 j=1,n do j=1,n
do 16 i=1,n do i=1,n
t(i,j)=0.d0 t(i,j)=0.d0
16 continue enddo
do 18 i=1,m do i=1,m
18 w(i,j)=s(i,j) w(i,j)=s(i,j)
20 t(j,j)=1.d0 enddo
t(j,j)=1.d0
enddo
sum=0.d0 sum=0.d0
do 10 i=1,m do i=1,m
sum=sum+s(i,i)*s(i,i) sum=sum+s(i,i)*s(i,i)
10 continue enddo
sum=sum/m sum=sum/m
12 format (//5x,'Average square overlap =',f10.6) 12 format (//5x,'Average square overlap =',f10.6)
if (n.eq.1) goto 100 if (n.eq.1) goto 100
@ -212,17 +225,18 @@ C conv=1.d-6
21 if (j.ge.last) goto 30 21 if (j.ge.last) goto 30
sum=0.d0 sum=0.d0
do 22 i=1,n do i=1,n
22 sum=sum+s(i,j)*s(i,j) sum=sum+s(i,j)*s(i,j)
enddo
if (sum.gt.small) goto 28 if (sum.gt.small) goto 28
do 24 i=1,n do i=1,n
sij=s(i,j) sij=s(i,j)
s(i,j)=-s(i,last) s(i,j)=-s(i,last)
s(i,last)=sij s(i,last)=sij
tij=t(i,j) tij=t(i,j)
t(i,j)=-t(i,last) t(i,j)=-t(i,last)
t(i,last)=tij t(i,last)=tij
24 continue end do
last=last-1 last=last-1
goto 21 goto 21
28 j=j+1 28 j=j+1
@ -232,9 +246,9 @@ C conv=1.d-6
jmax=0 jmax=0
dmax=0.d0 dmax=0.d0
amax=0.d0 amax=0.d0
do 60 i=1,mm do i=1,mm
ip=i+1 ip=i+1
do 50 j=ip,n do j=ip,n
a=s(i,j)*s(i,j)-s(i,i)*s(i,i) a=s(i,j)*s(i,j)-s(i,i)*s(i,i)
b=-s(i,i)*s(i,j) b=-s(i,i)*s(i,j)
if (j.gt.m) goto 31 if (j.gt.m) goto 31
@ -257,17 +271,18 @@ C conv=1.d-6
33 cosine=0.d0 33 cosine=0.d0
sine=1.d0 sine=1.d0
34 delta=sine*(a*sine+b*cosine) 34 delta=sine*(a*sine+b*cosine)
do 35 k=1,m do k=1,m
p=s(k,i)*cosine-s(k,j)*sine p=s(k,i)*cosine-s(k,j)*sine
q=s(k,i)*sine+s(k,j)*cosine q=s(k,i)*sine+s(k,j)*cosine
s(k,i)=p s(k,i)=p
35 s(k,j)=q s(k,j)=q
do 40 k=1,n enddo
do k=1,n
p=t(k,i)*cosine-t(k,j)*sine p=t(k,i)*cosine-t(k,j)*sine
q=t(k,i)*sine+t(k,j)*cosine q=t(k,i)*sine+t(k,j)*cosine
t(k,i)=p t(k,i)=p
t(k,j)=q t(k,j)=q
40 continue enddo
45 d=dabs(sine) 45 d=dabs(sine)
if (d.le.amax) goto 50 if (d.le.amax) goto 50
imax=i imax=i
@ -275,7 +290,8 @@ C conv=1.d-6
amax=d amax=d
dmax=delta dmax=delta
50 continue 50 continue
60 continue end do
end do
70 format (' iter=',i4,' largest rotation=',f12.8, 70 format (' iter=',i4,' largest rotation=',f12.8,
* ', vectors',i3,' and',i3,', incr. of diag. squares=',g12.5) * ', vectors',i3,' and',i3,', incr. of diag. squares=',g12.5)
71 format (' i,j,a,b,sin,cos,delta =',2i3,5f10.5) 71 format (' i,j,a,b,sin,cos,delta =',2i3,5f10.5)
@ -285,22 +301,27 @@ C conv=1.d-6
* 'in subroutine maxovl ***'//) * 'in subroutine maxovl ***'//)
stop stop
100 continue 100 continue
do 120 j=1,n do j=1,n
if (s(j,j).gt.0.d0) goto 120 if (s(j,j).gt.0.d0) cycle
do 105 i=1,m do i=1,m
105 s(i,j)=-s(i,j) s(i,j)=-s(i,j)
do 110 i=1,n enddo
110 t(i,j)=-t(i,j) do i=1,n
120 continue t(i,j)=-t(i,j)
enddo
enddo
sum=0.d0 sum=0.d0
do 125 i=1,m do i=1,m
125 sum=sum+s(i,i)*s(i,i) sum=sum+s(i,i)*s(i,i)
enddo
sum=sum/m sum=sum/m
do 122 i=1,m do i=1,m
do 122 j=1,n do j=1,n
sw=s(i,j) sw=s(i,j)
s(i,j)=w(i,j) s(i,j)=w(i,j)
122 w(i,j)=sw w(i,j)=sw
enddo
enddo
return return
end end