get_spin_square Function

public function get_spin_square(dmat_a, dmat_b, ta, tb, abxc, smat, nocb) result(s2)

Uses

  • proc~~get_spin_square~~UsesGraph proc~get_spin_square get_spin_square module~mathlib mathlib proc~get_spin_square->module~mathlib module~messages messages proc~get_spin_square->module~messages module~precision precision proc~get_spin_square->module~precision module~mathlib->module~precision module~oqp_linalg oqp_linalg module~mathlib->module~oqp_linalg 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 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~messages module~blas_wrap->module~precision module~mathlib_types mathlib_types module~blas_wrap->module~mathlib_types module~lapack_wrap->module~messages module~lapack_wrap->module~precision module~lapack_wrap->module~mathlib_types

Arguments

Type IntentOptional Attributes Name
real(kind=dp), intent(in), dimension(:) :: dmat_a
real(kind=dp), intent(in), dimension(:) :: dmat_b
real(kind=dp), intent(in), dimension(:) :: ta
real(kind=dp), intent(in), dimension(:) :: tb
real(kind=dp), intent(in), dimension(:,:) :: abxc
real(kind=dp), intent(in), dimension(:) :: smat
integer, intent(in) :: nocb

Return Value real(kind=dp)


Calls

proc~~get_spin_square~~CallsGraph proc~get_spin_square get_spin_square interface~pack_matrix pack_matrix proc~get_spin_square->interface~pack_matrix interface~show_message show_message proc~get_spin_square->interface~show_message interface~unpack_matrix unpack_matrix proc~get_spin_square->interface~unpack_matrix proc~oqp_dgemm_i64 oqp_dgemm_i64 proc~get_spin_square->proc~oqp_dgemm_i64 proc~symmetrize_matrix symmetrize_matrix proc~get_spin_square->proc~symmetrize_matrix proc~traceprod_sym_packed traceprod_sym_packed proc~get_spin_square->proc~traceprod_sym_packed proc~pack_f90 PACK_F90 interface~pack_matrix->proc~pack_f90 proc~unpack_f90 UNPACK_F90 interface~unpack_matrix->proc~unpack_f90 proc~oqp_dgemm_i64->interface~show_message dgemm dgemm proc~oqp_dgemm_i64->dgemm proc~pack_f90->interface~show_message proc~oqp_dtrttp_i64 oqp_dtrttp_i64 proc~pack_f90->proc~oqp_dtrttp_i64 proc~unpack_f90->interface~show_message proc~oqp_dtpttr_i64 oqp_dtpttr_i64 proc~unpack_f90->proc~oqp_dtpttr_i64 proc~oqp_dtpttr_i64->interface~show_message dtpttr dtpttr proc~oqp_dtpttr_i64->dtpttr proc~oqp_dtrttp_i64->interface~show_message dtrttp dtrttp proc~oqp_dtrttp_i64->dtrttp

Called by

proc~~get_spin_square~~CalledByGraph proc~get_spin_square get_spin_square proc~tdhf_sf_energy tdhf_sf_energy proc~tdhf_sf_energy->proc~get_spin_square proc~tdhf_sf_energy_c tdhf_sf_energy_C proc~tdhf_sf_energy_c->proc~tdhf_sf_energy

Source Code

  function get_spin_square(dmat_a,dmat_b,ta,tb,abxc,Smat,nocb) result(s2)
  ! dmat_a / dmat_b -- alpha/beta density of the excited state
  ! ta / tb -- alpha/beta difference density matrix
    use precision, only : dp
    use mathlib, only: symmetrize_matrix, traceprod_sym_packed
    use mathlib, only: pack_matrix, unpack_matrix
    use messages, only: show_message, with_abort

    implicit none

    real(kind=dp), intent(in), dimension(:) :: &
      dmat_a, dmat_b, ta, tb
    real(kind=dp), intent(in), dimension(:,:) :: abxc
    real(kind=dp), intent(in), dimension(:) :: smat
    integer, intent(in) :: nocb
    real(kind=dp) :: s2

    real(kind=dp), allocatable :: scr1(:), dmat_t(:), &
      dmat_t_sq(:,:), smat_sq(:,:), tmp1(:,:), tmp2(:,:)
    integer :: nbf, nbf_tri, ok
    real(kind=dp) :: dum1, dum2, dum3, dum4

    nbf = ubound(abxc, 1)
    nbf_tri = ubound(dmat_a, 1)

    allocate(scr1(nbf_tri), &
             dmat_t(nbf_tri), &
             dmat_t_sq(nbf,nbf), &
             smat_sq(nbf,nbf), &
             tmp1(nbf,nbf), &
             tmp2(nbf,nbf), &
             source=0.0_dp, stat=ok)
    if (ok/=0) call show_message('Cannot allocate memory in qet_spin_square',with_abort)

   ! Calculate spin expectation values
     dum1 = nocb+1

   ! Symmetric matrix scr1 = Smat*Dmat_a*Smat
     dmat_t = dmat_a + ta
     call unpack_matrix(dmat_t,dmat_t_sq)
     call unpack_matrix(smat,smat_sq)
     call dgemm('n', 'n', nbf, nbf, nbf, &
                1.0_dp, smat_sq, nbf, &
                        dmat_t_sq, nbf, &
                0.0_dp, tmp1, nbf)
     call dgemm('n', 'n', nbf, nbf, nbf, &
                1.0_dp, tmp1, nbf, &
                        smat_sq, nbf, &
                0.0_dp, tmp2, nbf)
     call pack_matrix(tmp2,scr1)
   ! -tr[ Dmat_b*Smat*Dmat_a*Smat ]
     dmat_t = dmat_b + tb
     dum2 = -traceprod_sym_packed(dmat_t,scr1,nbf)

   ! Symmetric matrix scr1 = Smat*Ta*Smat
     call unpack_matrix(Ta,tmp1)
     call dgemm('n', 'n', nbf, nbf, nbf, &
                1.0_dp, smat_sq, nbf, &
                        tmp1, nbf, &
                0.0_dp, tmp2, nbf)
     call dgemm('n', 'n', nbf, nbf, nbf, &
                1.0_dp, tmp2, nbf, &
                        smat_sq, nbf, &
                0.0_dp, tmp1, nbf)
     call pack_matrix(tmp1,scr1)
   ! -tr[ Tb*Smat*Ta*Smat ])
     dum3 =-traceprod_sym_packed(tb,scr1,nbf)

   ! +tr[ abxc*Smat ]
     tmp1 = abxc
     call symmetrize_matrix(tmp1, nbf)
     call pack_matrix(tmp1, scr1)
     dum4 = traceprod_sym_packed(scr1, smat, nbf)/2.0_dp

     s2 = dum1 + dum2 - dum3 + dum4**2

 end function get_spin_square