10
0
mirror of https://gitlab.com/scemama/eplf synced 2024-07-07 11:55:58 +02:00
eplf/ao.irp.f
2009-06-10 00:41:32 +02:00

177 lines
3.3 KiB
Fortran

BEGIN_PROVIDER [ integer, ao_num ]
implicit none
BEGIN_DOC
! Number of atomic orbitals
END_DOC
!$OMP CRITICAL (qcio_critical)
call qcio_get_basis_num_contr(ao_num)
!$OMP END CRITICAL (qcio_critical)
assert (ao_num > 0)
END_PROVIDER
BEGIN_PROVIDER [ integer, ao_prim_num, (ao_num) ]
implicit none
BEGIN_DOC
! Number of primitives per atomic orbital
END_DOC
!$OMP CRITICAL (qcio_critical)
call qcio_get_basis_num_prim(ao_prim_num)
!$OMP END CRITICAL (qcio_critical)
END_PROVIDER
BEGIN_PROVIDER [ integer, ao_nucl, (ao_num) ]
implicit none
BEGIN_DOC
! Nucleus on which the atomic orbital is centered
END_DOC
!$OMP CRITICAL (qcio_critical)
call qcio_get_basis_atom(ao_nucl)
!$OMP END CRITICAL (qcio_critical)
END_PROVIDER
BEGIN_PROVIDER [ integer, ao_power, (ao_num,3) ]
implicit none
BEGIN_DOC
! x,y,z powers of the atomic orbital
END_DOC
integer :: buffer(3,ao_num)
integer :: i,j
!$OMP CRITICAL (qcio_critical)
call qcio_get_basis_power(buffer)
!$OMP END CRITICAL (qcio_critical)
do i=1,3
do j=1,ao_num
ao_power(j,i) = buffer(i,j)
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ integer , ao_power_max ]
BEGIN_DOC
! Maximum power among x, y and z
END_DOC
ao_power_max = maxval(ao_power_max_nucl)
END_PROVIDER
BEGIN_PROVIDER [ integer , ao_power_max_nucl, (nucl_num,3) ]
implicit none
BEGIN_DOC
! Maximum powers of x, y and z per nucleus
END_DOC
integer :: i, j
do j=1,3
do i=1,nucl_num
ao_power_max_nucl(i,j) = 0
enddo
enddo
integer :: inucl
do j=1,3
do i=1,ao_num
inucl = ao_nucl(i)
ao_power_max_nucl(inucl,j) = max(ao_power(i,j),ao_power_max_nucl(inucl,j))
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ integer, ao_prim_num_max ]
implicit none
BEGIN_DOC
! Max Number of primitives per atomic orbital
END_DOC
ao_prim_num_max = maxval(ao_prim_num)
END_PROVIDER
BEGIN_PROVIDER [ real, ao_expo, (ao_prim_num_max,ao_num) ]
&BEGIN_PROVIDER [ real, ao_coef, (ao_prim_num_max,ao_num) ]
implicit none
BEGIN_DOC
! Exponents and coefficients of the atomic orbitals
END_DOC
double precision :: buffer(ao_prim_num_max,ao_num)
integer :: i,j
!$OMP CRITICAL (qcio_critical)
call qcio_get_basis_exponent(buffer)
!$OMP END CRITICAL (qcio_critical)
do i=1,ao_num
do j=1,ao_prim_num(i)
ao_expo(j,i) = buffer(j,i)
enddo
enddo
!$OMP CRITICAL (qcio_critical)
call qcio_get_basis_coefficient(buffer)
!$OMP END CRITICAL (qcio_critical)
double precision :: norm, norm2
double precision :: overlap
do i=1,ao_num
do j=1,ao_prim_num(i)
norm = overlap(ao_expo(j,i),ao_expo(j,i),ao_power(i,:))
norm = sqrt(norm)
ao_coef(j,i) = buffer(j,i)/norm
enddo
enddo
END_PROVIDER
double precision function rintgauss(n)
implicit none
integer :: n
double precision :: pi
pi = acos(-1.)
rintgauss = sqrt(pi)
if ( n == 0 ) then
return
else if ( n == 1 ) then
rintgauss = 0.
else if ( mod(n,2) == 1) then
rintgauss = 0.
else
double precision :: fact2
rintgauss = rintgauss/(2.**(n/2))
rintgauss = rintgauss * fact2(n-1)
endif
end function
double precision function overlap(gamA,gamB,nA)
implicit none
real :: gamA, gamB
integer :: nA(3)
double precision :: gamtot
gamtot = gamA+gamB
overlap=1.0
integer :: l
double precision :: rintgauss
do l=1,3
overlap = overlap * rintgauss(nA(l)+nA(l))/ (gamtot**(0.5+float(nA(l))))
enddo
end function