!--------------------------------------------------------------------------------------------------!
!   CP2K: A general program to perform molecular dynamics simulations                              !
!   Copyright (C) 2000 - 2017  CP2K developers group                                               !
!--------------------------------------------------------------------------------------------------!

! **************************************************************************************************
!> \brief Calculation of the spherical harmonics and the corresponding orbital
!>      transformation matrices.
!> \par Literature
!>      H. B. Schlegel, M. J. Frisch, Int. J. Quantum Chem. 54, 83 (1995)
!> \par History
!>      - restructured and cleaned (20.05.2004,MK)
!> \author Matthias Krack (08.06.2000)
! **************************************************************************************************
MODULE orbital_transformation_matrices

   USE kinds,                           ONLY: dp,&
                                              dp_size,&
                                              int_size
   USE mathconstants,                   ONLY: dfac,&
                                              fac,&
                                              pi
   USE mathlib,                         ONLY: binomial
   USE orbital_pointers,                ONLY: co,&
                                              nco,&
                                              ncoset,&
                                              nso,&
                                              nsoset
   USE orbital_symbols,                 ONLY: cgf_symbol,&
                                              sgf_symbol
   USE termination,                     ONLY: stop_memory

!$ USE OMP_LIB,                         ONLY: omp_get_level

#include "../base/base_uses.f90"

   IMPLICIT NONE

   PRIVATE

   CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'orbital_transformation_matrices'

! **************************************************************************************************
   TYPE orbtramat_type
      REAL(KIND=dp), DIMENSION(:, :), POINTER :: c2s, slm, s2c
   END TYPE orbtramat_type

   REAL(KIND=dp), DIMENSION(:, :), ALLOCATABLE  :: c2s_tramat, s2c_tramat
   TYPE(orbtramat_type), DIMENSION(:), POINTER :: orbtramat

   INTEGER, SAVE :: current_maxl = -1

! *** Public variables ***

   PUBLIC :: orbtramat, c2s_tramat

! *** Public data types ***

! *** Public subroutines ***

   PUBLIC :: deallocate_spherical_harmonics, &
             init_spherical_harmonics

CONTAINS

! **************************************************************************************************
!> \brief  Allocate and initialize the orbital transformation matrices for
!>         the transformation and for the backtransformation of orbitals
!>         from the Cartesian representation to the spherical representation.
!> \param maxl ...
!> \date    20.05.2004
!> \author  MK
!> \version 1.0
! **************************************************************************************************
   SUBROUTINE create_spherical_harmonics(maxl)

      INTEGER, INTENT(IN)                                :: maxl

      CHARACTER(len=*), PARAMETER :: routineN = 'create_spherical_harmonics', &
         routineP = moduleN//':'//routineN

      INTEGER                                            :: expo, i, ic, ic1, ic2, is, istat, j, k, &
                                                            l, lx, lx1, lx2, ly, ly1, ly2, lz, &
                                                            lz1, lz2, m, ma, nc, ns
      REAL(KIND=dp)                                      :: s, s1, s2

