subroutine sfropcal(pa, pb, ta, tb, z, &
noca, nocb)
use precision, only: dp
implicit none
real(kind=dp), intent(out), dimension(:,:) :: pa, pb
real(kind=dp), intent(in), dimension(:,:) :: ta, tb
real(kind=dp), intent(in), dimension(:) :: z
integer, intent(in) :: noca, nocb
integer :: i, j, k, ij, nbf
nbf = ubound(pa, 1)
! Alpha
pa = 0.0_dp
do j = 1, noca
do i = 1, noca
pa(i,j) = ta(i,j)
end do
end do
pb = 0.0_dp
do j = nocb+1, nbf
do i = nocb+1, nbf
pb(i,j) = tb(i-nocb,j-nocb)
end do
end do
! add Z contribution
! DOC-SOCC
ij = 0
do i = nocb+1, noca
do j = 1, nocb
ij = ij+1
pb(j,i) = pb(j,i)+z(ij)*0.5_dp
end do
end do
! DOC-VIRT
do k = noca+1, nbf
do j = 1, nocb
ij = ij+1
pa(j,k) = pa(j,k)+z(ij)*0.5_dp
pb(j,k) = pb(j,k)+z(ij)*0.5_dp
end do
end do
! SOCC-VIRT
do k = noca+1, nbf
do i = nocb+1, noca
ij = ij+1
pa(i,k) = pa(i,k)+z(ij)*0.5_dp
end do
end do
end subroutine sfropcal