lukasplevac/easyconfigs-it4i
1
0
Fork 0
mirror of https://code.it4i.cz/sccs/easyconfigs-it4i.git synced 2025-04-17 04:00:49 +01:00
Code Issues Packages Projects Releases Wiki Activity
easyconfigs-it4i/m/MRCC/mrcc_files/calcorbd.f
Lukas Krupcik eb1ea94130 merge master
2024-07-25 10:27:17 +02:00

935 lines
36 KiB
Fortran
Executable File
Raw Blame History

************************************************************************
subroutine calcorbd(ngrid,grid,natoms,nangmax,ncontrmax,nprimmax,
$ncartmax,nsphermax,nang,ncontr,nprim,gexp,gcoef,coord,ctostr,
$cartg,dvec,nbasis,gexp2,ibasis,nangmin,gcn,itol,lpre,bfmap,
$iatrange)
************************************************************************
* Calculate orbital values and gradients on grid
************************************************************************
implicit none
integer ngrid,natoms,nangmax,ncontrmax,nprimmax,ncartmax,nsphermax
integer nang(natoms),ncontr(0:nangmax,natoms),iatoms,igrid,jbasis
integer nprim(0:nangmax,natoms),nicontr,niprim,nicart,nispher,iang
integer nangmin(natoms),gcn(2,ncontrmax,0:nangmax,natoms),i,j,ii
integer nbasis,ibasis,iprim,bfmap(nbasis),iatrange(2,natoms)
integer icontr
real*8 grid(3,ngrid),gexp(nprimmax,0:nangmax,natoms),r2,itol,cmax
real*8 gcoef(nprimmax,ncontrmax,0:nangmax,natoms)
real*8 coord(3,natoms),ctostr(ncartmax**2,0:nangmax),rmin,rmax
real*8 x,y,z,ax,ay,az,gexp2(nprimmax),dvec(ngrid*4,nbasis),amin,a
logical cartg,lat,lpre
C Loop over atoms
ibasis=0
jbasis=0
do iatoms=1,natoms
if(lpre) iatrange(1,iatoms)=ibasis
x=coord(1,iatoms)
y=coord(2,iatoms)
z=coord(3,iatoms)
C Prescreening
rmin=1d30
rmax=1.d0
C$OMP PARALLEL DO Schedule(Static)
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(igrid,ax,ay,az,r2)
C$OMP& REDUCTION(min:rmin)
C$OMP& REDUCTION(max:rmax)
do igrid=1,ngrid
ax=grid(1,igrid)-x
ay=grid(2,igrid)-y
az=grid(3,igrid)-z
r2=ax*ax+ay*ay+az*az
rmin=min(rmin,r2)
rmax=max(rmax,r2)
enddo
C$OMP END PARALLEL DO
rmin=dsqrt(rmin)
rmax=dsqrt(rmax)
C Loop over angular momenta
do iang=nangmin(iatoms),nang(iatoms)
nicontr=ncontr(iang,iatoms)
niprim=nprim(iang,iatoms)
nicart=(iang+1)*(iang+2)/2
nispher=2*iang+1
if(cartg) nispher=nicart
amin=1d30
cmax=0.d0
do iprim=1,niprim
a=gexp(iprim,iang,iatoms)
amin=min(amin,a)
gexp2(iprim)=-2.d0*a
do icontr=1,nicontr
cmax=max(cmax,dabs(gcoef(iprim,icontr,iang,iatoms)))
enddo
enddo
cmax=dble(niprim)*cmax
if(cmax*rmax**(iang+1)*dexp(-amin*rmin*rmin).ge.itol) then
if(iang.gt.5.or.cartg) then
call calco1_gn(ngrid,grid,x,y,z,niprim,nicontr,nispher,
$nicart,nprimmax,gcoef(1,1,iang,iatoms),ctostr(1,iang),gexp2,iang,
$gcn(1,1,iang,iatoms),dvec(1,ibasis+1),nbasis)
else if(iang.eq.0) then
call calco1_s(ngrid,grid,x,y,z,niprim,nicontr,
$nprimmax,gcoef(1,1,iang,iatoms),gexp2,
$gcn(1,1,iang,iatoms),dvec(1,ibasis+1),nbasis)
else if(iang.eq.1) then
call calco1_p(ngrid,grid,x,y,z,niprim,nicontr,
$nprimmax,gcoef(1,1,iang,iatoms),gexp2,
$gcn(1,1,iang,iatoms),dvec(1,ibasis+1),nbasis)
else if(iang.eq.2) then
call calco1_d(ngrid,grid,x,y,z,niprim,nicontr,
$nprimmax,gcoef(1,1,iang,iatoms),gexp2,
$gcn(1,1,iang,iatoms),dvec(1,ibasis+1),nbasis)
else if(iang.eq.3) then
call calco1_f(ngrid,grid,x,y,z,niprim,nicontr,
$nprimmax,gcoef(1,1,iang,iatoms),gexp2,
$gcn(1,1,iang,iatoms),dvec(1,ibasis+1),nbasis)
else if(iang.eq.4) then
call calco1_g(ngrid,grid,x,y,z,niprim,nicontr,
$nprimmax,gcoef(1,1,iang,iatoms),gexp2,
$gcn(1,1,iang,iatoms),dvec(1,ibasis+1),nbasis)
else if(iang.eq.5) then
call calco1_h(ngrid,grid,x,y,z,niprim,nicontr,
$nprimmax,gcoef(1,1,iang,iatoms),gexp2,
$gcn(1,1,iang,iatoms),dvec(1,ibasis+1),nbasis)
endif
if(lpre) then
ii=0
do i=ibasis+1,ibasis+nispher*nicontr
jbasis=jbasis+1
lat=.false.
do j=1,ngrid*4
if(dabs(dvec(j,i)).ge.itol) then
lat=.true.
exit
endif
enddo
if(lat) then
ii=ii+1
bfmap(ibasis+ii)=jbasis
if(ibasis+ii.ne.i)
$ dvec(1:ngrid*4,ibasis+ii)=dvec(1:ngrid*4,i)
endif
enddo
ibasis=ibasis+ii
else
ibasis=ibasis+nispher*nicontr
endif
else
if(lpre) then
jbasis=jbasis+nispher*nicontr
else
ibasis=ibasis+nispher*nicontr
endif
endif
enddo
if(lpre) iatrange(2,iatoms)=ibasis
enddo
C
return
end
C
************************************************************************
subroutine calco1_gn(ngrid,grid,x,y,z,niprim,nicontr,nispher,
$nicart,nprimmax,gcoef,ctostr,gexp2,iang,gcn,dvec,nbasis)
************************************************************************
* Calculate orbital values and gradients on grid, general shell
************************************************************************
implicit none
integer ngrid,igrid,ii,iprim,niprim,i,j,k,iang,nicontr,nispher
integer nicart,nprimmax,icart,gcn(2,*),icontr,j1,j2,ispher
integer nbasis
real*8 grid(3,ngrid),ax,ay,az,r2,x,y,z,a,gexp2(niprim),ex,exa
real*8 gcoef(nprimmax,*),ctostr(nispher,nicart),inta(nicart,4)
real*8 intr(niprim,4),ints(nispher,4),inti(4)
real*8 dvec(ngrid,4,nbasis),axy,axz,ayz,ax2,ay2,az2,exa2
C Loop over grid points
C$OMP PARALLEL DO
C$OMP& DEFAULT(PRIVATE)
C$OMP& SHARED(ngrid,grid,x,y,z,niprim,gexp2,iang,gcn,ctostr,gcoef,dvec)
C$OMP& SHARED(nicontr,nispher)
do igrid=1,ngrid
ax=grid(1,igrid)-x
ay=grid(2,igrid)-y
az=grid(3,igrid)-z
ax2=ax*ax
ay2=ay*ay
az2=az*az
r2=0.5d0*(ax2+ay2+az2)
do iprim=1,niprim
a=gexp2(iprim)
ex=dexp(a*r2)
exa=ex*a
intr(iprim, 1)=ex
intr(iprim, 2)=exa*ax
intr(iprim, 3)=exa*ay
intr(iprim, 4)=exa*az
enddo
icart=0
do i=0,iang
do j=0,iang-i
k=iang-i-j
icart=icart+1
inta(icart, 1)=ax**i*ay**j*az**k
inta(icart, 2)=i*ax**max(0,(i-1))*ay**j*az**k
inta(icart, 3)=ax**i*j*ay**max(0,(j-1))*az**k
inta(icart, 4)=ax**i*ay**j*k*az**max(0,(k-1))
enddo
enddo
ints=matmul(ctostr,inta)
ii=0
do icontr=1,nicontr
j1=gcn(1,icontr)
j2=gcn(2,icontr)
inti(1:4)=matmul(gcoef(j1:j2,icontr),intr(j1:j2,1:4))
do ispher=1,nispher
ii=ii+1
dvec(igrid, 1,ii)=ints(ispher, 1)*inti( 1)
dvec(igrid, 2,ii)=ints(ispher, 2)*inti( 1)+
$ ints(ispher, 1)*inti( 2)
dvec(igrid, 3,ii)=ints(ispher, 3)*inti( 1)+
$ ints(ispher, 1)*inti( 3)
dvec(igrid, 4,ii)=ints(ispher, 4)*inti( 1)+
$ ints(ispher, 1)*inti( 4)
enddo
enddo
enddo
C$OMP END PARALLEL DO
C
return
end
C
************************************************************************
subroutine calco1_s(ngrid,grid,x,y,z,niprim,nicontr,
$nprimmax,gcoef,gexp2,gcn,dvec,nbasis)
************************************************************************
* Calculate orbital values and gradients on grid
************************************************************************
implicit none
integer ngrid,igrid,ii,iprim,niprim,i,j,k,nicontr
integer nprimmax,gcn(2,*),icontr,j1,j2,ispher,nbasis
real*8 grid(3,ngrid),x,y,z,a,gexp2(niprim)
real*8 gcoef(nprimmax,*),dvec(ngrid,4,nbasis),ex,exa,exa2
real*8 intr(niprim,4),inti(4)
real*8 r2,a001,a002,a010,a011,a020,a100,a101,a110,a200
C$OMP PARALLEL DO
C$OMP& DEFAULT(PRIVATE)
C$OMP& SHARED(ngrid,grid,x,y,z,niprim,gexp2,gcn,gcoef,dvec,nicontr)
do igrid=1,ngrid
a100=grid(1,igrid)-x
a010=grid(2,igrid)-y
a001=grid(3,igrid)-z
a002=a001*a001
a020=a010*a010
a200=a100*a100
r2=0.5d0*(a200+a020+a002)
do iprim=1,niprim
a=gexp2(iprim)
ex=dexp(a*r2)
exa=ex*a
intr(iprim, 1)=ex
intr(iprim, 2)=exa*a100
intr(iprim, 3)=exa*a010
intr(iprim, 4)=exa*a001
enddo
do icontr=1,nicontr
j1=gcn(1,icontr)
j2=gcn(2,icontr)
dvec(igrid,1:4,icontr)=
$matmul(gcoef(j1:j2,icontr),intr(j1:j2,1:4))
enddo
enddo
C$OMP END PARALLEL DO
C
return
end
C
************************************************************************
subroutine calco1_p(ngrid,grid,x,y,z,niprim,nicontr,
$nprimmax,gcoef,gexp2,gcn,dvec,nbasis)
************************************************************************
* Calculate orbital values and gradients on grid
************************************************************************
implicit none
integer ngrid,igrid,ii,iprim,niprim,i,j,k,nicontr
integer nprimmax,gcn(2,*),icontr,j1,j2,ispher,nbasis
real*8 grid(3,ngrid),x,y,z,a,gexp2(niprim)
real*8 gcoef(nprimmax,*),dvec(ngrid,4,nbasis),ex,exa,exa2
real*8 intr(niprim,4),inti(4)
real*8 r2,a001,a002,a010,a011,a020,a100,a101,a110,a200
C$OMP PARALLEL DO
C$OMP& DEFAULT(PRIVATE)
C$OMP& SHARED(ngrid,grid,x,y,z,niprim,gexp2,gcn,gcoef,dvec,nicontr)
do igrid=1,ngrid
a100=grid(1,igrid)-x
a010=grid(2,igrid)-y
a001=grid(3,igrid)-z
a002=a001*a001
a020=a010*a010
a200=a100*a100
r2=0.5d0*(a200+a020+a002)
do iprim=1,niprim
a=gexp2(iprim)
ex=dexp(a*r2)
exa=ex*a
intr(iprim, 1)=ex
intr(iprim, 2)=exa*a100
intr(iprim, 3)=exa*a010
intr(iprim, 4)=exa*a001
enddo
ii=0
do icontr=1,nicontr
j1=gcn(1,icontr)
j2=gcn(2,icontr)
inti(1:4)=matmul(gcoef(j1:j2,icontr),intr(j1:j2,1:4))
ii=ii+1
dvec(igrid,1,ii)=a001*inti(1)
dvec(igrid,2,ii)=a001*inti(2)
dvec(igrid,3,ii)=a001*inti(3)
dvec(igrid,4,ii)=inti(1)+a001*inti(4)
ii=ii+1
dvec(igrid,1,ii)=a010*inti(1)
dvec(igrid,2,ii)=a010*inti(2)
dvec(igrid,3,ii)=inti(1)+a010*inti(3)
dvec(igrid,4,ii)=a010*inti(4)
ii=ii+1
dvec(igrid,1,ii)=a100*inti(1)
dvec(igrid,2,ii)=inti(1)+a100*inti(2)
dvec(igrid,3,ii)=a100*inti(3)
dvec(igrid,4,ii)=a100*inti(4)
enddo
enddo
C$OMP END PARALLEL DO
C
return
end
C
************************************************************************
subroutine calco1_d(ngrid,grid,x,y,z,niprim,nicontr,
$nprimmax,gcoef,gexp2,gcn,dvec,nbasis)
************************************************************************
* Calculate orbital values and gradients on grid
************************************************************************
implicit none
integer ngrid,igrid,ii,iprim,niprim,i,j,k,nicontr
integer nprimmax,gcn(2,*),icontr,j1,j2,ispher,nbasis
real*8 grid(3,ngrid),x,y,z,a,gexp2(niprim)
real*8 gcoef(nprimmax,*),dvec(ngrid,4,nbasis),ex,exa,exa2
real*8 intr(niprim,4),ints(20),inti(4)
real*8 r2,a001,a002,a010,a011,a020,a100,a101,a110,a200
C$OMP PARALLEL DO
C$OMP& DEFAULT(PRIVATE)
C$OMP& SHARED(ngrid,grid,x,y,z,niprim,gexp2,gcn,gcoef,dvec,nicontr)
do igrid=1,ngrid
a100=grid(1,igrid)-x
a010=grid(2,igrid)-y
a001=grid(3,igrid)-z
a002=a001*a001
a020=a010*a010
a200=a100*a100
r2=0.5d0*(a200+a020+a002)
do iprim=1,niprim
a=gexp2(iprim)
ex=dexp(a*r2)
exa=ex*a
intr(iprim, 1)=ex
intr(iprim, 2)=exa*a100
intr(iprim, 3)=exa*a010
intr(iprim, 4)=exa*a001
enddo
a011=a010*a001
a101=a100*a001
a110=a100*a010
ints(1)=a110*1.73205080756887697113d0
ints(2)=a011*1.73205080756887697113d0
ints(3)=a002-(a020+a200)*0.5d0
ints(4)=a101*1.73205080756887697113d0
ints(5)=(a200-a020)*0.86602540378443848557d0
ints(6)=a010*1.73205080756887697113d0
ints(7)=a001*1.73205080756887697113d0
ints(8)=a100*2.d0*0.86602540378443848557d0
ints(9)=a100*1.73205080756887697113d0
ints(10)=a001*1.73205080756887697113d0
ints(11)=-a010*2.d0*0.86602540378443848557d0
ints(12)=a010*1.73205080756887697113d0
ints(13)=a001*2.d0
ints(14)=a100*1.73205080756887697113d0
ii=0
do icontr=1,nicontr
j1=gcn(1,icontr)
j2=gcn(2,icontr)
inti(1:4)=matmul(gcoef(j1:j2,icontr),intr(j1:j2,1:4))
ii=ii+1
dvec(igrid,1,ii)=ints(1)*inti(1)
dvec(igrid,2,ii)=ints(6)*inti(1)+ints(1)*inti(2)
dvec(igrid,3,ii)=ints(9)*inti(1)+ints(1)*inti(3)
dvec(igrid,4,ii)=ints(1)*inti(4)
ii=ii+1
dvec(igrid,1,ii)=ints(2)*inti(1)
dvec(igrid,2,ii)=ints(2)*inti(2)
dvec(igrid,3,ii)=ints(10)*inti(1)+ints(2)*inti(3)
dvec(igrid,4,ii)=ints(12)*inti(1)+ints(2)*inti(4)
ii=ii+1
dvec(igrid,1,ii)=ints(3)*inti(1)
dvec(igrid,2,ii)=-a100*inti(1)+ints(3)*inti(2)
dvec(igrid,3,ii)=-a010*inti(1)+ints(3)*inti(3)
dvec(igrid,4,ii)=ints(13)*inti(1)+ints(3)*inti(4)
ii=ii+1
dvec(igrid,1,ii)=ints(4)*inti(1)
dvec(igrid,2,ii)=ints(7)*inti(1)+ints(4)*inti(2)
dvec(igrid,3,ii)=ints(4)*inti(3)
dvec(igrid,4,ii)=ints(14)*inti(1)+ints(4)*inti(4)
ii=ii+1
dvec(igrid,1,ii)=ints(5)*inti(1)
dvec(igrid,2,ii)=ints(8)*inti(1)+ints(5)*inti(2)
dvec(igrid,3,ii)=ints(11)*inti(1)+ints(5)*inti(3)
dvec(igrid,4,ii)=ints(5)*inti(4)
enddo
enddo
C$OMP END PARALLEL DO
C
return
end
C
************************************************************************
subroutine calco1_f(ngrid,grid,x,y,z,niprim,nicontr,
$nprimmax,gcoef,gexp2,gcn,dvec,nbasis)
************************************************************************
* Calculate orbital values and gradients on grid
************************************************************************
implicit none
integer ngrid,igrid,ii,iprim,niprim,i,j,k,nicontr
integer nprimmax,gcn(2,*),icontr,j1,j2,ispher,nbasis
real*8 grid(3,ngrid),x,y,z,a,gexp2(niprim)
real*8 gcoef(nprimmax,*),dvec(ngrid,4,nbasis),ex,exa,exa2
real*8 intr(niprim,4),ints(28),inti(4)
real*8 r2,a001,a002,a003,a010,a011,a012,a020,a021,a030,a100,a101,a
$102,a110,a111,a120,a200,a201,a210,a300
C$OMP PARALLEL DO
C$OMP& DEFAULT(PRIVATE)
C$OMP& SHARED(ngrid,grid,x,y,z,niprim,gexp2,gcn,gcoef,dvec,nicontr)
do igrid=1,ngrid
a100=grid(1,igrid)-x
a010=grid(2,igrid)-y
a001=grid(3,igrid)-z
a002=a001*a001
a003=a002*a001
a020=a010*a010
a030=a020*a010
a200=a100*a100
a300=a200*a100
r2=0.5d0*(a200+a020+a002)
do iprim=1,niprim
a=gexp2(iprim)
ex=dexp(a*r2)
exa=ex*a
intr(iprim, 1)=ex
intr(iprim, 2)=exa*a100
intr(iprim, 3)=exa*a010
intr(iprim, 4)=exa*a001
enddo
a011=a010*a001
a012=a011*a001
a021=a020*a001
a101=a100*a001
a102=a101*a001
a110=a100*a010
a111=a110*a001
a120=a110*a010
a201=a200*a001
a210=a200*a010
ints(1)=a210*2.37170824512628453107d0-a030*0.7905694150420947696
$7d0
ints(2)=a111*3.87298334620741657730d0
ints(3)=a012*2.44948974278317788134d0-(a030+a210)*0.612372435695
$79447033d0
ints(4)=a003-(a021+a201)*1.5d0
ints(5)=a102*2.44948974278317788134d0-(a120+a300)*0.612372435695
$79447033d0
ints(6)=(a201-a021)*1.93649167310370828865d0
ints(7)=a300*0.79056941504209476967d0-a120*2.3717082451262845310
$7d0
ints(8)=a110*2.d0*2.37170824512628453107d0
ints(9)=a011*3.87298334620741657730d0
ints(10)=-a110*2.d0*0.61237243569579447033d0
ints(11)=-a101*2.d0*1.5d0
ints(12)=a002*2.44948974278317788134d0-(a020+a200*3.d0)*0.612372
$43569579447033d0
ints(13)=a101*2.d0*1.93649167310370828865d0
ints(14)=a200*3.d0*0.79056941504209476967d0-a020*2.3717082451262
$8453107d0
ints(15)=a200*2.37170824512628453107d0-a020*3.d0*0.7905694150420
$9476967d0
ints(16)=a101*3.87298334620741657730d0
ints(17)=a002*2.44948974278317788134d0-(a020*3.d0+a200)*0.612372
$43569579447033d0
ints(18)=-a011*2.d0*1.5d0
ints(19)=-a110*2.d0*0.61237243569579447033d0
ints(20)=-a011*2.d0*1.93649167310370828865d0
ints(21)=-a110*2.d0*2.37170824512628453107d0
ints(22)=a110*3.87298334620741657730d0
ints(23)=a011*2.d0*2.44948974278317788134d0
ints(24)=a002*3.d0-(a020+a200)*1.5d0
ints(25)=a101*2.d0*2.44948974278317788134d0
ints(26)=(a200-a020)*1.93649167310370828865d0
ii=0
do icontr=1,nicontr
j1=gcn(1,icontr)
j2=gcn(2,icontr)
inti(1:4)=matmul(gcoef(j1:j2,icontr),intr(j1:j2,1:4))
ii=ii+1
dvec(igrid,1,ii)=ints(1)*inti(1)
dvec(igrid,2,ii)=ints(8)*inti(1)+ints(1)*inti(2)
dvec(igrid,3,ii)=ints(15)*inti(1)+ints(1)*inti(3)
dvec(igrid,4,ii)=ints(1)*inti(4)
ii=ii+1
dvec(igrid,1,ii)=ints(2)*inti(1)
dvec(igrid,2,ii)=ints(9)*inti(1)+ints(2)*inti(2)
dvec(igrid,3,ii)=ints(16)*inti(1)+ints(2)*inti(3)
dvec(igrid,4,ii)=ints(22)*inti(1)+ints(2)*inti(4)
ii=ii+1
dvec(igrid,1,ii)=ints(3)*inti(1)
dvec(igrid,2,ii)=ints(10)*inti(1)+ints(3)*inti(2)
dvec(igrid,3,ii)=ints(17)*inti(1)+ints(3)*inti(3)
dvec(igrid,4,ii)=ints(23)*inti(1)+ints(3)*inti(4)
ii=ii+1
dvec(igrid,1,ii)=ints(4)*inti(1)
dvec(igrid,2,ii)=ints(11)*inti(1)+ints(4)*inti(2)
dvec(igrid,3,ii)=ints(18)*inti(1)+ints(4)*inti(3)
dvec(igrid,4,ii)=ints(24)*inti(1)+ints(4)*inti(4)
ii=ii+1
dvec(igrid,1,ii)=ints(5)*inti(1)
dvec(igrid,2,ii)=ints(12)*inti(1)+ints(5)*inti(2)
dvec(igrid,3,ii)=ints(19)*inti(1)+ints(5)*inti(3)
dvec(igrid,4,ii)=ints(25)*inti(1)+ints(5)*inti(4)
ii=ii+1
dvec(igrid,1,ii)=ints(6)*inti(1)
dvec(igrid,2,ii)=ints(13)*inti(1)+ints(6)*inti(2)
dvec(igrid,3,ii)=ints(20)*inti(1)+ints(6)*inti(3)
dvec(igrid,4,ii)=ints(26)*inti(1)+ints(6)*inti(4)
ii=ii+1
dvec(igrid,1,ii)=ints(7)*inti(1)
dvec(igrid,2,ii)=ints(14)*inti(1)+ints(7)*inti(2)
dvec(igrid,3,ii)=ints(21)*inti(1)+ints(7)*inti(3)
dvec(igrid,4,ii)=ints(7)*inti(4)
enddo
enddo
C$OMP END PARALLEL DO
C
return
end
C
************************************************************************
subroutine calco1_g(ngrid,grid,x,y,z,niprim,nicontr,
$nprimmax,gcoef,gexp2,gcn,dvec,nbasis)
************************************************************************
* Calculate orbital values and gradients on grid
************************************************************************
implicit none
integer ngrid,igrid,ii,iprim,niprim,i,j,k,nicontr
integer nprimmax,gcn(2,*),icontr,j1,j2,ispher,nbasis
real*8 grid(3,ngrid),x,y,z,a,gexp2(niprim)
real*8 gcoef(nprimmax,*),dvec(ngrid,4,nbasis),ex,exa,exa2
real*8 intr(niprim,4),ints(36),inti(4)
real*8 r2,a001,a002,a003,a004,a010,a011,a012,a013,a020,a021,a022,a
$030,a031,a040,a100,a101,a102,a103,a110,a111,a112,a120,a121,a130,a2
$00,a201,a202,a210,a211,a220,a300,a301,a310,a400
C$OMP PARALLEL DO
C$OMP& DEFAULT(PRIVATE)
C$OMP& SHARED(ngrid,grid,x,y,z,niprim,gexp2,gcn,gcoef,dvec,nicontr)
do igrid=1,ngrid
a100=grid(1,igrid)-x
a010=grid(2,igrid)-y
a001=grid(3,igrid)-z
a002=a001*a001
a003=a002*a001
a004=a003*a001
a020=a010*a010
a030=a020*a010
a040=a030*a010
a200=a100*a100
a300=a200*a100
a400=a300*a100
r2=0.5d0*(a200+a020+a002)
do iprim=1,niprim
a=gexp2(iprim)
ex=dexp(a*r2)
exa=ex*a
intr(iprim, 1)=ex
intr(iprim, 2)=exa*a100
intr(iprim, 3)=exa*a010
intr(iprim, 4)=exa*a001
enddo
a011=a010*a001
a012=a011*a001
a013=a012*a001
a021=a020*a001
a022=a021*a001
a031=a030*a001
a101=a100*a001
a102=a101*a001
a103=a102*a001
a110=a100*a010
a111=a110*a001
a112=a111*a001
a120=a110*a010
a121=a120*a001
a130=a120*a010
a201=a200*a001
a202=a201*a001
a210=a200*a010
a211=a210*a001
a220=a210*a010
a301=a300*a001
a310=a300*a010
ints(1)=(a310-a130)*2.95803989154980806475d0
ints(2)=a211*6.27495019900556627590d0-a031*2.0916500663351889066
$6d0
ints(3)=a112*6.70820393249936941515d0-(a130+a310)*1.118033988749
$89490253d0
ints(4)=a013*3.16227766016837907870d0-(a031+a211)*2.371708245126
$28453107d0
ints(5)=a004-(a022+a202)*3.d0+(a040+a400)*0.375d0+a220*0.75d0
ints(6)=a103*3.16227766016837907870d0-(a121+a301)*2.371708245126
$28453107d0
ints(7)=(a202-a022)*3.35410196624968470758d0+(a040-a400)*0.55901
$699437494745126d0
ints(8)=a301*2.09165006633518890666d0-a121*6.2749501990055662759
$0d0
ints(9)=(a040+a400)*0.73950997288745201619d0-a220*4.437059837324
$71231917d0
ints(10)=(a210*3.d0-a030)*2.95803989154980806475d0
ints(11)=a111*2.d0*6.27495019900556627590d0
ints(12)=a012*6.70820393249936941515d0-(a030+a210*3.d0)*1.118033
$98874989490253d0
ints(13)=-a111*2.d0*2.37170824512628453107d0
ints(14)=-a102*2.d0*3.d0+a300*4.d0*0.375d0+a120*2.d0*0.75d0
ints(15)=a003*3.16227766016837907870d0-(a021+a201*3.d0)*2.371708
$24512628453107d0
ints(16)=a102*2.d0*3.35410196624968470758d0-a300*4.d0*0.55901699
$437494745126d0
ints(17)=a201*3.d0*2.09165006633518890666d0-a021*6.2749501990055
$6627590d0
ints(18)=a300*4.d0*0.73950997288745201619d0-a120*2.d0*4.43705983
$732471231917d0
ints(19)=(a300-a120*3.d0)*2.95803989154980806475d0
ints(20)=a201*6.27495019900556627590d0-a021*3.d0*2.0916500663351
$8890666d0
ints(21)=a102*6.70820393249936941515d0-(a120*3.d0+a300)*1.118033
$98874989490253d0
ints(22)=a003*3.16227766016837907870d0-(a021*3.d0+a201)*2.371708
$24512628453107d0
ints(23)=-a012*2.d0*3.d0+a030*4.d0*0.375d0+a210*2.d0*0.75d0
ints(24)=-a111*2.d0*2.37170824512628453107d0
ints(25)=-a012*2.d0*3.35410196624968470758d0+a030*4.d0*0.5590169
$9437494745126d0
ints(26)=-a111*2.d0*6.27495019900556627590d0
ints(27)=a030*4.d0*0.73950997288745201619d0-a210*2.d0*4.43705983
$732471231917d0
ints(28)=a210*6.27495019900556627590d0-a030*2.091650066335188906
$66d0
ints(29)=a111*2.d0*6.70820393249936941515d0
ints(30)=a012*3.d0*3.16227766016837907870d0-(a030+a210)*2.371708
$24512628453107d0
ints(31)=a003*4.d0-(a021*2.d0+a201*2.d0)*3.d0
ints(32)=a102*3.d0*3.16227766016837907870d0-(a120+a300)*2.371708
$24512628453107d0
ints(33)=(a201*2.d0-a021*2.d0)*3.35410196624968470758d0
ints(34)=a300*2.09165006633518890666d0-a120*6.274950199005566275
$90d0
ii=0
do icontr=1,nicontr
j1=gcn(1,icontr)
j2=gcn(2,icontr)
inti(1:4)=matmul(gcoef(j1:j2,icontr),intr(j1:j2,1:4))
ii=ii+1
dvec(igrid,1,ii)=ints(1)*inti(1)
dvec(igrid,2,ii)=ints(10)*inti(1)+ints(1)*inti(2)
dvec(igrid,3,ii)=ints(19)*inti(1)+ints(1)*inti(3)
dvec(igrid,4,ii)=ints(1)*inti(4)
ii=ii+1
dvec(igrid,1,ii)=ints(2)*inti(1)
dvec(igrid,2,ii)=ints(11)*inti(1)+ints(2)*inti(2)
dvec(igrid,3,ii)=ints(20)*inti(1)+ints(2)*inti(3)
dvec(igrid,4,ii)=ints(28)*inti(1)+ints(2)*inti(4)
ii=ii+1
dvec(igrid,1,ii)=ints(3)*inti(1)
dvec(igrid,2,ii)=ints(12)*inti(1)+ints(3)*inti(2)
dvec(igrid,3,ii)=ints(21)*inti(1)+ints(3)*inti(3)
dvec(igrid,4,ii)=ints(29)*inti(1)+ints(3)*inti(4)
ii=ii+1
dvec(igrid,1,ii)=ints(4)*inti(1)
dvec(igrid,2,ii)=ints(13)*inti(1)+ints(4)*inti(2)
dvec(igrid,3,ii)=ints(22)*inti(1)+ints(4)*inti(3)
dvec(igrid,4,ii)=ints(30)*inti(1)+ints(4)*inti(4)
ii=ii+1
dvec(igrid,1,ii)=ints(5)*inti(1)
dvec(igrid,2,ii)=ints(14)*inti(1)+ints(5)*inti(2)
dvec(igrid,3,ii)=ints(23)*inti(1)+ints(5)*inti(3)
dvec(igrid,4,ii)=ints(31)*inti(1)+ints(5)*inti(4)
ii=ii+1
dvec(igrid,1,ii)=ints(6)*inti(1)
dvec(igrid,2,ii)=ints(15)*inti(1)+ints(6)*inti(2)
dvec(igrid,3,ii)=ints(24)*inti(1)+ints(6)*inti(3)
dvec(igrid,4,ii)=ints(32)*inti(1)+ints(6)*inti(4)
ii=ii+1
dvec(igrid,1,ii)=ints(7)*inti(1)
dvec(igrid,2,ii)=ints(16)*inti(1)+ints(7)*inti(2)
dvec(igrid,3,ii)=ints(25)*inti(1)+ints(7)*inti(3)
dvec(igrid,4,ii)=ints(33)*inti(1)+ints(7)*inti(4)
ii=ii+1
dvec(igrid,1,ii)=ints(8)*inti(1)
dvec(igrid,2,ii)=ints(17)*inti(1)+ints(8)*inti(2)
dvec(igrid,3,ii)=ints(26)*inti(1)+ints(8)*inti(3)
dvec(igrid,4,ii)=ints(34)*inti(1)+ints(8)*inti(4)
ii=ii+1
dvec(igrid,1,ii)=ints(9)*inti(1)
dvec(igrid,2,ii)=ints(18)*inti(1)+ints(9)*inti(2)
dvec(igrid,3,ii)=ints(27)*inti(1)+ints(9)*inti(3)
dvec(igrid,4,ii)=ints(9)*inti(4)
enddo
enddo
C$OMP END PARALLEL DO
C
return
end
C
************************************************************************
subroutine calco1_h(ngrid,grid,x,y,z,niprim,nicontr,
$nprimmax,gcoef,gexp2,gcn,dvec,nbasis)
************************************************************************
* Calculate orbital values and gradients on grid
************************************************************************
implicit none
integer ngrid,igrid,ii,iprim,niprim,i,j,k,nicontr
integer nprimmax,gcn(2,*),icontr,j1,j2,ispher,nbasis
real*8 grid(3,ngrid),x,y,z,a,gexp2(niprim)
real*8 gcoef(nprimmax,*),dvec(ngrid,4,nbasis),ex,exa,exa2
real*8 intr(niprim,4),ints(44),inti(4)
real*8 r2,a001,a002,a003,a004,a005,a010,a011,a012,a013,a014,a020,a
$021,a022,a023,a030,a031,a032,a040,a041,a050,a100,a101,a102,a103,a1
$04,a110,a111,a112,a113,a120,a121,a122,a130,a131,a140,a200,a201,a20
$2,a203,a210,a211,a212,a220,a221,a230,a300,a301,a302,a310,a311,a320
$,a400,a401,a410,a500
C$OMP PARALLEL DO
C$OMP& DEFAULT(PRIVATE)
C$OMP& SHARED(ngrid,grid,x,y,z,niprim,gexp2,gcn,gcoef,dvec,nicontr)
do igrid=1,ngrid
a100=grid(1,igrid)-x
a010=grid(2,igrid)-y
a001=grid(3,igrid)-z
a002=a001*a001
a003=a002*a001
a004=a003*a001
a005=a004*a001
a020=a010*a010
a030=a020*a010
a040=a030*a010
a050=a040*a010
a200=a100*a100
a300=a200*a100
a400=a300*a100
a500=a400*a100
r2=0.5d0*(a200+a020+a002)
do iprim=1,niprim
a=gexp2(iprim)
ex=dexp(a*r2)
exa=ex*a
intr(iprim, 1)=ex
intr(iprim, 2)=exa*a100
intr(iprim, 3)=exa*a010
intr(iprim, 4)=exa*a001
enddo
a011=a010*a001
a012=a011*a001
a013=a012*a001
a014=a013*a001
a021=a020*a001
a022=a021*a001
a023=a022*a001
a031=a030*a001
a032=a031*a001
a041=a040*a001
a101=a100*a001
a102=a101*a001
a103=a102*a001
a104=a103*a001
a110=a100*a010
a111=a110*a001
a112=a111*a001
a113=a112*a001
a120=a110*a010
a121=a120*a001
a122=a121*a001
a130=a120*a010
a131=a130*a001
a140=a130*a010
a201=a200*a001
a202=a201*a001
a203=a202*a001
a210=a200*a010
a211=a210*a001
a212=a211*a001
a220=a210*a010
a221=a220*a001
a230=a220*a010
a301=a300*a001
a302=a301*a001
a310=a300*a010
a311=a310*a001
a320=a310*a010
a401=a400*a001
a410=a400*a010
ints(1)=a050*0.70156076002011391601d0-a230*7.0156076002011387160
$5d0+a410*3.50780380010056935802d0
ints(2)=(a311-a131)*8.87411967464942463835d0
ints(3)=a050*0.52291251658379711564d0-a032*4.1833001326703769251
$5d0+a212*12.54990039801113255180d0-a230*1.04582503316759423129d0-a
$410*1.56873754975139156898d0
ints(4)=a113*10.24695076595959974952d0-(a131+a311)*5.12347538297
$979987476d0
ints(5)=a014*3.87298334620741613321d0-(a032+a212)*5.809475019311
$12419982d0+a230*0.96824583655185403330d0+(a050+a410)*0.48412291827
$592701665d0
ints(6)=a005-(a023+a203)*5.d0+a221*3.75d0+(a041+a401)*1.875d0
ints(7)=a104*3.87298334620741613321d0-(a122+a302)*5.809475019311
$12419982d0+a320*0.96824583655185403330d0+(a140+a500)*0.48412291827
$592701665d0
ints(8)=(a203-a023)*5.12347538297979987476d0+(a041-a401)*2.56173
$769148989993738d0
ints(9)=a140*1.56873754975139156898d0-a122*12.549900398011132551
$80d0+a302*4.18330013267037692515d0+a320*1.04582503316759423129d0-a
$500*0.52291251658379711564d0
ints(10)=(a041+a401)*2.21852991866235615959d0-a221*13.3111795119
$7413695752d0
ints(11)=a140*3.50780380010056935802d0-a320*7.015607600201138716
$05d0+a500*0.70156076002011391601d0
ints(12)=-a130*2.d0*7.01560760020113871605d0+a310*4.d0*3.5078038
$0010056935802d0
ints(13)=(a211*3.d0-a031)*8.87411967464942463835d0
ints(14)=a112*2.d0*12.54990039801113255180d0-a130*2.d0*1.0458250
$3316759423129d0-a310*4.d0*1.56873754975139156898d0
ints(15)=a013*10.24695076595959974952d0-(a031+a211*3.d0)*5.12347
$538297979987476d0
ints(16)=-a112*2.d0*5.80947501931112419982d0+a130*2.d0*0.9682458
$3655185403330d0+a310*4.d0*0.48412291827592701665d0
ints(17)=-a103*2.d0*5.d0+a121*2.d0*3.75d0+a301*4.d0*1.875d0
ints(18)=a004*3.87298334620741613321d0-(a022+a202*3.d0)*5.809475
$01931112419982d0+a220*3.d0*0.96824583655185403330d0+(a040+a400*5.d
$0)*0.48412291827592701665d0
ints(19)=a103*2.d0*5.12347538297979987476d0-a301*4.d0*2.56173769
$148989993738d0
ints(20)=a040*1.56873754975139156898d0-a022*12.54990039801113255
$180d0+a202*3.d0*4.18330013267037692515d0+a220*3.d0*1.0458250331675
$9423129d0-a400*5.d0*0.52291251658379711564d0
ints(21)=a301*4.d0*2.21852991866235615959d0-a121*2.d0*13.3111795
$1197413695752d0
ints(22)=a040*3.50780380010056935802d0-a220*3.d0*7.0156076002011
$3871605d0+a400*5.d0*0.70156076002011391601d0
ints(23)=a040*5.d0*0.70156076002011391601d0-a220*3.d0*7.01560760
$020113871605d0+a400*3.50780380010056935802d0
ints(24)=(a301-a121*3.d0)*8.87411967464942463835d0
ints(25)=a040*5.d0*0.52291251658379711564d0-a022*3.d0*4.18330013
$267037692515d0+a202*12.54990039801113255180d0-a220*3.d0*1.04582503
$316759423129d0-a400*1.56873754975139156898d0
ints(26)=a103*10.24695076595959974952d0-(a121*3.d0+a301)*5.12347
$538297979987476d0
ints(27)=a004*3.87298334620741613321d0-(a022*3.d0+a202)*5.809475
$01931112419982d0+a220*3.d0*0.96824583655185403330d0+(a040*5.d0+a40
$0)*0.48412291827592701665d0
ints(28)=-a013*2.d0*5.d0+a211*2.d0*3.75d0+a031*4.d0*1.875d0
ints(29)=-a112*2.d0*5.80947501931112419982d0+a310*2.d0*0.9682458
$3655185403330d0+a130*4.d0*0.48412291827592701665d0
ints(30)=-a013*2.d0*5.12347538297979987476d0+a031*4.d0*2.5617376
$9148989993738d0
ints(31)=a130*4.d0*1.56873754975139156898d0-a112*2.d0*12.5499003
$9801113255180d0+a310*2.d0*1.04582503316759423129d0
ints(32)=a031*4.d0*2.21852991866235615959d0-a211*2.d0*13.3111795
$1197413695752d0
ints(33)=a130*4.d0*3.50780380010056935802d0-a310*2.d0*7.01560760
$020113871605d0
ints(34)=(a310-a130)*8.87411967464942463835d0
ints(35)=-a031*2.d0*4.18330013267037692515d0+a211*2.d0*12.549900
$39801113255180d0
ints(36)=a112*3.d0*10.24695076595959974952d0-(a130+a310)*5.12347
$538297979987476d0
ints(37)=a013*4.d0*3.87298334620741613321d0-(a031*2.d0+a211*2.d0
$)*5.80947501931112419982d0
ints(38)=a004*5.d0-(a022*3.d0+a202*3.d0)*5.d0+a220*3.75d0+(a040+
$a400)*1.875d0
ints(39)=a103*4.d0*3.87298334620741613321d0-(a121*2.d0+a301*2.d0
$)*5.80947501931112419982d0
ints(40)=(a202*3.d0-a022*3.d0)*5.12347538297979987476d0+(a040-a4
$00)*2.56173769148989993738d0
ints(41)=-a121*2.d0*12.54990039801113255180d0+a301*2.d0*4.183300
$13267037692515d0
ints(42)=(a040+a400)*2.21852991866235615959d0-a220*13.3111795119
$7413695752d0
ii=0
do icontr=1,nicontr
j1=gcn(1,icontr)
j2=gcn(2,icontr)
inti(1:4)=matmul(gcoef(j1:j2,icontr),intr(j1:j2,1:4))
ii=ii+1
dvec(igrid,1,ii)=ints(1)*inti(1)
dvec(igrid,2,ii)=ints(12)*inti(1)+ints(1)*inti(2)
dvec(igrid,3,ii)=ints(23)*inti(1)+ints(1)*inti(3)
dvec(igrid,4,ii)=ints(1)*inti(4)
ii=ii+1
dvec(igrid,1,ii)=ints(2)*inti(1)
dvec(igrid,2,ii)=ints(13)*inti(1)+ints(2)*inti(2)
dvec(igrid,3,ii)=ints(24)*inti(1)+ints(2)*inti(3)
dvec(igrid,4,ii)=ints(34)*inti(1)+ints(2)*inti(4)
ii=ii+1
dvec(igrid,1,ii)=ints(3)*inti(1)
dvec(igrid,2,ii)=ints(14)*inti(1)+ints(3)*inti(2)
dvec(igrid,3,ii)=ints(25)*inti(1)+ints(3)*inti(3)
dvec(igrid,4,ii)=ints(35)*inti(1)+ints(3)*inti(4)
ii=ii+1
dvec(igrid,1,ii)=ints(4)*inti(1)
dvec(igrid,2,ii)=ints(15)*inti(1)+ints(4)*inti(2)
dvec(igrid,3,ii)=ints(26)*inti(1)+ints(4)*inti(3)
dvec(igrid,4,ii)=ints(36)*inti(1)+ints(4)*inti(4)
ii=ii+1
dvec(igrid,1,ii)=ints(5)*inti(1)
dvec(igrid,2,ii)=ints(16)*inti(1)+ints(5)*inti(2)
dvec(igrid,3,ii)=ints(27)*inti(1)+ints(5)*inti(3)
dvec(igrid,4,ii)=ints(37)*inti(1)+ints(5)*inti(4)
ii=ii+1
dvec(igrid,1,ii)=ints(6)*inti(1)
dvec(igrid,2,ii)=ints(17)*inti(1)+ints(6)*inti(2)
dvec(igrid,3,ii)=ints(28)*inti(1)+ints(6)*inti(3)
dvec(igrid,4,ii)=ints(38)*inti(1)+ints(6)*inti(4)
ii=ii+1
dvec(igrid,1,ii)=ints(7)*inti(1)
dvec(igrid,2,ii)=ints(18)*inti(1)+ints(7)*inti(2)
dvec(igrid,3,ii)=ints(29)*inti(1)+ints(7)*inti(3)
dvec(igrid,4,ii)=ints(39)*inti(1)+ints(7)*inti(4)
ii=ii+1
dvec(igrid,1,ii)=ints(8)*inti(1)
dvec(igrid,2,ii)=ints(19)*inti(1)+ints(8)*inti(2)
dvec(igrid,3,ii)=ints(30)*inti(1)+ints(8)*inti(3)
dvec(igrid,4,ii)=ints(40)*inti(1)+ints(8)*inti(4)
ii=ii+1
dvec(igrid,1,ii)=ints(9)*inti(1)
dvec(igrid,2,ii)=ints(20)*inti(1)+ints(9)*inti(2)
dvec(igrid,3,ii)=ints(31)*inti(1)+ints(9)*inti(3)
dvec(igrid,4,ii)=ints(41)*inti(1)+ints(9)*inti(4)
ii=ii+1
dvec(igrid,1,ii)=ints(10)*inti(1)
dvec(igrid,2,ii)=ints(21)*inti(1)+ints(10)*inti(2)
dvec(igrid,3,ii)=ints(32)*inti(1)+ints(10)*inti(3)
dvec(igrid,4,ii)=ints(42)*inti(1)+ints(10)*inti(4)
ii=ii+1
dvec(igrid,1,ii)=ints(11)*inti(1)
dvec(igrid,2,ii)=ints(22)*inti(1)+ints(11)*inti(2)
dvec(igrid,3,ii)=ints(33)*inti(1)+ints(11)*inti(3)
dvec(igrid,4,ii)=ints(11)*inti(4)
enddo
enddo
C$OMP END PARALLEL DO
C
return
end
C
Reference in New Issue View Git Blame Copy Permalink