!$    IF (omp_get_level() > 0) &
!$       CPABORT("create_spherical_harmonics is not thread-safe")

      IF (current_maxl > -1) THEN
         CALL cp_abort(__LOCATION__, &
                       "Spherical harmonics are already allocated. "// &
                       "Use the init routine for an update")
      END IF

      IF (maxl < 0) THEN
         CALL cp_abort(__LOCATION__, &
                       "A negative maximum angular momentum quantum "// &
                       "number is invalid")
      END IF

      ALLOCATE (orbtramat(0:maxl), STAT=istat)
      IF (istat /= 0) THEN
         CALL stop_memory(routineN, moduleN, __LINE__, &
                          "orbtramat", (maxl+1)*int_size)
      END IF
      nc = ncoset(maxl)
      ns = nsoset(maxl)
      ALLOCATE (c2s_tramat(ns, nc), s2c_tramat(ns, nc), STAT=istat)
      IF (istat /= 0) THEN
         CALL stop_memory(routineN, moduleN, __LINE__, &
                          "c2s_tramat, s2c_tramat", (2*ns*nc)*int_size)
      END IF
      c2s_tramat = 0.0_dp
      s2c_tramat = 0.0_dp

      DO l = 0, maxl

         nc = nco(l)
         ns = nso(l)

         ALLOCATE (orbtramat(l)%c2s(ns, nc), STAT=istat)
         IF (istat /= 0) THEN
            CALL stop_memory(routineN, moduleN, __LINE__, &
                             "orbtramat(l)%c2s", ns*nc*dp_size)
         END IF
         orbtramat(l)%c2s = 0.0_dp

         ALLOCATE (orbtramat(l)%slm(ns, nc), STAT=istat)
         IF (istat /= 0) THEN
            CALL stop_memory(routineN, moduleN, __LINE__, &
                             "orbtramat(l)%slm", ns*nc*dp_size)
         END IF
         orbtramat(l)%slm = 0.0_dp

         ALLOCATE (orbtramat(l)%s2c(ns, nc), STAT=istat)
         IF (istat /= 0) THEN
            CALL stop_memory(routineN, moduleN, __LINE__, &
                             "orbtramat(l)%s2c", ns*nc*dp_size)
         END IF
         orbtramat(l)%s2c = 0.0_dp

      END DO

!   *** Loop over all angular momentum quantum numbers l ***

      DO l = 0, maxl

!     *** Build the orbital transformation matrix for the     ***
!     *** transformation from Cartesian to spherical orbitals ***
!     *** (c2s, formula 15)                                   ***

         DO lx = 0, l
            DO ly = 0, l-lx
               lz = l-lx-ly
               ic = co(lx, ly, lz)
               DO m = -l, l
                  is = l+m+1
                  ma = ABS(m)
                  j = lx+ly-ma
                  IF ((j >= 0) .AND. (MODULO(j, 2) == 0)) THEN
                     j = j/2
                     s1 = 0.0_dp
                     DO i = 0, (l-ma)/2
                        s2 = 0.0_dp
                        DO k = 0, j
                           IF (((m < 0) .AND. (MODULO(ABS(ma-lx), 2) == 1)) .OR. &
                               ((m > 0) .AND. (MODULO(ABS(ma-lx), 2) == 0))) THEN
                              expo = (ma-lx+2*k)/2
                              s = (-1.0_dp)**expo*SQRT(2.0_dp)
                           ELSE IF ((m == 0) .AND. (MODULO(lx, 2) == 0)) THEN
                              expo = k-lx/2
                              s = (-1.0_dp)**expo
                           ELSE
                              s = 0.0_dp
                           END IF
                           s2 = s2+binomial(j, k)*binomial(ma, lx-2*k)*s
                        END DO
                        s1 = s1+binomial(l, i)*binomial(i, j)* &
                             (-1.0_dp)**i*fac(2*l-2*i)/fac(l-ma-2*i)*s2
                     END DO
                     orbtramat(l)%c2s(is, ic) = &
                        SQRT((fac(2*lx)*fac(2*ly)*fac(2*lz)*fac(l)*fac(l-ma))/ &
                             (fac(lx)*fac(ly)*fac(lz)*fac(2*l)*fac(l+ma)))*s1/ &
                        (2.0_dp**l*fac(l))
                  ELSE
                     orbtramat(l)%c2s(is, ic) = 0.0_dp
                  END IF
               END DO
            END DO
         END DO

!     *** Build the corresponding transformation matrix for the ***
!     *** transformation from spherical to Cartesian orbitals   ***
!     *** (s2c = s*TRANSPOSE(c2s), formulas 18 and 19)          ***

         DO lx1 = 0, l
            DO ly1 = 0, l-lx1
               lz1 = l-lx1-ly1
               ic1 = co(lx1, ly1, lz1)
               s1 = SQRT((fac(lx1)*fac(ly1)*fac(lz1))/ &
                         (fac(2*lx1)*fac(2*ly1)*fac(2*lz1)))
               DO lx2 = 0, l
                  DO ly2 = 0, l-lx2
                     lz2 = l-lx2-ly2
                     ic2 = co(lx2, ly2, lz2)
                     lx = lx1+lx2
                     ly = ly1+ly2
                     lz = lz1+lz2
                     IF ((MODULO(lx, 2) == 0) .AND. &
                         (MODULO(ly, 2) == 0) .AND. &
                         (MODULO(lz, 2) == 0)) THEN
                        s2 = SQRT((fac(lx2)*fac(ly2)*fac(lz2))/ &
                                  (fac(2*lx2)*fac(2*ly2)*fac(2*lz2)))
                        s = fac(lx)*fac(ly)*fac(lz)*s1*s2/ &
                            (fac(lx/2)*fac(ly/2)*fac(lz/2))
                        DO is = 1, nso(l)
                           orbtramat(l)%s2c(is, ic1) = orbtramat(l)%s2c(is, ic1)+ &
                                                       s*orbtramat(l)%c2s(is, ic2)
                        END DO
                     END IF
                  END DO
               END DO
            END DO
         END DO

