mrsfqrorhs Subroutine

public subroutine mrsfqrorhs(rhs, xhxa, xhxb, hpta, hptb, tab, tij, fa, fb, noca, nocb)

Uses

  • proc~~mrsfqrorhs~~UsesGraph proc~mrsfqrorhs mrsfqrorhs module~precision precision proc~mrsfqrorhs->module~precision iso_fortran_env iso_fortran_env module~precision->iso_fortran_env

Arguments

Type IntentOptional Attributes Name
real(kind=dp), intent(out), dimension(:) :: rhs
real(kind=dp), intent(inout), dimension(:,:) :: xhxa
real(kind=dp), intent(inout), dimension(:,:) :: xhxb
real(kind=dp), intent(in), dimension(:,:) :: hpta
real(kind=dp), intent(in), dimension(:,:) :: hptb
real(kind=dp), intent(in), dimension(:,:) :: tab
real(kind=dp), intent(in), dimension(:,:) :: tij
real(kind=dp), intent(in), dimension(:,:) :: fa
real(kind=dp), intent(in), dimension(:,:) :: fb
integer, intent(in) :: noca
integer, intent(in) :: nocb

Calls

proc~~mrsfqrorhs~~CallsGraph proc~mrsfqrorhs mrsfqrorhs proc~oqp_dgemm_i64 oqp_dgemm_i64 proc~mrsfqrorhs->proc~oqp_dgemm_i64 dgemm dgemm proc~oqp_dgemm_i64->dgemm interface~show_message show_message proc~oqp_dgemm_i64->interface~show_message

Source Code

  subroutine mrsfqrorhs(rhs, xhxa, xhxb, hpta, hptb, tab, tij, fa, fb, noca,  &
                        nocb)

    use precision, only: dp
    implicit none

    real(kind=dp), intent(out), dimension(:) :: rhs
    real(kind=dp), intent(inout), dimension(:,:) :: xhxa, xhxb
    real(kind=dp), intent(in), dimension(:,:) :: hpta
    real(kind=dp), intent(in), dimension(:,:) :: hptb
    real(kind=dp), intent(in), dimension(:,:) :: tij
    real(kind=dp), intent(in), dimension(:,:) :: tab
    real(kind=dp), intent(in), dimension(:,:) :: fa, fb
    integer, intent(in) :: noca, nocb

    real(kind=dp), allocatable, dimension(:,:) :: scr
    integer :: nbf, i, j, ij, a, x, nconf

    nbf = ubound(fa, 1)

    allocate(scr(nbf,nbf), &
             source=0.0_dp)

  ! Alpha
  ! hxa+= 2*fa(p+,a+)*ta(a+,b+)
    do j = noca+1, nbf
      do i = noca+1, nbf
        scr(i,j) = tab(i-noca,j-noca)
      end do
    end do
    call dgemm('n', 'n', nbf, nbf, nbf, &
               2.0_dp, fa, nbf, &
                       scr, nbf, &
               1.0_dp, xhxa, nbf)

  ! Beta
  ! xhxb+= 2*fb(p-, i-)*tb(i-, j-)
    call dgemm('n', 'n', nbf, nocb, nocb, &
               2.0_dp, fb, nbf, &
                       tij, nocb, &
               1.0_dp, xhxb, nbf)

    rhs = 0.0_dp

  ! doc-socc
    ij = 0
    do x = nocb+1, noca
      do i = 1, nocb
        ij = ij+1
        rhs(ij) = hptb(i,x-nocb)+xhxb(x,i)
      end do
    end do

  ! doc-virt
    do a = noca+1, nbf
      do i = 1, nocb
        ij = ij+1
        rhs(ij) = hpta(i,a-noca)+hptb(i,a-nocb) &
                + xhxb(a,i)-xhxa(i,a)
      end do
    end do

  ! soc-virt
    do a = noca+1, nbf
      do x = nocb+1, noca
        ij = ij+1
        rhs(ij) = hpta(x,a-noca)-xhxa(x,a)
      end do
    end do

    nconf = ij
    rhs(1:nconf) = -rhs(1:nconf)

    return

  end subroutine mrsfqrorhs