build_pfon_density Subroutine

public subroutine build_pfon_density(pdmat, mo_a, mo_b, occ_a, occ_b, scf_type, nbf, nelec_a, nelec_b)

Uses

  • proc~~build_pfon_density~~UsesGraph proc~build_pfon_density build_pfon_density module~mathlib mathlib proc~build_pfon_density->module~mathlib module~precision precision proc~build_pfon_density->module~precision module~mathlib->module~precision module~oqp_linalg oqp_linalg module~mathlib->module~oqp_linalg iso_fortran_env iso_fortran_env module~precision->iso_fortran_env module~blas_wrap blas_wrap module~oqp_linalg->module~blas_wrap module~lapack_wrap lapack_wrap module~oqp_linalg->module~lapack_wrap module~blas_wrap->module~precision module~mathlib_types mathlib_types module~blas_wrap->module~mathlib_types module~messages messages module~blas_wrap->module~messages module~lapack_wrap->module~precision module~lapack_wrap->module~mathlib_types module~lapack_wrap->module~messages module~messages->module~precision comm_IOFILE comm_IOFILE module~messages->comm_IOFILE comm_PAR comm_PAR module~messages->comm_PAR module~io_constants io_constants module~messages->module~io_constants

Arguments

Type IntentOptional Attributes Name
real(kind=dp), intent(inout) :: pdmat(:,:)
real(kind=dp), intent(in) :: mo_a(:,:)
real(kind=dp), intent(in) :: mo_b(:,:)
real(kind=dp), intent(in) :: occ_a(:)
real(kind=dp), intent(in) :: occ_b(:)
integer, intent(in) :: scf_type
integer, intent(in) :: nbf
integer, intent(in) :: nelec_a
integer, intent(in) :: nelec_b

Calls

proc~~build_pfon_density~~CallsGraph proc~build_pfon_density build_pfon_density interface~pack_matrix pack_matrix proc~build_pfon_density->interface~pack_matrix proc~pack_f90 PACK_F90 interface~pack_matrix->proc~pack_f90 interface~show_message show_message proc~pack_f90->interface~show_message proc~oqp_dtrttp_i64 oqp_dtrttp_i64 proc~pack_f90->proc~oqp_dtrttp_i64 proc~oqp_dtrttp_i64->interface~show_message dtrttp dtrttp proc~oqp_dtrttp_i64->dtrttp

Called by

proc~~build_pfon_density~~CalledByGraph proc~build_pfon_density build_pfon_density proc~scf_driver scf_driver proc~scf_driver->proc~build_pfon_density proc~hf_energy hf_energy proc~hf_energy->proc~scf_driver

Source Code

    subroutine build_pfon_density(pdmat, mo_a, mo_b, occ_a, occ_b, scf_type, nbf, nelec_a, nelec_b)
        use precision, only: dp 
        use mathlib, only: pack_matrix
        implicit none 

        real(kind=dp), intent(inout) :: pdmat(:,:)
        real(kind=dp), intent(in) :: mo_a(:,:), mo_b(:,:)
        real(kind=dp), intent(in) :: occ_a(:), occ_b(:)
        integer, intent(in) :: nbf, scf_type, nelec_a, nelec_b

        real(kind=dp), allocatable :: dtmp(:,:)
        integer :: i, mu, nu
        integer :: n_double, n_single
        real(kind=dp) :: occ_factor

        allocate(dtmp(nbf, nbf), source=0.0_dp)
        
        pdmat(:,:) = 0.0_dp

        select case(scf_type)
        case(1)  ! RHF
            do i = 1, nbf 
                if (occ_a(i) > 1.0e-14_dp) then 
                    do mu = 1, nbf
                        do nu = 1, nbf 
                            dtmp(mu,nu) = dtmp(mu,nu) + occ_a(i) * mo_a(mu,i)*mo_a(nu,i)
                        end do 
                    end do 
                end if 
            end do 
            call pack_matrix(dtmp, pdmat(:,1))

        case(2)  ! UHF
            do i = 1, nbf 
                if (occ_a(i) > 1.0e-14_dp) then 
                    do mu = 1, nbf
                        do nu = 1, nbf 
                            dtmp(mu,nu) = dtmp(mu,nu) + occ_a(i) * mo_a(mu,i)*mo_a(nu,i)
                        end do 
                    end do 
                end if 
            end do 
            call pack_matrix(dtmp, pdmat(:,1))

            dtmp(:,:) = 0.0_dp 
            do i = 1, nbf 
                if (occ_b(i) > 1.0e-14_dp) then 
                    do mu = 1, nbf 
                        do nu = 1, nbf 
                            dtmp(mu,nu) = dtmp(mu,nu) + occ_b(i) * mo_b(mu,i)*mo_b(nu,i)
                        end do 
                    end do 
                end if 
            end do
            call pack_matrix(dtmp, pdmat(:,2))

        case(3)  ! ROHF
            n_double = nelec_b           
            n_single = nelec_a - nelec_b 

            dtmp(:,:) = 0.0_dp
            do i = 1, nbf 
                if (occ_a(i) > 1.0e-14_dp) then 
                    if (i <= n_double) then
                        occ_factor = occ_a(i)  
                    else if (i <= n_double + n_single) then
                        occ_factor = 1.0_dp  
                    else
                        occ_factor = occ_a(i)  ! Virtual orbitals
                    endif

                    do mu = 1, nbf
                        do nu = 1, nbf 
                            dtmp(mu,nu) = dtmp(mu,nu) + occ_factor * mo_a(mu,i)*mo_a(nu,i)
                        end do 
                    end do 
                end if 
            end do 
            call pack_matrix(dtmp, pdmat(:,1))

            dtmp(:,:) = 0.0_dp 
            do i = 1, nbf 
                if (occ_b(i) > 1.0e-14_dp) then 
                    if (i <= n_double) then
                        occ_factor = occ_b(i)
                    else
                        occ_factor = 0.0_dp
                    endif

                    do mu = 1, nbf 
                        do nu = 1, nbf 
                            dtmp(mu,nu) = dtmp(mu,nu) + occ_factor * mo_a(mu,i)*mo_a(nu,i)
                        end do 
                    end do 
                end if 
            end do
            call pack_matrix(dtmp, pdmat(:,2))
        end select

        deallocate(dtmp)

    end subroutine build_pfon_density