!     *** Build up the real spherical harmonics ***

         s = SQRT(0.25_dp*dfac(2*l+1)/pi)

         DO lx = 0, l
            DO ly = 0, l-lx
               lz = l-lx-ly
               ic = co(lx, ly, lz)
               DO m = -l, l
                  is = l+m+1
!MK         s2 = (-1.0_dp)**m*s !-> alternative S(lm) definition
                  orbtramat(l)%slm(is, ic) = &
                     s*orbtramat(l)%c2s(is, ic)/ &
                     !MK           s2*orbtramat(l)%c2s(is,ic)/&
                     SQRT(dfac(2*lx-1)*dfac(2*ly-1)*dfac(2*lz-1))
               END DO
            END DO
         END DO

!     *** Build up one shot transformation ***
!     *** for unnormalized functions       ***
         nc = nco(l)
         ns = nso(l)
         lx1 = ncoset(l-1)+1
         ly1 = nsoset(l-1)+1
         lx2 = ncoset(l)
         ly2 = nsoset(l)
         s2c_tramat(ly1:ly2, lx1:lx2) = orbtramat(l)%s2c(1:ns, 1:nc)
         c2s_tramat(ly1:ly2, lx1:lx2) = orbtramat(l)%c2s(1:ns, 1:nc)

         s1 = 8.0_dp*pi*fac(l+1)/fac(2*l+2)
         DO lx = 0, l
            DO ly = 0, l-lx
               lz = l-lx-ly
               s2 = fac(2*lx)*fac(2*ly)*fac(2*lz)/(fac(lx)*fac(ly)*fac(lz))
               s = SQRT(s1*s2)
               ic = ncoset(l-1)+co(lx, ly, lz)
               DO m = -l, l
                  is = nsoset(l-1)+l+m+1
                  s2c_tramat(is, ic) = s2c_tramat(is, ic)*s
                  c2s_tramat(is, ic) = c2s_tramat(is, ic)/s
               END DO
            END DO
         END DO

      END DO

!   *** Save initialization status ***

      current_maxl = maxl

   END SUBROUTINE create_spherical_harmonics

! **************************************************************************************************
!> \brief   Deallocate the orbital transformation matrices.
!> \date    20.05.2004
!> \author  MK
!> \version 1.0
! **************************************************************************************************
   SUBROUTINE deallocate_spherical_harmonics()
      CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_spherical_harmonics', &
         routineP = moduleN//':'//routineN

      INTEGER                                            :: l

!$    IF (omp_get_level() > 0) &
!$       CPABORT("deallocate_spherical_harmonics is not thread-safe")

      IF (current_maxl > -1) THEN

         DO l = 0, SIZE(orbtramat, 1)-1

            DEALLOCATE (orbtramat(l)%c2s)

            DEALLOCATE (orbtramat(l)%slm)

            DEALLOCATE (orbtramat(l)%s2c)

         END DO

         DEALLOCATE (orbtramat)

         DEALLOCATE (c2s_tramat, s2c_tramat)

         current_maxl = -1

      END IF

   END SUBROUTINE deallocate_spherical_harmonics

