subroutine sfrolhs(pmo, z, e, fa, fb, hpza, hpzb, &
noca, nocb)
use precision, only: dp
implicit none
real(kind=dp), intent(out), dimension(:) :: pmo
real(kind=dp), intent(in), dimension(:) :: z
real(kind=dp), intent(in), dimension(:) :: e
real(kind=dp), intent(in), dimension(:,:) :: fa, fb
real(kind=dp), intent(in), dimension(:,:) :: hpza
real(kind=dp), intent(in), dimension(:,:) :: hpzb
integer, intent(in) :: noca, nocb
real(kind=dp), allocatable, dimension(:,:) :: ztmp
real(kind=dp), allocatable, dimension(:,:) :: wrk
integer :: ij, i, k, j, nbf, lr1, lr2
nbf = ubound(fa, 1)
lr1 = nocb+1
lr2 = noca
allocate(ztmp(nbf,nbf), &
wrk(nbf,nbf), &
source=0.0_dp)
ij = 0
do i = nocb+1, noca
do j = 1, nocb
ij = ij+1
ztmp(j,i) = z(ij)
end do
end do
do k = noca+1, nbf
do j = 1, nocb
ij = ij+1
ztmp(j,k) = z(ij)
end do
end do
do k = noca+1, nbf
do i = nocb+1, noca
ij = ij+1
ztmp(i,k) = z(ij)
end do
end do
! doc-socc
do j = 1, nocb
wrk(j,1) = wrk(j,1)+hpzb(j,1) &
-fa(lr1,lr1)*ztmp(j,lr1) &
-fa(lr2,lr1)*ztmp(j,lr2)
wrk(j,2) = wrk(j,2)+hpzb(j,2) &
-fa(lr2,lr2)*ztmp(j,lr2) &
-fa(lr1,lr2)*ztmp(j,lr1)
end do
do j = 1, nocb
do k = 1, nocb
wrk(j,1) = wrk(j,1)+fa(k,j)*ztmp(k,lr1)
wrk(j,2) = wrk(j,2)+fa(k,j)*ztmp(k,lr2)
end do
end do
do j = 1, nocb
do k = 1, nbf-noca
wrk(j,1) = wrk(j,1)+fb(noca+k,lr1)*ztmp(j,noca+k) &
+fb(noca+k,j)*ztmp(lr1,noca+k)
wrk(j,2) = wrk(j,2)+fb(noca+k,j)*ztmp(lr2,noca+k) &
+fb(noca+k,lr2)*ztmp(j,noca+k)
end do
end do
ij = 0
wrk = wrk*0.5_dp
do i = 1, 2
do j = 1, nocb
ij = ij+1
pmo(ij) = (e(nocb+i)-e(j))*z(ij)+wrk(j,i)
end do
end do
! doc-virt
wrk = 0.0_dp
do k = 1, nbf-noca
do j = 1, nocb
wrk(j,k) = wrk(j,k)+hpza(j,k) &
+hpzb(j,noca-nocb+k) &
+fb(lr1,noca+k)*ztmp(j,lr1) &
+fb(lr2,noca+k)*ztmp(j,lr2) &
-fa(lr1,j)*ztmp(lr1,noca+k) &
-fa(lr2,j)*ztmp(lr2,noca+k)
end do
end do
wrk = wrk*0.5_dp
do k = 1, nbf-noca
do j = 1, nocb
ij = ij+1
pmo(ij) =(e(noca+k)-e(j))*z(ij)+wrk(j,k)
end do
end do
! socc-virt
wrk = 0.0_dp
do k = 1, nbf-noca
wrk(k,1) = wrk(k,1)+hpza(lr1,k) &
+fb(lr1,lr1)*ztmp(lr1,noca+k) &
+fb(lr2,lr1)*ztmp(lr2,noca+k)
wrk(k,2) = wrk(k,2)+hpza(lr2,k) &
+fb(lr1,lr2)*ztmp(lr1,noca+k) &
+fb(lr2,lr2)*ztmp(lr2,noca+k)
end do
do k = 1, nbf-noca
do j = 1, nocb
wrk(k,1) = wrk(k,1)-fa(j,noca+k)*ztmp(j,lr1) &
-fa(j,lr1)*ztmp(j,noca+k)
wrk(k,2) = wrk(k,2)-fa(j,noca+k)*ztmp(j,lr2) &
-fa(j,lr2)*ztmp(j,noca+k)
end do
end do
do k = 1, nbf-noca
do j = 1, nbf-noca
wrk(k,1) = wrk(k,1)-fb(noca+j,noca+k)*ztmp(lr1,noca+j)
wrk(k,2) = wrk(k,2)-fb(noca+j,noca+k)*ztmp(lr2,noca+j)
end do
end do
wrk = wrk*0.5_dp
do k = 1, nbf-noca
do i = 1, noca-nocb
ij = ij+1
pmo(ij) = (e(noca+k)-e(nocb+i))*z(ij)+wrk(k,i)
end do
end do
deallocate(ztmp, wrk)
end subroutine sfrolhs