qp_plugins_scemama/devel/cc/curly_W.irp.f

BEGIN_PROVIDER [ double precision, cWoooo, (spin_occ_num,spin_occ_num,spin_occ_num,spin_occ_num) ]
 implicit none
 BEGIN_DOC
 ! Curly W in occ-occ-occ-occ block
 END_DOC
  integer                        :: i,j,m,n
  integer                        :: a,b,e,f

  cWoooo(:,:,:,:) = OOOO(:,:,:,:)

  do j=1,spin_occ_num
    do e=1,spin_vir_num
      do i=1,spin_occ_num
        do n=1,spin_occ_num
          do m=1,spin_occ_num
            cWoooo(m,n,i,j) = cWoooo(m,n,i,j) +                      &
                t1_cc(j,e)*OOOV(m,n,i,e) -                           &
                t1_cc(i,e)*OOOV(m,n,j,e)
          end do
        end do
      end do
    end do
  end do

  call dgemm('N','T',                                                &
      spin_occ_num*spin_occ_num, spin_occ_num*spin_occ_num,          &
      spin_vir_num*spin_vir_num,                                     &
      0.25d0, OOVV, spin_occ_num*spin_occ_num,                       &
      tau_cc, spin_occ_num*spin_occ_num,                             &
      1.d0, cWoooo, spin_occ_num*spin_occ_num)


END_PROVIDER


BEGIN_PROVIDER [ double precision, cWovvo, (spin_occ_num,spin_vir_num,spin_vir_num,spin_occ_num) ]
 implicit none
 BEGIN_DOC
 ! Curly W in occ-vir-vir-occ block
 END_DOC
  integer                        :: i,j,m,n
  integer                        :: a,b,e,f
  double precision               :: x


  cWovvo(:,:,:,:) = OVVO(:,:,:,:)

  call dgemm('N','T', &
    spin_occ_num*spin_vir_num*spin_vir_num, spin_occ_num, spin_vir_num, &
    1.d0, OVVV, spin_occ_num*spin_vir_num*spin_vir_num, &
    t1_cc, spin_occ_num, &
    1.d0, cWovvo, spin_occ_num*spin_vir_num*spin_vir_num)


  do j=1,spin_occ_num
    do e=1,spin_vir_num
      call dgemm('N','N', &
        spin_occ_num, spin_vir_num, spin_occ_num, &
        -1.d0, OOVO(1,1,e,j), spin_occ_num, &
        t1_cc, spin_occ_num, &
        1.d0, cWovvo(1,1,e,j), spin_occ_num)
    end do
  end do

  double precision, allocatable :: tmp(:,:,:)
  allocate ( tmp(spin_occ_num,spin_vir_num,spin_vir_num) )
  do j=1,spin_occ_num
    do f=1,spin_vir_num
      do b=1,spin_vir_num
        do n=1,spin_occ_num
          tmp(n,b,f) = - 0.5d0*t2_cc(j,n,f,b) - t1_cc(j,f)*t1_cc(n,b)
        enddo
      enddo
    enddo
    do f=1,spin_vir_num
      do e=1,spin_vir_num
        call dgemm('N','N', &
          spin_occ_num, spin_vir_num, spin_occ_num, &
          1.d0, OOVV(1,1,e,f), spin_occ_num, &
          tmp(1,1,f), spin_occ_num, &
          1.d0, cWovvo(1,1,e,j), spin_occ_num)
      enddo
    enddo
  enddo
  
END_PROVIDER

  
BEGIN_PROVIDER [ double precision, cWovvo_prime, (spin_occ_num,spin_vir_num,spin_vir_num,spin_occ_num) ]
 implicit none
 BEGIN_DOC
 ! Curly W in occ-vir-vir-occ block
 END_DOC
  integer                        :: m,b,e,j

  do j=1,spin_occ_num
    do b=1,spin_vir_num
      do e=1,spin_vir_num
        do m=1,spin_occ_num
          cWovvo_prime(m,e,b,j) = cWovvo(m,b,e,j)
        end do
      end do
    end do
  end do

  
END_PROVIDER

  
BEGIN_PROVIDER [ double precision, cWvvvv, (spin_vir_num,spin_vir_num,spin_vir_num,spin_vir_num) ]
 implicit none
 BEGIN_DOC
 ! Curly W in vir-vir-vir-vir block
 END_DOC
  integer                        :: i,j,m,n
  integer                        :: a,b,e,f
  double precision               :: x

  double precision, allocatable :: mat_A(:,:), mat_C(:,:)

  ! OMP PRIVATE(mat_A,mat_C,a,b,m,e,f) &
  ! OMP SHARED(spin_vir_num, spin_occ_num, t1_cc, cWvvvv, OVVV, VVVV)

  allocate (mat_A(spin_vir_num, spin_occ_num), mat_C(spin_vir_num,spin_vir_num))

  ! OMP DO
  do f=1,spin_vir_num
    do e=1,spin_vir_num
      do m=1,spin_occ_num
        do a=1,spin_vir_num
          mat_A(a,m) = OVVV(m,a,f,e)
        enddo
      enddo
      call dgemm('N','N',                                          &
          spin_vir_num, spin_vir_num, spin_occ_num,                &
          1.d0, mat_A, size(mat_A,1),                              &
          t1_cc, size(t1_cc,1),                                    &
          0.d0, mat_C, size(mat_C,1) )
      do b=1,spin_vir_num
        do a=1,spin_vir_num
          cWvvvv(a,b,e,f) = VVVV(a,b,e,f) - mat_C(a,b) + mat_C(b,a)
        enddo
      enddo
    end do
  end do
  ! OMP END DO

  deallocate (mat_A, mat_C)
  ! OMP END PARALLEL

  call dgemm('T','N', &
    spin_vir_num*spin_vir_num, spin_vir_num*spin_vir_num, &
    spin_occ_num*spin_occ_num, &
    0.25d0, tau_cc, spin_occ_num*spin_occ_num, &
    OOVV, spin_occ_num*spin_occ_num, &
    1.d0, cWvvvv, spin_vir_num*spin_vir_num)

END_PROVIDER