! **************************************************************************************************
!> \brief  Initialize or update the orbital transformation matrices.
!> \param maxl ...
!> \param output_unit ...
!> \date     09.07.1999
!> \par Variables
!>      - maxl   : Maximum angular momentum quantum number
!> \author MK
!> \version 1.0
! **************************************************************************************************
   SUBROUTINE init_spherical_harmonics(maxl, output_unit)

      INTEGER, INTENT(IN)                                :: maxl
      INTEGER                                            :: output_unit

      CHARACTER(len=*), PARAMETER :: routineN = 'init_spherical_harmonics', &
         routineP = moduleN//':'//routineN

      CHARACTER(LEN=78)                                  :: headline
      INTEGER                                            :: l, nc, ns

!$    IF (omp_get_level() > 0) &
!$       CPABORT("init_spherical_harmonics is not thread-safe")

      IF (maxl < 0) THEN
         CALL cp_abort(__LOCATION__, &
                       "A negative maximum angular momentum quantum "// &
                       "number is invalid")
      END IF

      IF (maxl > current_maxl) THEN

         CALL deallocate_spherical_harmonics()
         CALL create_spherical_harmonics(maxl)

!     *** Print the spherical harmonics and   ***
!     *** the orbital transformation matrices ***
         IF (output_unit > 0) THEN

            DO l = 0, maxl

               nc = nco(l)
               ns = nso(l)

               headline = "SPHERICAL HARMONICS"
               CALL write_matrix(orbtramat(l)%slm, l, output_unit, headline)

               headline = "CARTESIAN ORBITAL TO SPHERICAL ORBITAL "// &
                          "TRANSFORMATION MATRIX"
               CALL write_matrix(orbtramat(l)%c2s, l, output_unit, headline)

               headline = "SPHERICAL ORBITAL TO CARTESIAN ORBITAL "// &
                          "TRANSFORMATION MATRIX"
               CALL write_matrix(orbtramat(l)%s2c, l, output_unit, headline)

            END DO

            WRITE (UNIT=output_unit, FMT="(A)") ""

         END IF

      END IF

   END SUBROUTINE init_spherical_harmonics

! **************************************************************************************************
!> \brief   Print a matrix to the logical unit "lunit".
!> \param matrix ...
!> \param l ...
!> \param lunit ...
!> \param headline ...
!> \date    07.06.2000
!> \par Variables
!>      - matrix  : Matrix to be printed.
!>      - l       : Angular momentum quantum number
!>      - lunit   : Logical unit number.
!>      - headline: Headline of the matrix.
!> \author  MK
!> \version 1.0
! **************************************************************************************************
   SUBROUTINE write_matrix(matrix, l, lunit, headline)

      REAL(KIND=dp), DIMENSION(:, :), POINTER            :: matrix
      INTEGER, INTENT(IN)                                :: l, lunit
      CHARACTER(LEN=*), INTENT(IN)                       :: headline

      CHARACTER(12)                                      :: symbol
      CHARACTER(LEN=78)                                  :: string
      INTEGER                                            :: from, i, ic, is, jc, lx, ly, lz, m, nc, &
                                                            to

!   *** Write headline ***

      WRITE (UNIT=lunit, FMT="(/,/,T2,A)") TRIM(headline)

!   *** Write the matrix in the defined format ***

      nc = nco(l)

      DO ic = 1, nc, 6
         from = ic
         to = MIN(nc, from+5)
         i = 1
         DO lx = l, 0, -1
            DO ly = l-lx, 0, -1
               lz = l-lx-ly
               jc = co(lx, ly, lz)
               IF ((jc >= from) .AND. (jc <= to)) THEN
                  symbol = cgf_symbol(1, (/lx, ly, lz/))
                  WRITE (UNIT=string(i:), FMT="(A)") TRIM(symbol(3:12))
                  i = i+12
               END IF
            END DO
         END DO
         WRITE (UNIT=lunit, FMT="(/,T13,A)") TRIM(string)
         symbol = ""
         DO m = -l, l
            is = l+m+1
            symbol = sgf_symbol(1, l, m)
            WRITE (UNIT=lunit, FMT="(T4,A4,6(1X,F11.6))") &
               symbol(3:6), (matrix(is, jc), jc=from, to)
         END DO
      END DO

   END SUBROUTINE write_matrix

END MODULE orbital_transformation_matrices
