!***********************************************************************
! This file is part of OpenMolcas.                                     *
!                                                                      *
! OpenMolcas is free software; you can redistribute it and/or modify   *
! it under the terms of the GNU Lesser General Public License, v. 2.1. *
! OpenMolcas is distributed in the hope that it will be useful, but it *
! is provided "as is" and without any express or implied warranties.   *
! For more details see the full text of the license in the file        *
! LICENSE or in <http://www.gnu.org/licenses/>.                        *
!                                                                      *
! Copyright (C) 1990,1991, Roland Lindh                                *
!               1990, IBM                                              *
!***********************************************************************

!#define _DEBUGPRINT_
subroutine SphCar(Win,nab,nijx,Scrt,nScrt,Coeff1,n1,Tr1,Pr1,Coeff2,n2,Tr2,Pr2,Wout,mab)
!***********************************************************************
!                                                                      *
!  Object: to project an one-electrom matrix from spherical harmonics  *
!          to cartesians.                                              *
!                                                                      *
!          Matrix on input  AB,ij                                      *
!          Matrix on output ij,ab                                      *
!                                                                      *
! Called from: OneEl                                                   *
!                                                                      *
! Calling    : RecPrt                                                  *
!              DGEMM_   (ESSL)                                         *
!              DGeTMO   (ESSL)                                         *
!                                                                      *
!     Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA  *
!             February '90                                             *
!                                                                      *
!             Roland Lindh, Dept. of Theoretical Chemistry, University *
!             of Lund, SWEDEN                                          *
!             Modified spherical harmonics to cartesians October '91.  *
!***********************************************************************

use Index_Functions, only: nTri_Elem1
use Constants, only: Zero, One
use Definitions, only: wp, iwp

implicit none
integer(kind=iwp), intent(in) :: nab, nijx, nScrt, n1, n2, mab
real(kind=wp), intent(in) :: Win(nab*nijx), Coeff1(nTri_Elem1(n1),nTri_Elem1(n1)), Coeff2(nTri_Elem1(n2),nTri_Elem1(n2))
real(kind=wp), intent(out) :: Scrt(nScrt), Wout(mab*nijx)
logical(kind=iwp), intent(in) :: Tr1, Pr1, Tr2, Pr2
integer(kind=iwp) :: k1, k2, l1, l2

l1 = nTri_Elem1(n1)
k1 = l1
if (Pr1) k1 = 2*n1+1
l2 = nTri_Elem1(n2)
k2 = l2
if (Pr2) k2 = 2*n2+1
#ifdef _DEBUGPRINT_
call recprt(' Win',' ',Win,nab,nijx)
call recprt('Coeff1',' ',Coeff1,l1,l1)
call recprt('Coeff2',' ',Coeff2,l2,l2)
#endif

if (Tr1 .and. Tr2) then

  ! Starting with A,Bij transforming to Bij,a

  call DGEMM_('T','T',k2*nijx,l1,k1,One,Win,k1,Coeff1,l1,Zero,Scrt,k2*nijx)

  ! Transform B,ija to ij,ab

  call DGEMM_('T','T',nijx*l1,l2,k2,One,Scrt,k2,Coeff2,l2,Zero,Wout,nijx*l1)

else if (Tr2) then

  ! Transpose from aB,ij to B,ija

  call DGeTmO(Win,l1,l1,k2*nijx,Scrt,k2*nijx)

  ! Start transforming B,ija to ij,ab

  call DGEMM_('T','T',nijx*l1,l2,k2,One,Scrt,k2,Coeff2,l2,Zero,Wout,nijx*l1)
else

  ! Starting with A,bij transforming to a,bij

  call DGEMM_('N','N',l1,l2*nijx,k1,One,Coeff1,l1,Win,k1,Zero,Scrt,l1)

  ! Transpose to ij,ab

  call DGeTmO(Scrt,l1*l2,l1*l2,nijx,Wout,nijx)
end if

return

end subroutine SphCar
