module rabs_angular
!
!***** February 2012, wide *****
!-----------------------------------------------------------------------------------------------------------------------
! This module provides a set of procedures which support the analytic integration over angular coordinates or which are
! related to this integration. This includes the Wigner n-j symbols but also a set of other coefficients for closed- and
! open-shell SCF iterations and for the electron-electron interaction.
!-----------------------------------------------------------------------------------------------------------------------
   !
   use rabs_constant
   use rabs_dirac_orbital
   use rabs_functions_math
   use rabs_io_dialog
   use rabs_naglib
   implicit none
   private
   !
   public  :: angular_DF_Cabk
                 ! Calculates the C(abk) angular coefficient of the direct Coulomb term in the closed-shell SCF iteration
                 ! scheme.
   public  :: angular_DF_Dabk
                 ! Calculates the D(abk) angular coefficient of the exchange Coulomb term in the closed-shell SCF
                 ! iteration scheme.
   public  :: angular_E_beta_nu
                 ! Calculates the E_beta^nu(abL) angular coefficient as defined by Grant (1988) for the Gaunt interaction
                 ! and for other interactions.
   public  :: angular_nu
                 ! Calculates the nu_nu,L angular coefficient of the Gaunt interaction as defined by Grant and Pyper (1976).
   public ::  bipolar_spherical_Ylm
                 ! Returns the value of the bipolar spherical harmonic for angles theta1, phi1, theta2, phi2.
   public  :: cfp_coefficient
                 ! Returns a coefficient of fractional parentage by looking up an appropriate table.
   private :: cfp_three_half
                 ! Returns a coefficient of fractional parentage for equivalent electrons with j=3/2 by looking up an
                 ! appropriate table.
   private :: cfp_five_half
                 ! Returns a coefficient of fractional parentage for equivalent electrons with j=5/2 by looking up an
                 ! appropriate table.
   private :: cfp_seven_half
                 ! Returns a coefficient of fractional parentage for equivalent electrons with j=7/2 by looking up an
                 ! appropriate table.
   private :: cfp_dummy
                 ! Returns a coefficient of fractional parentage for 1 or 2 equivalent electrons with j > 7/2.
   public  :: CL_reduced_me
                 ! Calculates the reduced matrix element of the C^L tensor  <kapa || C^(L) || kapb>.
   public  :: CL_reduced_me_mod
                 ! Calculates the reduced matrix element of the C^L tensor  [kapa || C^(L) || kapb] due to
                 ! Erikas&Gediminas (2009).
   public  :: CL_reduced_me_hfs
                 ! Calculates the reduced matrix element of the C^L tensor  <kapa || C^(L) || kapb> due to the
                 ! definition in HFS.
   public  :: Clebsch_Gordan
                 ! Calculates the Clebsch-Gordan coefficient  <ja,ma,jb,mb;Jab,Mab>  by using the phase convention due
                 ! to Condon and Shortley.
   public  :: sigma_TtL_reduced_me
                 ! Calculates the reduced matrix element of the tensor  <kapa || sigma dot T_{tL} || kapb>.
   public  :: sigma_1mp_reduced_me
                 ! Calculates the (modified) reduced matrix element  [-kapa||sigma^1||kapb] due to Erikas&Gediminas (2009).
   public  :: sigma_1pm_reduced_me
                 ! Calculates the (modified) reduced matrix element  [kapa||sigma^1||-kapb] due to Erikas&Gediminas (2009).
   public  :: triangle
                 ! Calculates the tringular factor Delta(ja,jb,jc).
   public  :: wigner_3j_symbol
                 ! Calculates the value of a Wigner 3-j symbol for given quantum numbers.
   private :: wigner_6j_Delta
                 ! Calculates the value of the Delta(a,b,c) symbol for given quantum numbers.
   public  :: wigner_6j_symbol
                 ! Calculates the value of a Wigner 6-j symbol for given quantum numbers.
   public  :: wigner_6j_triangle
                 ! Calculate the triangular factors for 6j-symbol.
   public  :: wigner_9j_symbol
                 ! Calculates the value of a Wigner 9-j symbol for given quantum numbers.
   public  :: wigner_9j_triangle
                 ! Calculate the triangular factors for 9j-symbol.
   public  :: wigner_eckardt_geometry
                 ! Returns the "geometrical factor" from a complete matrix element owing to the Wigner-Eckardt theorem.
   public  :: wigner_rotation_D_matrix
                 ! Returns the value of the Wigner rotation matrix D^j_pq(alpha, beta, gamma).
   public  :: wigner_rotation_d_small
                 ! Returns the value of the Wigner rotation matrix d^j_pq(beta).
                 !
   integer, private :: ifail
   !
   ! Define some global variables to store the logarithmic Gamma function
   integer, parameter, private :: number_of_ln_gamma = 500
   logical, private            :: ln_gamma_not_initialized = .true.
   real(kind=dp), private      :: ln_gamma(number_of_ln_gamma)
   !
contains
   !
   function angular_DF_Cabk(kappa,kappa_p,k,q_p,equivalent)         result(Cabk)
   !--------------------------------------------------------------------------------------------------------------------
   ! Calculates the C(abk) angular coefficient of the direct Coulomb term in the DF energy functional within the
   ! configuration-average approach. See I. Lindgren and A. Rosen (1974) for more details. Use  equivalent = .true.
   ! if kappa and kappa_p arise from the same subshell and .false. otherwise. q_p is the occupation of the primed
   ! subshell (kappa_p). The parameter kappa is not needed within this procedure but is kept for similiarity with other
   ! procedures.
   !
   ! Calls: angular_momentum_j().
   !--------------------------------------------------------------------------------------------------------------------
      !
      integer, intent(in)  :: kappa, kappa_p, k, q_p
      logical, intent(in)  :: equivalent
      real(kind=dp)        :: Cabk
      !
      Cabk = kappa      ! kappa is not really needed for the calculation but kept for similiarity with other procedures
      if (k /= 0) then
         Cabk = zero
         return
      else
         Cabk = angular_momentum_j(kappa_p) + one
      end if
      !
      if (equivalent) then
         Cabk = Cabk * (q_p - one) / angular_momentum_j(kappa_p)
      else
         Cabk = Cabk * q_p / (angular_momentum_j(kappa_p) + one)
      end if
      !
   end function angular_DF_Cabk
   !
   !
   function angular_DF_Dabk(kappa,kappa_p,k,q_p,equivalent) result(Dabk)
   !--------------------------------------------------------------------------------------------------------------------
   ! Calculates the D(abk) angular coefficient of the exchange Coulomb term in the DF energy functional within the
   ! configuration-average approach. See I. Lindgren and A. Rosen (1974) for more details. Use  equivalent = .true. if
   ! kappa and kappa_p arise from the same subshell and .false. otherwise. q_p is the occupation of the primed
   ! subshell (kappa_p)
   !
   ! Calls: angular_momentum_j(), angular_momentum_l(), wigner_3j_symbol().
   !--------------------------------------------------------------------------------------------------------------------
      !
      integer, intent(in)  :: kappa, kappa_p, k, q_p
      logical, intent(in)  :: equivalent
      real(kind=dp)        :: Dabk
      !
      integer              :: l, l_p, j, j_p
      !
      l   = angular_momentum_l(kappa)
      l_p = angular_momentum_l(kappa_p)
      j   = angular_momentum_j(kappa)
      j_p = angular_momentum_j(kappa_p)
      !
      if (mod(l+l_p+k,2) == 1) then
         Dabk = zero
         return
      else
         Dabk = -(j_p + one) * wigner_3j_symbol(j,2*k,j_p,-1,0,1)**2
      end if
      !
      if (equivalent) then
         Dabk = Dabk * (q_p - one) / angular_momentum_j(kappa_p)
      else
         Dabk = Dabk * q_p / (angular_momentum_j(kappa_p) + one)
      end if
      !
   end function angular_DF_Dabk
   !
   !
   function angular_E_beta_nu(beta,nu,kappa,kappa_p,L)     result(value)
   !--------------------------------------------------------------------------------------------------------------------
   ! Calculates the E_beta^nu (kappa,kappa',L) angular coefficient of the electron--electron interaction as defined by
   ! I. P. Grant, in "Relativistic Atomic Structure Calculations" (1989), Eq.(66a-c).
   !--------------------------------------------------------------------------------------------------------------------
      !
      integer, intent(in)  :: beta, kappa, kappa_p, L, nu
      real(kind=dp)        :: value
      !
      if (rabs_use_stop   .and.  beta /= -1   .and.   beta /= 1) then
         stop "angular_E_beta_nu(): program stop A."
      end if
      !
      if (nu == L-1   .and.   L > 0) then
         value = (nu + one - beta*(kappa_p - kappa)) / sqrt( (nu+one)*(nu+nu+one) )
      else if (nu == L   .and.   L >= 0) then
         value = - beta*(kappa + kappa_p) / sqrt( (nu+one)*nu )
      else if (nu == L+1   .and.   L >= 0) then
         value = (-nu - beta*(kappa_p - kappa)) / sqrt( nu*(nu+nu+one) )
      else if (rabs_use_stop) then
         stop "angular_E_beta_nu(): program stop B."
      end if
      !
   end function angular_E_beta_nu
   !
   !
   function angular_nu(nu,L)                               result(value)
   !--------------------------------------------------------------------------------------------------------------------
   ! Calculates the nu_nu,L angular coefficient of the Gaunt interaction as defined by I. P. Grant and N. C. Pyper,
   ! J. Phy. B9 (1976) 761, Eq. (8).
   !--------------------------------------------------------------------------------------------------------------------
      !
      integer, intent(in)  :: nu, L
      real(kind=dp)        :: value
      !
      if (nu == L-1   .and.   L > 0) then
         value = - (L+one) / (L+l+one)
      else if (nu == L   .and.   L >= 0) then
         value = one
      else if (nu == L+1   .and.   L >= 0) then
         value = - L / (L+L+one)
      else if (rabs_use_stop) then
         stop "angular_nu(): program stop A."
      end if
      !
   end function angular_nu
   !
   !
   function bipolar_spherical_Ylm(l1,l2,L,M,theta1,phi1,theta2,phi2)       result(bipolar)
   !--------------------------------------------------------------------------------------------------------------------
   ! Returns the value of the bipolar spherical harmonic   {Y_l1 (theta1,phi1) otimes Y_l2 (theta2,phi2)}_LM
   ! for given angles theta1, phi1, theta2, and phi2.
   !
   ! Calls: spherical_Ylm()
   !--------------------------------------------------------------------------------------------------------------------
      !
      integer, intent(in)       :: l1, l2, L, M
      real(kind=dp), intent(in) :: theta1, phi1, theta2, phi2
      real(kind=dp)             :: bipolar
      !
      integer                   :: m1, m2
      real(kind=dp)             :: wa
      !
      bipolar = zero
      !
      do  m1 = -l1,l1
         do  m2 = -l2,l2
	    wa = Clebsch_Gordan(l1+l1,m1+m1,l2+l2,m2+m2,L+L,M+M)
	    if (abs(wa) > eps10) then
	       bipolar = bipolar + wa * spherical_Ylm(l1,m1,theta1,phi1) * spherical_Ylm(l2,m2,theta2,phi2)
	    end if
	 end do
      end do
      !
   end function bipolar_spherical_Ylm
   !
   !
   subroutine cfp_coefficient(lock,nel,ijd,ivd,iwd,ijp,ivp,iwp,coefp)
   !--------------------------------------------------------------------------------------------------------------------
   ! Selects a cfp coefficient from an appropriate table of fractional parentage  coefficients in jj-coupling. It has
   ! been taken from the GRASP package and slightly adopted to the format of the RABS program.
   !
   ! Input variables:
   !
   !   lock     : + or - (2*j + 1).
   !   nel      : number of equivalent electrons in shell.
   !   ijd/ijp  : total j of daughter/parent state.
   !   ivd/ivp  : seniority of daughter/parent states.
   !   iwd/iwp  : other quantum number (if needed).
   !
   ! Output variable:
   !
   !   coefp    : numerical result
   !
   ! This control routine does not check the input variables for consistency, except the trivial case of j = 1/2.
   ! All other checks are performed at a lower level. The package will return correct results for j = 3/2, 5/2, 7/2.
   ! Higher values of j return a value 1.0 if NEL = 1 or 2; otherwise 0 with an error signal.
   !--------------------------------------------------------------------------------------------------------------------
      !
      integer, intent(in)       :: lock, nel, ijd, ivd, iwd, ijp, ivp, iwp
      real(kind=dp), intent(out):: coefp
      !
      integer :: k
      !
      k = abs(lock) / 2
      !
      select case(k)
      case(1)
         write (*,1)
         stop "cfp_coefficient(): program stop A."
      case(2)
         call cfp_three_half(nel,ijd,ijp,coefp)
      case(3)
         call cfp_five_half (nel,ijd,ivd,ijp,ivp,coefp)
      case(4)
         call cfp_seven_half(nel,ijd,ivd,ijp,ivp,coefp)
      case(5:)
         call cfp_dummy(lock,nel,ijd,ivd,iwd,ijp,ivp,iwp,coefp)
      end select
      !
      1 format ("cfp_coefficient(): Unnecessary attempt to form a cfp for an electron with j = 1/2.")
      !
   end subroutine cfp_coefficient
   !
   !
   subroutine cfp_three_half(nel,ijd,ijp,coefp)
   !--------------------------------------------------------------------------------------------------------------------
   ! Table look-up for fractional parentage coefficients of  equivalent electrons with j = 3/2. See listing of CFP for
   ! argument list.
   !--------------------------------------------------------------------------------------------------------------------
      !
      integer, intent(in)       :: nel, ijd, ijp
      real(kind=dp), intent(out):: coefp
      !
      real(kind=dp), parameter :: c1 = 6.0_dp, c2 = 5.0_dp
      !
      if (nel <= 0   .or. nel > 4) goto 7
      !
      select case(nel)
      case(1)
         if (ijd /= 3   .or.   ijp /= 0) goto 7
         coefp = one
         return
      case(2)
         if (ijp /= 3) goto 7
         if (ijd == 0   .or.   ijd == 4) then
            coefp = one
            return
         end if
         goto 7
      case(3)
         if (ijd /= 3) goto 7
         if (ijp == 0) then
            coefp = sqrt(one/c1)
            return
         else if(ijp /= 4) then
            goto 7
         else
            coefp = -sqrt (c2/c1)
            return
         end if
      case(4)
         if (ijd /= 0   .or.   ijp /= 3) goto 7
         coefp = one
         return
      case(:0,5:)
         stop "cfp_three_half(): program stop A."
      end select
      !
    7 write (*,1) nel,ijd,ijp
      stop
      !
    1 format ("cfp3: error in trying to compute a cfp for a state with ",1i2," electrons with j = 3/2;",  &
            / " ijd = ",1i2,", ijp = ",1i2,".")
      !
   end subroutine cfp_three_half
   !
   !
   subroutine cfp_five_half(nel,ijd,ivd,ijp,ivp,coefp)
   !--------------------------------------------------------------------------------------------------------------------
   ! Table look-up for fractional parentage coefficients of  equivalent electrons with j = 3/2. See listing of CFP for
   ! argument list.
   !--------------------------------------------------------------------------------------------------------------------
      !
      integer, intent(in)       :: nel, ijd, ivd, ijp, ivp
      real(kind=dp), intent(out):: coefp
      !
      integer       :: ij1, iv1, ij2, iv2, is, k, kd, kp, n
      real(kind=dp) :: denom, dnel, fact
      !
      ! Set 1.0 tables of data
      !
      integer, dimension(3)    :: norm = (/  18,7,14 /)
      integer, dimension(3,3)  :: ij   = reshape(source=(/  5,0,5,0,4,3,0,8,9 /),   shape=(/3,3/)), &
                                  iv   = reshape(source=(/  1,0,1,8,2,3,8,2,3 /),   shape=(/3,3/)), &
                                  num3 = reshape(source=(/ -4,0,0,5,-5,3,9,2,-11/), shape=(/3,3/))
      !
      real(kind=dp), parameter :: d0 = 0.0_dp, d1 = 1.0_dp, d7 = 7.0_dp
      !
      ! 2.0 Locate entry in cfp table.
      if (nel <= 0) goto 12
      if (nel >= 4) goto 1
      !
      n = nel
      ij1 = ijd;   iv1 = ivd;   ij2 = ijp;   iv2 = ivp;   goto 2
      !
    1 if (nel > 6) goto 12
      n = 7 - nel
      ij1 = ijp;   iv1 = ivp;   ij2 = ijd;   iv2 = ivd
      !
      ! 2.1 Find 'daughter' index.
    2 k = 0
    3 k = k+1
      if (k > 3) then
         print *, "Find 'daughter' index.n = ",n
         goto 12
      end if
      if (ij(n,k) /= ij1) goto 3
      if (iv(n,k) /= iv1) goto 3
      kd = k
      !
      ! 2.2 Find 'parent' index.
      if (n /= 1) goto 4
      if (iv2 /= 0) goto 12
      if (ij2 == 0) goto 6
      goto 12
    4 k = 0
    5 k = k+1
      if (k > 3) then
         print *, "Find 'parent' index."
         goto 12
      end if
      if (ij(n-1,k) /= ij2) goto 5
      if (iv(n-1,k) /= iv2) goto 5
      kp = k
      !
      ! 3.0 compute coefficients.
      ! 3.1 table look-up
      !!x goto (6,6,7), n
      select case (n)
      case(1,2)
        goto 6
      case(3)
        goto 7
      end select
      !
    6 coefp = d1;   goto 10
    7 continue
      coefp = dble (num3(kd,kp))
      denom = dble (norm(kd))
      if (coefp < zero) then  ! Arithmetic if (coefp) 9,11,8 is obsolet
         goto 9
      else if (coefp == zero) then
         goto 11
      else
         goto 8
      end if
    8 continue
      coefp = sqrt (coefp/denom)
      goto 10
    9 continue
      coefp = -sqrt(-coefp/denom)
      !
      ! 3.2 insert additional factors for hole states
   10 if (nel <= 3) goto 11
      dnel  = nel
      fact  = ((d7-dnel)/dnel) * (d1+dble(ijp)) / (d1+dble(ijd))
      coefp = coefp * sqrt(fact)
      is    = abs((ijd-ijp-ivd+ivp)/2)
      if (mod(is,2) == 0) goto 11
      coefp = -coefp
   11 return
      !
      ! 4.0 fault mode section.
   12 coefp = d0
      write (*,15) nel, ijd, ivd, ijp, ivp
      !x stop
      !
   15 format ("cfp_five_half(): Error in trying to compute a cfp for a state with ",1i2," electrons with j = 5/2;",  &
            / " ijd = ",1i2,", ivd = ",1i2,", ijp = ",1i2,", ivp = ",1i2,".")
      !
   end subroutine cfp_five_half
   !
   !
   subroutine cfp_seven_half(nel,ijd,ivd,ijp,ivp,coefp)
   !--------------------------------------------------------------------------------------------------------------------
   ! Table look-up for fractional parentage coefficients of  equivalent electrons with j = 7/2. See listing of CFP for
   ! argument list.
   !--------------------------------------------------------------------------------------------------------------------
      !
      integer, intent(in)       :: nel, ijd, ivd, ijp, ivp
      real(kind=dp), intent(out):: coefp
      !
      integer                   :: ij1, iv1, ij2, iv2, is, k, kd, kp, n
      real(kind=dp)             :: denom, dnel, fact
      !
      ! Set 1.0 tables of data
      !
      integer, dimension(4,8)  ::   ij   = reshape(source=(/  7,0,7,0,0,4,3,4,0,8,5,8,0,12,9,12,0,0,   &
                                                             11,4,0,0,15,8,0,0,0,10,0,0,0,16  /),   shape=(/4,8/)), &
                                    iv   = reshape(source=(/  1,0,1,0,10,2,3,2,10,2,3,2,10,2,3,2,10,   &
                                                             10,3,4,10,10,3,4,10,10,10,4,10,10,10,4 /), shape=(/4,8/))
      integer, dimension(6,4)  ::   num3 = reshape(source=(/  9,0,0,0,0,0,-5,3,121,143,-55,0,-9,-11,   &
                                                             12,-900,39,5,-13,0,-65,343,104,-17  /),  shape=(/6,4/))
      integer, dimension(6)    ::  norm3 = (/  36,14,198,1386,198,22  /)
      integer, dimension(8,6)  ::  num4  = reshape(source=(/  1,280,308,1144,0,0,0,0,0,54,-121,0,-968, &
                                                              169,462,0,0,-231,-14,195,-77,2366,-343,0,0,-65,250,     &
                                                             -245,-1755,90,-945,140,0,-210,91,624,280,2275,650,      &
                                                              234,0,0,140,-1224,0,-560,680,627 /),  shape=(/8,6/))
      integer, dimension(8)    ::  norm4 = (/1,840,924,3432,3080,5460,3080,1001/)
      !
      real(kind=dp), parameter :: d0 = 0.0_dp, d1 = 1.0_dp, d9 = 9.0_dp
      !
      ! 2.0 locate entry in cfp table.
      if (nel <= 0) goto 14
      if (nel >= 5) goto 1
      !
      n = nel
      ij1 = ijd;   iv1 = ivd;   ij2 = ijp;   iv2 = ivp;   goto 2
    1 if (nel > 8) goto 14
      n = 9-nel
      ij1 = ijp;   iv1 = ivp;   ij2 = ijd;   iv2 = ivd
      !
      ! 2.1 find 'daughter' index.
    2 k = 0
    3 k = k+1
      if (k > 8) goto 14
      if (ij(n,k) /= ij1) goto 3
      if (iv(n,k) /= iv1) goto 3
      kd = k
      !
      ! 2.2 find 'parent' index.
      if (n /= 1) goto 4
      if (iv2 /= 0) goto 14
      if (ij2 == 0) goto 6
      goto 14
    4 k = 0
    5 k = k+1
      if (k > 8) goto 14
      if (ij(n-1,k) /= ij2) goto 5
      if (iv(n-1,k) /= iv2) goto 5
      kp = k
      !
      ! 3.0 compute coefficients.
      ! 3.1 table look-up
      !!x goto (6,6,7,11), n
      select case (n)
      case(1,2)
        goto 6
      case(3)
        goto 7
      case(4)
         goto 11
      end select
      !
    6 coefp = d1;   goto 12
    7 continue
      coefp = dble (num3(kd,kp));   denom = dble (norm3(kd))
    8 if (coefp < zero) then  ! Arithmetic if (coefp) 10,13,9 is obsolet
         goto 10
      else if (coefp == zero) then
         goto 13
      else
         goto 9
      end if
    9 continue
      coefp = sqrt(coefp/denom);     goto 12
   10 continue
      coefp = -sqrt(-coefp/denom);   goto 12
   11 continue
      coefp = dble (num4(kd,kp));    denom = dble (norm4(kd));   goto 8
      !
      ! 3.2 insert additional factors for hole states
   12 if (nel <= 4) goto 13
      dnel  = dble (nel)
      fact  = ((d9-dnel)/dnel) * (d1+dble(ijp)) / (d1+dble(ijd))
      coefp = coefp * sqrt(fact)
      is = abs((ijd-ijp-ivd+ivp)/2-3)
      if (mod(is,2) == 0) goto 13
      coefp = -coefp
   13 return
      !
      ! 4.0 fault mode section.
   14 write (*,15) nel, ijd, ivd, ijp, ivp
      stop
      !
   15 format ("cfp7: error in trying to compute a cfp for a state with ',1i2,' electrons with j = 7/2;",   &
            / " ijd = ",1i2,", ivd = ",1i2,  ", ijp = ",1i2,", ivp = ",1i2,".")
      !
   end subroutine cfp_seven_half
   !
   !
   subroutine cfp_dummy(lock,nel,ijd,ivd,iwd,ijp,ivp,iwp,coefp)
   !--------------------------------------------------------------------------------------------------------------------
   ! This is a dummy subroutine. It returns correct values for 1 or 2 particle or single hole states, and signals an
   ! error otherwise.
   !--------------------------------------------------------------------------------------------------------------------
      !
      integer, intent(in)       :: lock, nel, ijd, ivd, iwd, ijp, ivp, iwp
      real(kind=dp), intent(out):: coefp
      !
      integer :: locj
      !
      if (nel == 1   .or.   nel == 2   .or.   nel == abs(lock)) then
         coefp = one
      else
         if (ijd == 99    .and.   ijp == 99   .and. &
             ivd == iwd   .and. ivp == iwp)   then
            ! Just to avoid warnings because of unused arguments
            print *, " "
         end if
         !
         locj = abs(lock) - 1
         write (*,1) locj
         stop
      end if
      !
      1 format ("cfp_dummy(): Inadmissable attempt to obtain a cfp for a state of a shell with j = ",1i2,"/2;",  &
              / " new subprogram required.")
      !
   end subroutine cfp_dummy
   !
   !
   function CL_reduced_me(kapa,L,kapb)                     result(redme)
   !--------------------------------------------------------------------------------------------------------------------
   ! Calculates the reduced matrix element of the C^L spherical tensor  <kapa || C^(L) || kapb>.
   !
   ! Calls: angular_momentum_j(), angular_momentum_l(), wigner_3j_symbol().
   !--------------------------------------------------------------------------------------------------------------------
      !
      integer, intent(in) :: kapa, kapb, L
      real(kind=dp)       :: redme
      !
      integer :: ja, jb, la, lb
      !
      redme = zero
      !
      ja = angular_momentum_j(kapa);   jb = angular_momentum_j(kapb)
      la = angular_momentum_l(kapa);   lb = angular_momentum_l(kapb)
      !
      if (rabs_use_stop   .and.   mod(ja+1,2) /= 0) then
         stop "CL_reduced_me(): program stop A."
      end if
      !
      redme = ((-1)**((ja+1)/2)) * sqrt( (ja+one)*(jb+one) ) * wigner_3j_symbol(ja,L+L,jb,1,0,-1)
      !
   end function CL_reduced_me
   !
   !
   function CL_reduced_me_mod(kapa,L,kapb)                  result(redme)
   !--------------------------------------------------------------------------------------------------------------------
   ! Calculates the modified form [kapa || C^(L) || kapb] of the reduced matrix element of the C^L spherical tensor
   ! <kapa || C^(L) || kapb> due to Erikas&Gediminas (2009).
   !
   ! Calls: angular_momentum_j(), angular_momentum_l(), wigner_3j_symbol().
   !--------------------------------------------------------------------------------------------------------------------
      !
      integer, intent(in) :: kapa, kapb, L
      real(kind=dp)       :: redme
      !
      integer             :: ja, jb, la, lb
      !
      redme = zero
      !
      ja = angular_momentum_j(kapa);   jb = angular_momentum_j(kapb)
      la = angular_momentum_l(kapa);   lb = angular_momentum_l(kapb)
      !
      if (rabs_use_stop   .and.   mod(ja+1,2) /= 0) then
         stop "CL_reduced_me_mod(): program stop A."
      end if
      !
      ! Implement the parity selection
      if (mod(la+L+lb,2) /= 0) then
         print *, "CL_reduced_me_mod(): parity rule requests pi(...) = 0."
         return
      end if
      !
      redme = ((-1)**((ja+1)/2)) * sqrt( (jb+one) ) * wigner_3j_symbol(ja,L+L,jb,1,0,-1)
      !
   end function CL_reduced_me_mod
   !
   !
   function CL_reduced_me_hfs(kapa,L,kapb)                     result(redme)
   !--------------------------------------------------------------------------------------------------------------------
   ! Calculates the reduced matrix element of the C^L spherical tensor  <kapa || C^(L) || kapb>   due to the definition
   ! in the HFS component.
   !
   ! Calls: angular_momentum_j(), angular_momentum_l(), wigner_3j_symbol().
   !--------------------------------------------------------------------------------------------------------------------
      !
      integer, intent(in) :: kapa, kapb, L
      real(kind=dp)       :: redme
      !
      integer :: ja, jb, la, lb
      !
      redme = zero
      !
      ja = angular_momentum_j(kapa);   jb = angular_momentum_j(kapb)
      la = angular_momentum_l(kapa);   lb = angular_momentum_l(kapb)
      !
      if (rabs_use_stop   .and.   mod(jb+L+L+1,2) /= 0) then
         stop "CL_reduced_me_hfs(): program stop A."
      end if
      !
      if (mod(la+L+lb,2) == 0) then
         redme = ((-1)**((jb-L-L-1)/2)) * sqrt( (jb+one) ) * wigner_3j_symbol(ja,jb,L+L,1,-1,0)
      else
         redme = zero
      end if
      !
   end function CL_reduced_me_hfs
   !
   !
   function Clebsch_Gordan(ja,ma,jb,mb,Jab,Mab)               result(CG)
   !--------------------------------------------------------------------------------------------------------------------
   ! Calculates the Clebsch-Gordan coefficient   <ja',ma',jb',mb';Jab',Mab'>   by using the phase convention due to
   ! Condon and Shortley; the dummy arguments of this procedure are the double of the actual angular momentum quantum
   ! numbers, i.e. ja = ja' + ja', ma = ma' + ma', ...
   !
   ! Calls: wigner_3j_symbol().
   !--------------------------------------------------------------------------------------------------------------------
      !
      integer, intent(in) :: ja, jb, Jab, ma, mb, Mab
      real(kind=dp)       :: CG
      !
      CG = zero
      !
      if (rabs_use_stop   .and.   mod(ja-jb+Mab,2) /= 0) then
         stop "Clebsch_Gordan(): program stop A."
      end if
      !
      CG = ((-1)**((ja-jb+Mab)/2)) * sqrt( (Jab+one) ) * wigner_3j_symbol(ja,jb,Jab,ma,mb,-Mab)
      !
   end function Clebsch_Gordan
   !
   !
   function sigma_TtL_reduced_me(kapa,L,t,kapb)              result(redme)
   !--------------------------------------------------------------------------------------------------------------------
   ! Calculates the reduced matrix element of the C^L spherical tensor  <kapa || sigma dot T_{tL} || kapb>.
   !
   ! Calls: angular_momentum_j(), angular_momentum_l(), wigner_3j_symbol().
   !--------------------------------------------------------------------------------------------------------------------
      !
      integer, intent(in) :: kapa, kapb, L, t
      real(kind=dp)       :: redme
      !
      redme = zero
      !
      if (L == t + 1) then
         redme = sqrt( (t+one)/(two*two*pi) ) * (one + (kapa+kapb)/(t+one)) * CL_reduced_me(-kapa,t,kapb)
      else if (L == t) then
         redme = sqrt( (t+t+one)/(two*two*pi*t*(t+one)) ) * (kapb-kapa) * CL_reduced_me(kapa,t,kapb)
      else if (L == t - 1) then
         redme = sqrt( t/(two*two*pi) ) * (-one + (kapa+kapb)/t ) * CL_reduced_me(-kapa,t,kapb)
      else
         stop "sigma_TtL_reduced_me(): program stop A."
      end if
      !
   end function sigma_TtL_reduced_me
   !
   !
   function sigma_1mp_reduced_me(kapa,kapb)                 result(redme)
   !--------------------------------------------------------------------------------------------------------------------
   ! Calculates the (modified) reduced matrix element of the sigma^1 spherical tensor [-kapa||sigma^1||kapb] due to
   ! Erikas&Gediminas (2009). Note that kapa must be given without the minus sign.
   !
   ! Calls: angular_momentum_j(), angular_momentum_l(), wigner_3j_symbol().
   !--------------------------------------------------------------------------------------------------------------------
      !
      integer, intent(in) :: kapa, kapb
      real(kind=dp)       :: redme
      !
      integer :: ja, jb, la, lb
      !
      redme = zero
      !
      ja = angular_momentum_j(kapa);   jb = angular_momentum_j(kapb)
      la = angular_momentum_l(kapa);   lb = angular_momentum_l(kapb)
      !
      redme = (  Clebsch_Gordan(lb+lb,0,1,1,ja,1)  * Clebsch_Gordan(lb+lb,0,1,1,jb,1)                                  &
	       - Clebsch_Gordan(lb+lb,2,1,-1,ja,1) * Clebsch_Gordan(lb+lb,2,1,-1,jb,1) ) / Clebsch_Gordan(jb,1,2,0,ja,1)
      !
   end function sigma_1mp_reduced_me
   !
   !
   function sigma_1pm_reduced_me(kapa,kapb)                 result(redme)
   !--------------------------------------------------------------------------------------------------------------------
   ! Calculates the (modified) reduced matrix element of the sigma^1 spherical tensor [kapa||sigma^1||-kapb] due to
   ! Erikas&Gediminas (2009). Note that kapb must be given without the minus sign.
   !
   ! Calls: angular_momentum_j(), angular_momentum_l(), wigner_3j_symbol().
   !--------------------------------------------------------------------------------------------------------------------
      !
      integer, intent(in) :: kapa, kapb
      real(kind=dp)       :: redme
      !
      integer :: ja, jb, la, lb
      !
      redme = zero
      !
      ja = angular_momentum_j(kapa);   jb = angular_momentum_j(kapb)
      la = angular_momentum_l(kapa);   lb = angular_momentum_l(kapb)
      !
      redme = (  Clebsch_Gordan(la+la,0,1,1,ja,1)  * Clebsch_Gordan(la+la,0,1,1,jb,1)                                  &
	       - Clebsch_Gordan(la+la,2,1,-1,ja,1) * Clebsch_Gordan(la+la,2,1,-1,jb,1) )  / Clebsch_Gordan(jb,1,2,0,ja,1)
      !
   end function sigma_1pm_reduced_me
   !
   !
   function triangle(i2a,i2b,i2c)                          result(Delta)
   !--------------------------------------------------------------------------------------------------------------------
   ! Calculates the tringular factor Delta(ja,jb,jc). The arguments in this integer function are i2a = 2*ja+1, ...
   ! The result is 0 if the triangular condition failes and 1 otherwise.
   !--------------------------------------------------------------------------------------------------------------------
      !
      integer, intent(in)  :: i2a, i2b, i2c
      integer              :: Delta, i
      !
      i = i2b - i2c
      if (i2a >= abs(i) + 1  .and.   i2a <= i2b + i2c - 1) then
         Delta = 1
      else
         Delta = 0
      end if
      !
   end function triangle
   !
   !
   function wigner_3j_symbol(ja,jb,jc,ma,mb,mc)              result(w3j)
   !--------------------------------------------------------------------------------------------------------------------
   ! Calculates the Wigner 3-j symbol by its algebraic formulae as displayed in many texts on the theory of angular
   ! momentum (see R. D. Cowan, The Theory of Atomic Structure and Spectra;  University of California Press, 1981, p. 142).
   ! The integer arguments ja, ... of this function must be the double of the corresponding quantum numbers in the 3-j
   ! symbol, i.e. jk = jk' + jk', mk = mk' + mk' in
   !
   !                       (  ja'   jb'   jc'  )
   !                       (                   )
   !                       (  ma'   mb'   mc'  )
   !
   ! Calls:  nag_s14aaf() [from NAG], triangle().
   !--------------------------------------------------------------------------------------------------------------------
      !
      integer, intent(in)      :: ja, jb, jc, ma, mb, mc
      real(kind=dp)            :: w3j
      !
      integer                  :: i, k, kmin, kmax
      integer, dimension(1:15) :: ik
      real(kind=qp)            :: delta, qsum, sumk
      !
      ! Test the triangular condition and that for magnetic quantum numbers
      !
      if (ma+mb+mc /= 0) then
         w3j = zero
	 return
      else if (triangle(ja+1,jb+1,jc+1) == 0) then
         w3j = zero
	 return
      else if (abs(ma) > ja  .or.  abs(mb) > jb  .or.  abs(mc) > jc) then
         w3j = zero
	 return
      else if (rabs_use_stop                 .and. &
              (mod(ma+ja+ja,2) /= mod(ja,2)  .or.  mod(mb+jb+jb,2) /= mod(jb,2)  .or.  mod(mc+jc+jc,2) /= mod(jc,2)) ) then
         stop "wigner_3j_symbol(): program stop A."
      endif
      !
      !
      if (ja > 75 .or. jb > 75 .or. jc > 75)  then
         call set_warning("modified wigner_3j_symbol(), November 2010; arbitrary value")
         print *, "modified wigner_3j_symbol(), November 2010"
         w3j = one  ! arbitrary value
	 return
      end if
      !
      !
      ik(1)  =  ja + jb - jc;   ik(2)  =  ja - jb + jc
      ik(3)  = -ja + jb + jc;   ik(4)  =  ja + jb + jc + two
      !
      ik(5)  =  ja - ma;   ik(6)  =  ja + ma;   ik(7)  =  jb - mb
      ik(8)  =  jb + mb;   ik(9)  =  jc - mc;   ik(10) =  jc + mc
      !
      ik(11) =  jb - jc - ma;   ik(12) =  ja - jc + mb
      ik(13) =  jc - jb + ma;   ik(14) =  ja - jb - mc
      !
      do  i = 1,14
	 if (rabs_use_stop   .and.   mod(ik(i),2) == 1) then
            stop "wigner_3j_symbol(): program stop B."
	 end if
	 ik(i) = ik(i) / 2
      end do
      !
      ! Calculate the 3-j delta factor
      if (rabs_use_naglib)  then
         delta =   1.0_dp * nag_s14aaf(ik(1)+one,ifail) * nag_s14aaf(ik(2)+one,ifail) &
                          * nag_s14aaf(ik(3)+one,ifail) * nag_s14aaf(ik(5)+one,ifail) &
                          * nag_s14aaf(ik(6)+one,ifail) * nag_s14aaf(ik(7)+one,ifail) &
                          * nag_s14aaf(ik(8)+one,ifail) * nag_s14aaf(ik(9)+one,ifail) &
                          * nag_s14aaf(ik(10)+one,ifail) / nag_s14aaf(ik(4)+one,ifail)
      else
         delta =   1.0_dp * factorial_dp(ik(1))  * factorial_dp(ik(2)) * factorial_dp(ik(3))  * factorial_dp(ik(5)) &
                          * factorial_dp(ik(6))  * factorial_dp(ik(7)) * factorial_dp(ik(8))  * factorial_dp(ik(9)) &
                          * factorial_dp(ik(10)) / factorial_dp(ik(4))
      end if
      !
      ! Find out the intervall of summation  k  and sum up
      kmin = max(0,ik(11),ik(12))
      kmax = min(ik(1),ik(5),ik(8))
      !
      qsum = 0.0_dp
      do  k = kmin,kmax
         if (rabs_use_naglib)  then
	    sumk = 1.0_dp * &
	           nag_s14aaf(k+one,ifail)        * nag_s14aaf(ik(1)-k+one,ifail) &
	         * nag_s14aaf(ik(5)-k+one,ifail)  * nag_s14aaf(ik(8)-k+one,ifail) &
	         * nag_s14aaf(ik(13)+k+one,ifail) * nag_s14aaf(k-ik(12)+one,ifail)
         else
	    sumk = 1.0_dp * factorial_dp(k)        * factorial_dp(ik(1)-k)  * factorial_dp(ik(5)-k)  &
                          * factorial_dp(ik(8)-k)  * factorial_dp(ik(13)+k) * factorial_dp(k-ik(12))
         end if
	 sumk = 1.0_dp / sumk
	 if (mod(k,2) == 0) then
	    qsum = qsum + sumk
	 else
	    qsum = qsum - sumk
	 end if
      end do
      !
      if (mod(ik(14),2) /= 0 ) then
	 w3j = - sqrt(delta) * qsum
      else
	 w3j = sqrt(delta) * qsum
      end if
      !
      !! print *, "ja,jb,jc,ma,mb,mc,w3j = ",ja,"/2 ",jb,"/2 ",jc,"/2 ", &
      !!                                     ma,"/2 ",mb,"/2 ",mc,"/2 ",w3j
      !
   end function wigner_3j_symbol
   !
   !
   function wigner_6j_Delta(a,b,c)                         result(Delta)
   !--------------------------------------------------------------------------------------------------------------------
   ! Calculates the Delta factor of three angular momenta a', b', c' as given in R. D. Cowan, "The Theory of Atomic
   ! Structure and Spectra", University of California Press, Berkeley, Los Angeles, London, 1981, Eq. (5.24). It is
   ! assumed that a, b, c represent the double of angular momenta (i.e. a = a' + a', ...) and that they fulfill the
   ! triangular condition triangle(a+1,b+1,c+1) = 1.
   !--------------------------------------------------------------------------------------------------------------------
      !
      integer, intent(in) :: a, b, c
      real(kind=dp)       :: Delta
      !
      if (rabs_use_stop) then
      if (mod(a+b-c,2)  /= 0  .or.  mod(a-b+c,2)   /= 0    .or.  mod(-a+b+c,2) /= 0  .or.  mod(a+b+c+2,2) /= 0  ) then
         print *, "a, b, c = ", a, b, c
         stop "wigner_6j_Delta(): program stop A."
      else if ((a+b-c)/2 < 0  .or.  (a-b+c)/2 < 0  .or.  (-a+b+c)/2 < 0  .or.  (a+b+c+2)/2 < 0) then
         print *, "a, b, c = ", a, b, c
         stop "wigner_6j_Delta(): program stop B."
      end if
      end if
      !
      if (rabs_use_naglib)  then
         Delta = nag_s14aaf((a+b-c)/2+one,ifail)  * nag_s14aaf((a-b+c)/2+one,ifail) * &
                 nag_s14aaf((-a+b+c)/2+one,ifail) / nag_s14aaf((a+b+c+2)/2+one,ifail)
      else
         Delta = factorial((a+b-c)/2)  * factorial((a-b+c)/2) * factorial((-a+b+c)/2) / factorial((a+b+c+2)/2)
      end if
      Delta = sqrt(Delta)
      !
   end function wigner_6j_Delta
   !
   !
   function wigner_6j_symbol(j1,j2,j3,l1,l2,l3,no_triangles) result(w6j)
   !--------------------------------------------------------------------------------------------------------------------
   ! Calculates the numerical value of a 6j-symbol (given in w6j) using the algebraic formulae in R.D. Cowan,
   ! "The Theory of Atomic Structure and Spectra", University of California Press, Berkeley, Los Angeles, London,
   ! 1981, Eq. (5.23). A straightforward numerical evaluation is performed. The integer arguments ja, ... of this
   ! function must be the double of the corresponding quantum numbers in the 6-j symbol, i.e. jk = jk' + jk' > in
   !
   !                       (  j1'   j2'   j3'  )
   !                      {(                   )}
   !                       (  l1'   l2'   l3'  )
   !
   ! Calls:  triangle().
   !--------------------------------------------------------------------------------------------------------------------
      !
      integer, intent(in)           :: j1, j2, j3, l1, l2, l3
      logical, intent(in), optional :: no_triangles
      real(kind=dp)                 :: w6j, x
      !
      integer                       :: n1, n2, n3, n4, n5, n6, n7, k, kmin, kmax, icount, ki
      !
      if (ln_gamma_not_initialized) then
         ln_gamma(1) = one;   ln_gamma(2) = one;   x = two
         do k = 3, 30
            ln_gamma(k) = ln_gamma(k-1) * x;   x = x + one
         end do
         !
         do k = 1, 30
            ln_gamma(k) = log(ln_gamma(k))
         end do
         x = three * ten
         do k = 31, number_of_ln_gamma
            ln_gamma(k) = ln_gamma(k-1) + log(x);   x = x + one
         end do
         ln_gamma_not_initialized = .false.
      end if
      !
      w6j = zero
      !
      if (present(no_triangles)) then
         if (no_triangles) goto 1
      end if
      if (triangle(j1+1,j2+1,j3+1) == 0  .or.  triangle(j1+1,l2+1,l3+1) == 0  .or. triangle(l1+1,j2+1,l3+1) == 0  .or. &
          triangle(l1+1,l2+1,j3+1) == 0     ) then
         return
      else if (rabs_use_stop			   .and. &
           (j1 < 0  .or.  j2 < 0  .or.  j3 < 0  .or.  l1 < 0  .or.  l2 < 0  .or.  l3 < 0)) then
         print *, "j1, j2, j3, l1 ,l2, l3 = ",j1, j2, j3, l1 ,l2, l3
         stop  "wigner_6j_symbol(): program stop A."
      end if
    1 continue
      !
      ! Evaluate the algebraic formulae
      !
      n1 = (j1 + j2 + j3)/2;         n2 = (l2 + l1 + j3)/2;       n3 = (j1 + l2 + l3)/2;       n4 = (j2 + l1 + l3)/2
      n5 = (j1 + j2 + l2 + l1)/2;    n6 = (j1 + l1 + j3 + l3)/2;  n7 = (j2 + l2 + j3 + l3)/2
      kmin = max(n1,n2,n3,n4) + 1;   kmax = min(n5,n6,n7) + 1
      !
      w6j = one;   icount = 0
      if (kmin /= kmax) then
         do k = kmin+1, kmax
            ki = kmax - icount
	    w6j = one -(w6j * ki*(n5-ki+two)*(n6-ki+two)*(n7-ki+two))/         &
                  ((ki-one-n1)*(ki-one-n2)*(ki-one-n3)*(ki-one-n4))
            icount = icount + 1
         end do
      end if
      w6j = w6j*exp(                                                           &
        ( ln_gamma(kmin+1)   -ln_gamma(kmin-n1)-ln_gamma(kmin-n2)   -          &
	  ln_gamma(kmin-n3)  -ln_gamma(kmin-n4)-ln_gamma(n5+2-kmin) -          &
	  ln_gamma(n6+2-kmin)-ln_gamma(n7+2-kmin)) +                           &
	((ln_gamma(n1+1-j1)+ln_gamma(n1+1-j2)+ln_gamma(n1+1-j3)-ln_gamma(n1+2)+&
	  ln_gamma(n2+1-l2)+ln_gamma(n2+1-l1)+ln_gamma(n2+1-j3)-ln_gamma(n2+2)+&
	  ln_gamma(n3+1-j1)+ln_gamma(n3+1-l2)+ln_gamma(n3+1-l3)-ln_gamma(n3+2)+&
          ln_gamma(n4+1-j2)+ln_gamma(n4+1-l1)+ln_gamma(n4+1-l3)-ln_gamma(n4+2))&
	  /two))
      if(mod(n5+kmin,2) == 0) w6j=-w6j;   if(mod(j1+j2+l2+l1,4) /= 0) w6j=-w6j
      !
   end function wigner_6j_symbol
   !
   !
   function wigner_6j_triangle(j1,j2,j3,l1,l2,l3)             result(Delta)
   !--------------------------------------------------------------------------------------------------------------------
   ! Calculate the triangular factors for 6j-symbol. The arguments in this integer function are j1 = 2*ja, ...
   ! The result is 0 if the triangular condition failes and 1 itherwise.
   !--------------------------------------------------------------------------------------------------------------------
      !
      integer, intent(in)      :: j1, j2, j3, l1, l2, l3
      integer                  :: Delta
      !
      Delta = 0
      if (triangle(j1+1,j2+1,j3+1) == 0) return
      if (triangle(j1+1,l2+1,l3+1) == 0) return
      if (triangle(l1+1,j2+1,l3+1) == 0) return
      if (triangle(l1+1,l2+1,j3+1) == 0) return
      Delta = 1
      !
   end function wigner_6j_triangle
   !
   !
   function wigner_9j_symbol(j11,j12,j13,j21,j22,j23,j31,j32,j33,no_triangels)        result(w9j)
   !--------------------------------------------------------------------------------------------------------------------
   ! Calculates the numerical value of a Wigner 9-j symbol by using the expansion and summation over a triple product
   ! of 6j-symbols as listed, for instance, in R.D. Cowan, "The Theory of Atomic Structure and Spectra", University of
   ! California Press, Berkeley, Los Angeles, London, 1981, Eq. (5.23). A straightforward numerical evaluation is
   ! performed. The integer arguments ja, ... of this function must be the double of the corresponding quantum numbers
   ! in the 9-j symbol, i.e. jk = jk' + jk > 0 in
   !
   !                       (  j11'   j12'   j13'  )
   !                       (  j21'   j22'   j23'  )
   !                       (  j31'   j32'   j33'  )
   !
   ! Calls:  triangle(), wigner_6j_symbol().
   !--------------------------------------------------------------------------------------------------------------------
      !
      integer, intent(in)            :: j11, j12, j13, j21, j22, j23, j31, j32, j33
      logical, intent(in), optional  :: no_triangels
      real(kind=dp)                  :: w9j
      !
      integer :: j, jmin, jmax
      !
      w9j = zero
      !
      if (present(no_triangels)  .and. no_triangels) goto 1
      if (triangle(j11+1,j12+1,j13+1) == 0  .or. triangle(j21+1,j22+1,j23+1) == 0 .or. triangle(j31+1,j32+1,j33+1) == 0 .or.&
          triangle(j11+1,j21+1,j31+1) == 0  .or. triangle(j12+1,j22+1,j32+1) == 0 .or. triangle(j13+1,j23+1,j33+1) == 0) then
         return
      end if
    1 continue
      !
      ! Evaluate the algebraic expansion formulae
      !
      jmin = max(abs(j11-j33),abs(j12-j23),abs(j32-j21))
      jmax = min(j11+j33,j12+j23,j32+j21)
      !
      if (jmin <= jmax) then
         do  j = jmin,jmax,2
            w9j = w9j + (-1)**j * (j+one) * wigner_6j_symbol(j11,j21,j31,j32,j33,j) *  &
                                            wigner_6j_symbol(j12,j22,j32,j21,j,j23) *  &
                                            wigner_6j_symbol(j13,j23,j33,j,j11,j12)
         end do
      end if
      !
   end function wigner_9j_symbol
   !
   !
   function wigner_9j_triangle(j11,j12,j13,j21,j22,j23,j31,j32,j33)      result(Delta)
   !--------------------------------------------------------------------------------------------------------------------
   ! Calculates the triangular factor for a Wigner 9-j symbol. The integer arguments ja, ... of this function must be
   ! the double of the corresponding quantum numbers in the 9-j symbol, i.e. jk = jk' + jk > 0 in
   !
   !                       (  j11'   j12'   j13'  )
   !                       (  j21'   j22'   j23'  )
   !                       (  j31'   j32'   j33'  )
   !--------------------------------------------------------------------------------------------------------------------
      !
      integer, intent(in) :: j11, j12, j13, j21, j22, j23, j31, j32, j33
      integer             :: Delta
      !
      Delta = 0
      if (triangle(j11+1,j12+1,j13+1) == 0) return
      if (triangle(j21+1,j22+1,j23+1) == 0) return
      if (triangle(j31+1,j32+1,j33+1) == 0) return
      if (triangle(j11+1,j21+1,j31+1) == 0) return
      if (triangle(j12+1,j22+1,j32+1) == 0) return
      if (triangle(j13+1,j23+1,j33+1) == 0) return
      Delta = 1
      !
   end function wigner_9j_triangle
   !
   !
   function wigner_eckardt_geometry(totalJ_f,MM_f,J_t,MM_t,totalJ_i,MM_i)       result(geom)
   !--------------------------------------------------------------------------------------------------------------------
   ! Returns the "geometrical factor" of the Wigner-Eckardt theorem by splitting a (complete) matrix element in a
   ! "reduced" matrix element and a geometrical cofactor. Here, the definition of Grant, J. Phys. B7 (1974), 1458 is used.
   !
   !         <complete ME>  =  geom  *  <reduced ME>
   !
   ! The given quantum numbers totalJf, MM_f .... are the doubles of the original ones which characterize the complete
   ! matrix element.
   !
   ! Calls: is_triangle(), wigner_3j_symbol().
   !--------------------------------------------------------------------------------------------------------------------
      !
      integer, intent(in)  :: totalJ_f, MM_f, J_t, MM_t, totalJ_i, MM_i
      !
      integer              :: phase
      real(kind=dp)        :: geom, gfactor
      !
      geom = zero
      if (.not.is_triangle(totalJ_f,J_t,totalJ_i)   .or.  MM_t + MM_i - MM_f /= 0) then
         return
      end if
      !
      gfactor = sqrt(totalJ_f + one)
      phase   = totalJ_f - MM_f + 2 + 32
      if (mod(phase,4) == 0) then
         gfactor = - gfactor
      else if (rabs_use_stop       .and. (mod(phase,4) == 1   .or.   mod(phase,4) == 3)) then
         stop "Wigner_Eckardt_geometry(): program stop A."
      end if
      geom = gfactor * wigner_3j_symbol(totalJ_f,J_t,totalJ_i,-MM_f,MM_t,MM_i)
      !
   end function wigner_eckardt_geometry
   !
   !
   function wigner_rotation_D_matrix(j,p,q,alpha,beta,gamma)                      result(wa)
   !--------------------------------------------------------------------------------------------------------------------
   ! Returns the value of the Wigner rotation matrix D^j_pq(alpha, beta, gamma).
   !
   ! Calls: wigner_rotation_d_small().
   !--------------------------------------------------------------------------------------------------------------------
      !
      integer, intent(in)       :: j, p, q
      real(kind=dp), intent(in) :: alpha, beta, gamma
      complex(kind=dp)          :: wa
      !
      if (abs(p) > j  .or.  abs(q) > j) then
         stop "wigner_rotation_D_matrix(): program stop A."
      else if (alpha < zero  .or.  alpha > two*pi) then
         stop "wigner_rotation_D_matrix(): program stop B."
      else if (beta  < zero  .or.  beta  > pi)     then
         stop "wigner_rotation_D_matrix(): program stop C."
      else if (gamma < zero  .or.  gamma > two*pi) then
         stop "wigner_rotation_D_matrix(): program stop D."
      end if
      !
      wa = exp(-i_cmplx * p * alpha) * wigner_rotation_d_small(j,p,q,beta) * exp(-i_cmplx * q * gamma)
      !
   end function wigner_rotation_D_matrix
   !
   !
   function wigner_rotation_d_small(j,p,q,beta)                      result(wa)
   !--------------------------------------------------------------------------------------------------------------------
   ! Returns the value of the Wigner rotation matrix d^j_pq(beta).
   !--------------------------------------------------------------------------------------------------------------------
      !
      integer, intent(in)       :: j, p, q
      real(kind=dp), intent(in) :: beta
      real(kind=dp)             :: wa
      !
      integer                   :: k, kmin1, kmax1, m, n
      !
      if (abs(p) > j  .or.  abs(q) > j) then
         stop "wigner_rotation_d_small(): program stop A."
      else if (beta  < zero  .or.  beta  > pi)     then
         stop "wigner_rotation_d_small(): program stop B."
      else if (phase_am(j-p) == one  .or.  phase_am(j-q) == one) then
         stop "wigner_rotation_d_small(): program stop C."
      end if
      !
      wa = zero
      !
      kmin1 = max(0,-p-q)/2;   kmax1 =  min(j-p,j-q)/2
      !
      do  k = kmin1, kmax1
         m  = (p+q) / 2 + k+k;   n = (j+j-p-q) / 2 - k-k
         wa = wa + phase_am(k+k) * (cos(beta/two)**m) * (sin(beta/two)**n) /                                        &
                   (factorial_dp(k) * factorial_dp((j-p)/2 -k) * factorial_dp((j-q)/2 -k) * factorial_dp((p+q)/2 +k))
      end do;
      !
   end function wigner_rotation_d_small
   !
end module rabs_angular


      SUBROUTINE CEPS(CMN,DMN,EMN,EPSIL,LROW,LDIAG)
C
C CALCULATES THE STRUCTURE OF THE RECURRENCE COEFFICIENT MATRICES
C USED IN THE BELOUSOV PROCEDURE, STORES THIS INFORMATION IN
C LROW(0:KK,2), AND EVALUATES THE COEFFICIENT MATRICES
C THE SPECTRAL TRUNCATION PARAMETERS ARE DEFINED BY 3 PARAMETERS:
C MM, THE LARGEST FOURIER WAVENUMBER; KK, THE HIGHEST DEGREE OF THE
C ASSOCIATED LEGENDRE POLYNOMIALS, AND NN THE HIGHEST DEGREE OF THE
C ASSOCIATED LEGENDRE POLYNOMIALS FOR M=0.  THE LENGTH OF THE EPSIL
C RECURRENCE ARRAY (AS WITH THE ASSOC. LEGENDRE POLYNOMIAL ARRAY)
C IS GIVEN BY THE RELATION LEN = ((MM+1)*(NN+1) - (LMN**2 + LMN)/2)
C WHERE LMN = MM + NN - KK.  VARIABLES ARE STORED ALONG DIAGONALS
C STARTING WITH THE DIAGONAL DEFINED BY M=N.  THE LENGTH OF EACH
C DIAGONAL IS STORED IN THE ARRAY LDIAG(0:NN,1) AND IS EVALUATED
C USING THE EXPRESSION (MM+1) - AMAX(MM + N - KK, 0) WHERE 0>N>NN.
C CUMULATIVE DIAGONAL LENGTHS (CUMULATIVE DISPLACEMENTS) ARE STORED
C IN LDIAG(0:NN,2) SO THAT EPSIL OF ORDER M AND DEGREE N IS
C ADDRESSED AS EPSIL(1 + LDIAG(N-M,2)+M)).
C
C CALLED BY: INPUT
C CALLS:
C
C REVISIONS:
C 7-10-92 CHANGE TO CCM CODING CONVENTIONS (R. JAKOB)
C
C---- Model Parameters -------------------------------------------------
C
      INCLUDE 'params.i'
C
C------------ Arguments ------------------------------------------------
C
C     Output
C
C RECURRENCE COEFFICIENTS FOR ALP
      REAL CMN(LRM+1)
C RECURRENCE COEFFICIENTS FOR ALP
      REAL DMN(LRM+1)
C RECURRENCE COEFFICIENTS FOR ALP
      REAL EMN(LRM+1)
C RECURRENCE COEFFICIENTS FOR DALP
      REAL EPSIL(NALP)
C INDEX FOR ROWS
      INTEGER LROW(0:KK,2)
C INDEX FOR DIAGONALS
      INTEGER LDIAG(0:NN,2)
C
C------ Local Variables ------------------------------------------------
C
      INTEGER K,M,N,JM,JN,IS
      INTEGER NSQD,MSQD
C
C----- Executable Statements -------------------------------------------
C
C     FIRST DETERMINE LDIAG(0:NN,1:2), DIAGONAL LENGTHS AND CUMULATIVE
C     DISPLACEMENTS FOR ALP, DALP, AND EPSIL ARRAYS
C
      LDIAG(0,1) = MM+1
      LDIAG(0,2) = 0
C
      DO 10 N=1,NN
         LDIAG(N,1) = (MM+1) - MAX0(MM+N-KK, 0)
         LDIAG(N,2) = LDIAG(N-1,1) + LDIAG(N-1,2)
   10 CONTINUE
C
C     OTHER STRUCTURE INFORMATION (ROWS)
C     BEGIN BY CALCULATING ROW LENGTHS AND CUMULATIVE DISPLACEMENTS
C     AND STORE THE INFORMATION IN LROW(0:KK,1:2)
C     ROW INFO IS FROM M=0 TO M=MM FOR EACH 0 <= N <= KK (I.E., IT DOES
C     NOT EXCLUDE THE EMPTY AREA BETWEEN (NN+M) AND KK WHEN KK > NN)
C
      LROW(0,1) = 1
      LROW(0,2) = 0
C
      DO 15 K=1,KK
         LROW(K,1) = MIN0(K+1,MM+1)
         LROW(K,2) = LROW(K-1,1) + LROW(K-1,2)
   15 CONTINUE
C
C     COMPUTE EPSIL MATRIX
C     BEGIN WITH FIRST TWO DIAGONALS
C
      DO 25 M=0,MM
         JM = M+1
         IS = LDIAG(1,2)
         EPSIL(JM)    = 0.0
         EPSIL(IS+JM) = 1.0/SQRT(REAL(2*M+3))
   25 CONTINUE
C
C     REMAINING DIAGONALS (JN = 2 THROUGH NN)
C
      DO 40 JN = 2,NN
         IS   = LDIAG(JN,2)
         DO 30 M=0,LDIAG(JN,1)-1
            JM   = M+1
            N    = JN+M
            NSQD = N*N
            MSQD = M*M
            EPSIL(IS+JM) = SQRT(REAL(NSQD-MSQD)/REAL(4*NSQD-1))
   30    CONTINUE
   40 CONTINUE
C
C     COMPUTE RECURRENCE COEFFICIENT MATRICES CMN, DMN, EMN
C     REASON FOR STORING BY ROW IS TO AVOID BANK CONFLICTS WHEN
C     EVALUATING THE POLYNOMIALS IN SUBROUTINE CALP
C
C     CHECK FOR SUFFICIENT STORAGE (PARAMETER LRM CORRECTLY SPECIFIED)
C
      IF (LRM .LT. ((MM+1)*(KK+1)-(MM*MM+MM)/2-1)) THEN
         WRITE (0,2) LRM
    2    FORMAT(/,' STSWM: FATAL ERROR IN SUBROUTINE CEPS ',/,
     $     ' LRM INCORRECTLY SPECIFIED FOR BELOUSOV RECURRENCE',
     $     ', LRM = ', I10)
         STOP
      ENDIF
C
      DO 130 N = 2,KK
         IS   = LROW(N,2)
         DO 120 M=2,LROW(N,1)-1
            JM = M+1
            CMN(IS+JM) = SQRT(REAL((2*N+1)*(M+N-1)*(M+N-3))
     $                      /(REAL((2*N-3)*(M+N)*(M+N-2))))
            DMN(IS+JM) = SQRT(REAL((2*N+1)*(M+N-1)*(N-M+1))
     $                      /(REAL((2*N-1)*(M+N)*(M+N-2))))
            EMN(IS+JM) = SQRT(REAL((2*N+1)*(N-M))
     $                      /(REAL((2*N-1)*(M+N))))
  120    CONTINUE
  130 CONTINUE
C
      RETURN
      END


! =========================================================================
elemental function gsw_gibbs_ice_part_t (t, p)
! =========================================================================
!
!  part of the the first temperature derivative of Gibbs energy of ice
!  that is the outout is gibbs_ice(1,0,t,p) + S0
!
!  t   =  in-situ temperature (ITS-90)                            [ deg C ]
!  p   =  sea pressure                                             [ dbar ]
!
!  gibbs_ice_part_t = part of temperature derivative       [ J kg^-1 K^-1 ]
!--------------------------------------------------------------------------

use gsw_mod_teos10_constants, only : gsw_t0, db2pa

use gsw_mod_gibbs_ice_coefficients

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: t, p

real (r8) :: gsw_gibbs_ice_part_t

real (r8) :: dzi, tau
complex (r8) :: g, tau_t1, tau_t2, r2

tau = (t + gsw_t0)*rec_tt

dzi = db2pa*p*rec_pt

tau_t1 = tau/t1
tau_t2 = tau/t2

r2 = r20 + dzi*(r21 + r22*dzi)

g = r1*(log((1.0_r8 + tau_t1)/(1.0_r8 - tau_t1)) - 2.0_r8*tau_t1) &
    + r2*(log((1.0_r8 + tau_t2)/(1.0_r8 - tau_t2)) - 2.0_r8*tau_t2)

gsw_gibbs_ice_part_t = real(g)

return
end function

!--------------------------------------------------------------------------


      SUBROUTINE DLARTG( F, G, CS, SN, R )
*
*  -- LAPACK auxiliary routine (version 1.0b) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     October 31, 1992
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION   CS, F, G, R, SN
*     ..
*
*  Purpose
*  =======
*
*  DLARTG generate a plane rotation so that
*
*     [  CS  SN  ]  .  [ F ]  =  [ R ]   where CS**2 + SN**2 = 1.
*     [ -SN  CS  ]     [ G ]     [ 0 ]
*
*  This is a faster version of the BLAS1 routine DROTG, except for
*  the following differences:
*     F and G are unchanged on return.
*     If G=0, then CS=1 and SN=0.
*     If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any
*        floating point operations (saves work in DBDSQR when
*        there are zeros on the diagonal).
*
*  Arguments
*  =========
*
*  F       (input) DOUBLE PRECISION
*          The first component of vector to be rotated.
*
*  G       (input) DOUBLE PRECISION
*          The second component of vector to be rotated.
*
*  CS      (output) DOUBLE PRECISION
*          The cosine of the rotation.
*
*  SN      (output) DOUBLE PRECISION
*          The sine of the rotation.
*
*  R       (output) DOUBLE PRECISION
*          The nonzero component of the rotated vector.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D0 )
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION   T, TT
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, SQRT
*     ..
*     .. Executable Statements ..
*
      IF( G.EQ.ZERO ) THEN
         CS = ONE
         SN = ZERO
         R = F
      ELSE IF( F.EQ.ZERO ) THEN
         CS = ZERO
         SN = ONE
         R = G
      ELSE
         IF( ABS( F ).GT.ABS( G ) ) THEN
            T = G / F
            TT = SQRT( ONE+T*T )
            CS = ONE / TT
            SN = T*CS
            R = F*TT
         ELSE
            T = F / G
            TT = SQRT( ONE+T*T )
            SN = ONE / TT
            CS = T*SN
            R = G*TT
         END IF
      END IF
      RETURN
*
*     End of DLARTG
*
      END


! Module based Fortran program to perform wham for multiple dimensions
!
!
PROGRAM wham
use openmpi
use ReadInputs
use wham
use WriteData

! Check input files exist or not
call CheckFiles()

! Read the Input files
Call ReadInput()

! Perform the WHAM
call perform_wham()

! write the final data to file
call Write_fes()

END PROGRAM wham


subroutine WaterProps(Temp,Pres_in,Select,NeglectPres,Answer, &
                      TempDeriv,PresDeriv)
!***********************************************************************
! Copyright 2011 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!***********************************************************************
! Purpose: Calculate the density, enthalpy, or viscosity of
!          H2O between -30 and 30 C, taking into account
!          the liquid-solid phase transition

! Inputs: Temp = Temperature (C), Pres = Pressure (MPa),
!         Select = Selection code,
!         NeglectPres = 1 to neglect the pressure
!                     = 0 to include pressure dependence
! Output: Answer = density   (kg/m^3) for Select = 0
!                  enthalpy  (MJ/kg)  ...        = 1
!                  viscosity (Pa*s)   ...        = 2
!         TempDeriv = derivative wrt temperature of density
!                     enthalpy, or viscosity
!         PresDeriv = derivative wrt pressure of ...
use comai, only : ierr
implicit none
real*8 :: Temp,Pres,Answer,IceRefDens,LiqRefDens,IceEndTemp, &
   LiqEndTemp,Slope,CpIce,CpLiq,IceRefEnth,Xi,               &
   LiqRefEnth,IceVisc,RefLiqVisc,IceCompress,                &
   LiqCompress,CompressConvert,RefPres,MPaToPa,              &
   LiqExpansion,IceExpansion,LiqEndVisc,IceEndVisc,          &
   LiqDCpDTemp,IceDCpDTemp,Pres_in,LargePos,LargeNeg,        &
   LiqDEnthDTemp,IceDEnthDTemp,                              &
   LiqDViscDTemp,LiqEndDens,IceEndDens,TempDeriv,            &
   PresDeriv,LiqEndEnth,IceEndEnth,Vis_tol
integer :: Select,NeglectPres
parameter( Vis_tol= 1.d-6)

!----------------------DATA SECTION------------------------
! NOTE: 'Ref' in variable names refers to T = phase change
!       temperature and zero pressure; 'End' refers to
!       phase change temperatures
IceRefDens = 917.0              ! in kg/m^3
LiqRefDens = 1000.0
IceEndTemp = -0.10              ! in C
LiqEndTemp =  0.10
CpLiq = 4.182                   ! in kJ/kg*C
CpIce = 2.108
IceRefEnth = 0                  ! in kJ/kg
LiqRefEnth = 334.0
IceVisc = 1.E20                 ! in Pa*s
RefLiqVisc = 1.787E-3

if (NeglectPres==0) then
  IceCompress = 1.004E-3        ! in cm^3/(mol*bar)
  LiqCompress = 8.584E-4
  CompressConvert = 1.0/(18*1.E8)
  IceCompress = IceCompress*CompressConvert
  LiqCompress = LiqCompress*CompressConvert
  ! Now IceCompress and LiqCompress are compressibilities in
  ! 1/Pa when multiplied by density
else if (NeglectPres==1) then
  IceCompress = 0.0
  LiqCompress = 0.0
else
  write(*,*) 'NeglectPres is not specified - WaterProps'
  write(*,*) 'NeglectPres: ',NeglectPres
  write(ierr,*) 'NeglectPres is not specified - WaterProps'
  write(ierr,*) 'NeglectPres: ',NeglectPres
!  STOP
end if
RefPres = 1.E5 ! in Pa
MPaToPa = 1.E6
LiqExpansion = -0.011 ! in kg/(m^3*C)
IceExpansion = -0.26
LiqDCpDTemp = -0.0012 ! in kJ/(kg*K^2)
IceDCpDTemp =  0.0046
LiqDEnthDTemp = CpLiq + Temp*LiqDCpDTemp
IceDEnthDTemp = CpIce + Temp*IceDCpDTemp
LiqDViscDTemp = -4E-5

! Frozen wall benchmark only !!
!LiqDViscDTemp = 0.0
!RefLiqVisc = 0.0015
!LiqCompress = 0.0
!IceExpansion = 0.0
!LiqExpansion = 0.0
!IceCompress = 0.0
!LiqDCpDTemp = 0.0
!IceDCpDTemp = 0.0
!IceRefDens = 920.0

LargePos = 10.0
LargeNeg = -10.0
!----------------------------------------------------------

if ((Temp<-150.0).or.(Temp>150.0)) then
  ! Return error
  write(*,*) 'Temperature out of bounds --WaterProps'
  write(*,*) 'Temperature: ',Temp
  write(ierr,*) 'Temperature out of bounds --WaterProps'
  write(ierr,*) 'Temperature: ',Temp
!  STOP
else
  ! Convert Pres to Pa
  Pres = Pres_in*MPaToPa
  if (Select==0) then
    !-----------------CALCULATE DENSITY--------------------
    if (Temp < IceEndTemp) then
      Answer = IceRefDens + &
               IceExpansion*(Temp-IceEndTemp) + &
               IceRefDens**2.0*IceCompress*(Pres-RefPres)
      TempDeriv = IceExpansion
      PresDeriv = IceRefDens**2.0*IceCompress
    elseif ((Temp >= IceEndTemp).and. &
            (Temp <= LiqEndTemp)) then
      LiqEndDens = LiqRefDens + &
        LiqRefDens**2.0*LiqCompress*(Pres-RefPres)
      IceEndDens = IceRefDens + &
        IceRefDens**2.0*IceCompress*(Pres-RefPres)
      Slope = (LargePos-LargeNeg)/(LiqEndTemp-IceEndTemp)
      Xi = Slope*(Temp-IceEndTemp)+LargeNeg
      Answer = (LiqEndDens-IceEndDens)*(tanh(Xi)+1.0)/2.0 + &
        IceEndDens
      TempDeriv = ((LiqEndDens-IceEndDens)/2.0)*Slope* &
        (1.0-tanh(Xi)**2.0)
      PresDeriv = (LiqRefDens**2.0*LiqCompress - &
                   IceRefDens**2.0*IceCompress)* &
                  (tanh(Xi)-1.0)/2.0 + IceRefDens**2.0*IceCompress
    else
      Answer = LiqRefDens + &
               LiqExpansion*(Temp-LiqEndTemp) + &
               LiqRefDens**2.0*LiqCompress*(Pres-RefPres)
      TempDeriv = LiqExpansion
      PresDeriv = LiqRefDens**2.0*LiqCompress
    end if
  elseif (Select==1) then
    !-----------------CALCULATE ENTHALPY-------------------
    if (Temp < IceEndTemp) then
      Answer = IceRefEnth + &
               IceDEnthDTemp*(Temp-IceEndTemp)
      TempDeriv = IceDEnthDTemp
      PresDeriv = 0.0
    elseif ((Temp >= IceEndTemp).and. &
            (Temp <= LiqEndTemp)) then
      LiqEndEnth = LiqRefEnth
      IceEndEnth = IceRefEnth
      Slope = (LargePos-LargeNeg)/ &
              (LiqEndTemp-IceEndTemp)
      Xi = Slope*(Temp-IceEndTemp) + LargeNeg
      Answer = (LiqEndEnth-IceEndEnth)*(tanh(Xi)+1.0)/2.0 + &
        IceEndEnth
      TempDeriv = ((LiqEndEnth-IceEndEnth)/2.0)*Slope* &
        (1.0-tanh(Xi)**2.0)
      PresDeriv = 0.0
    else
      Answer = LiqRefEnth + &
               LiqDEnthDTemp*(Temp-LiqEndTemp)
      TempDeriv = LiqDEnthDTemp
      PresDeriv = 0.0
    end if
    ! Convert to MJ/kg
    Answer = Answer/1000.0
    TempDeriv = TempDeriv/1000.0
    PresDeriv = PresDeriv/1000.0
  elseif (Select==2) then
    !-----------------CALCULATE VISCOSITY-----------------
    if (Temp < IceEndTemp) then
      Answer = IceVisc
      TempDeriv = 0.0
      PresDeriv = 0.0
    elseif ((Temp >= IceEndTemp).and. &
            (Temp <= LiqEndTemp)) then
      LiqEndVisc = RefLiqVisc
      IceEndVisc = IceVisc
      Slope = (LargePos-LargeNeg)/(LiqEndTemp-IceEndTemp)
      Xi = Slope*(Temp-IceEndTemp)+LargeNeg
      Answer = (LiqEndVisc-IceEndVisc)*(tanh(Xi)+1.0)/2.0 + &
        IceEndVisc
      TempDeriv = ((LiqEndVisc-IceEndVisc)/2.0)*Slope* &
        (1.0-tanh(Xi)**2.0)
      PresDeriv = 0.0
    else
      Answer = RefLiqVisc + LiqDViscDTemp*(Temp-LiqEndTemp)
      TempDeriv = LiqDViscDTemp
      PresDeriv = 0.0
    end if
    if(Answer.lt.Vis_tol) then
     Answer = Vis_tol
     TempDeriv = 0.0
     PresDeriv = 0.0
    endif
  else
    ! Return error
    write(*,*) 'Selection code not set properly --WaterProps'
    write(*,*) 'Selection code: ',Select
    STOP
  end if
end if

end

subroutine WaterProps_Vap(Temp,Pres_in,Select,NeglectPres,Answer, &
                      TempDeriv,PresDeriv)
!  Purpose: Calculate the density, enthalpy, or viscosity of
!          H2O between -30 and 30 C, taking into account
!          the Vapuid-solid phase transition

! Inputs: Temp = Temperature (C), Pres = Pressure (MPa),
!         Select = Selection code,
!         NeglectPres = 1 to neglect the pressure
!                     = 0 to include pressure dependence
! Output: Answer = density   (kg/m^3) for Select = 0
!                  enthalpy  (MJ/kg)  ...        = 1
!                  viscosity (Pa*s)   ...        = 2
!         TempDeriv = derivative wrt temperature of density
!                     enthalpy, or viscosity
!         PresDeriv = derivative wrt pressure of ...
use comai, only : iout, iptty
use comdi, only : LiqEndTemp, VapEndTemp
implicit none
real*8 :: Temp,Pres,Answer,LiqRefDens,VapRefDens,          &
   Slope,CpLiq,CpVap,LiqRefEnth,                           &
   VapRefEnth,LiqVisc,RefLiqVisc,RefVapVisc,LiqCompress,   &
   VapCompress,CompressConvert,RefPres,MPaToPa,            &
   VapExpansion,LiqExpansion,VapEndVisc,LiqEndVisc,        &
   VapDCpDTemp,LiqDCpDTemp,Pres_in,                        &
   VapDEnthDTemp,LiqDEnthDTemp,LiqRefTemp,VapRefTemp,      &
   VapDViscDTemp,VapEndDens,LiqEndDens,TempDeriv,          &
   PresDeriv,VapEndEnth,LiqEndEnth,Vis_tol,                &
   VapTransDens,LiqTransDens,VapTransEnth,LiqTransEnth,    &
   VapTransVisc,LiqTransVisc,LiqViscTerm1,LiqViscTerm2,    &
   VapRefVisc,LiqRefVisc,DslopeP
integer :: Select,NeglectPres
parameter( Vis_tol= 1.d-6)

!----------------------DATA SECTION------------------------
! NOTE: 'Ref' in variable names refers to T = phase change
!       temperature and zero pressure; 'End' refers to
!       phase change temperatures
!   Pressure reference is 2.32 Mpa
LiqRefDens = 841.8             ! in kg/m^3 at 20 C
VapRefDens = 11.62             ! at 20 C
! LiqEndTemp = 218.              ! in C
! VapEndTemp =  222.
! gaz 032011 set test temps at 152 and 154
!LiqEndTemp = 151.              ! in C
!VapEndTemp =  155.
LiqRefTemp = LiqEndTemp
VapRefTemp = VapEndTemp
LiqTransDens = 841.8           ! at 218 C
VapTransDens = 11.52           ! at 222 C
LiqTransEnth =  0.934          ! at 218 C
VapTransEnth =  2.806          ! at 222 C
CpVap = 2.8e-3                    ! in MJ/kg*C 220-280 C
CpLiq = 4.28e-3                   !  20-220 C
! Ref values modified for GAZ application
LiqRefEnth = 0.934                 ! in MJ/kg
VapRefEnth = 2.806
LiqViscTerm2 = 0.0193           ! b in visc = a + b/T
LiqRefVisc = 1.19E-4             ! in Pa*s at 218 C
LiqViscTerm1 = LiqRefVisc-LiqViscTerm2/LiqEndTemp ! a in visc = a + b/T
VapRefVisc = 1.65E-6           ! at 222 C
if (NeglectPres==0) then
  LiqCompress = 0.5        ! kg/(m3*Mpa)
  VapCompress = 0.
  ! Now LiqCompress and VapCompress are compressibilities in
  ! 1/Pa when multiplied by density
else if (NeglectPres==1) then
  LiqCompress = 0.0
  VapCompress = 0.0
else
  write(*,*) 'NeglectPres is not specified - WaterProps_Vap'
  write(*,*) 'NeglectPres: ',NeglectPres
  STOP
end if
RefPres = 2.32! in Mpa
MPaToPa = 1.E6
VapExpansion = -0.011 ! in kg/(m^3*C)
LiqExpansion = -0.794
VapDCpDTemp = 0.0
LiqDCpDTemp =  0.0
VapDEnthDTemp = CpLiq + Temp*VapDCpDTemp
LiqDEnthDTemp = CpVap + Temp*LiqDCpDTemp
VapDViscDTemp = 5.e-9
!----------------------------------------------------------

if (Temp>600) then
  ! Return error
  if(iout.ne.0) then
   write(iout,*) 'Temperature out of bounds --WaterPropsVap'
   write(iout,*) 'Temperature: ',Temp, ' Stopping'
  endif
  if(iptty.ne.0) then
   write(iptty,*) 'Temperature out of bounds --WaterPropsVap'
   write(iptty,*) 'Temperature: ',Temp, ' Stopping'
  endif
  STOP
else
  ! Convert Pres to Pa
  Pres = Pres_in
  if (Select==0) then
    !-----------------CALCULATE DENSITY--------------------
    If (Temp < 0.0) then
     Answer = LiqRefDens + &
               LiqExpansion*(-LiqRefTemp) + &
               LiqCompress*(Pres-RefPres)
       TempDeriv = 0.0
       PresDeriv = LiqCompress
    elseif (Temp < LiqEndTemp) then
      Answer = LiqRefDens + &
               LiqExpansion*(Temp-LiqRefTemp) + &
               LiqCompress*(Pres-RefPres)
      TempDeriv = LiqExpansion
      PresDeriv = LiqCompress
    elseif ((Temp >= LiqEndTemp).and. &
            (Temp <= VapEndTemp)) then
      VapEndDens =  VapTransDens*(Pres/RefPres)
      LiqEndDens = LiqTransDens + &
        LiqCompress*(Pres-RefPres)
      Slope = (VapEndDens-LiqEndDens)/ &
              (VapEndTemp-LiqEndTemp)
      Answer = Slope*(Temp-LiqEndTemp)+LiqEndDens
      TempDeriv = Slope
      DSlopeP = (1./(VapEndTemp-LiqEndTemp))* &
          (VapEndDens/RefPres-LiqCompress)
      PresDeriv = DSlopeP*(Temp-LiqEndTemp)+ LiqCompress
    else
!   Perfect gas law (temperature only)
      Answer = VapTransDens*(VapEndTemp/Temp)*(Pres/RefPres)
      TempDeriv = -Answer/Temp
      PresDeriv = Answer/Pres
    end if
  elseif (Select==1) then
    !-----------------CALCULATE ENTHALPY-------------------
     If (Temp < 0.0) then
      Answer = LiqRefEnth + &
               LiqDEnthDTemp*(-LiqRefTemp)
       TempDeriv = 0.0
       PresDeriv = 0.0
    elseif (Temp < LiqEndTemp) then
      Answer = LiqRefEnth + &
               LiqDEnthDTemp*(Temp-LiqRefTemp)
      TempDeriv = LiqDEnthDTemp
      PresDeriv = 0.0
    elseif ((Temp >= LiqEndTemp).and. &
            (Temp <= VapEndTemp)) then
      VapEndEnth = VapTransEnth
      LiqEndEnth = LiqTransEnth
      Slope = (VapEndEnth-LiqEndEnth)/ &
              (VapEndTemp-LiqEndTemp)
      Answer = LiqEndEnth + &
               Slope*(Temp-LiqEndTemp)
      TempDeriv = Slope
      PresDeriv = 0.0
    else
      Answer = VapRefEnth + &
               VapDEnthDTemp*(Temp-VapRefTemp)
      TempDeriv = VapDEnthDTemp
      PresDeriv = 0.0
    end if
  elseif (Select==2) then
    !-----------------CALCULATE VISCOSITY-----------------
     if (Temp < 1.) then
      Answer = LiqViscTerm1  + LiqViscTerm2
      TempDeriv = 0.0
      PresDeriv = 0.0
    elseif (Temp < LiqEndTemp) then
      Answer = LiqViscTerm1  + LiqViscTerm2/Temp
      TempDeriv = - LiqViscTerm2/Temp**2
      PresDeriv = 0.0
    elseif ((Temp >= LiqEndTemp).and. &
            (Temp <= VapEndTemp)) then
      VapEndVisc = VapRefVisc
      LiqEndVisc = LiqRefVisc
      Slope = (VapEndVisc-LiqEndVisc)/ &
              (VapEndTemp-LiqEndTemp)
      Answer = Slope*(Temp-LiqEndTemp)+LiqEndVisc
      TempDeriv = Slope
      if (Temp==VapEndTemp) then
        Answer = VapEndVisc
      end if
      PresDeriv = 0.0
    else
      Answer = VapRefVisc + VapDViscDTemp*(Temp-VapRefTemp)
      TempDeriv = VapDViscDTemp
      PresDeriv = 0.0
    end if
  else
    ! Return error
    write(*,*) 'Selection code not set properly --WaterProps'
    write(*,*) 'Selection code: ',Select
    STOP
  end if
end if
end


      integer function idmin(n,sx,incx)
c
c     ******************************************************************
c     *                                                                *
c     *   find the index of element having min value                   *
c     *                                                                *
c     ******************************************************************
c
      integer   i,incx,ix,n
c
c     *****************************************************************
c
      real      sx(n),smin
c
c     *****************************************************************
c
      idmin     = 0
      if (n.lt.1) return

      idmin     = 1
      if (n.eq.1) return

      if (incx.eq.1) go to 11
c
c     code for increment not equal to 1
c
      ix        = 1
      smin      = sx(1)
      ix        = ix + incx
      do i=2,n
         if (sx(ix).lt.smin) then
            idmin     = i
            smin      = sx(ix)
         end if
         ix        = ix + incx
      end do

      return
c
c      code for increment equal to 1
c
   11 smin      = sx(1)
      do i=2,n
         if (sx(i).lt.smin) then
            idmin     = i
            smin      = sx(i)
         end if
      end do

      return

      end


!
! Interpolate_Utility
!
! Container module for interpolation routine modules
!
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, CIMSS/SSEC 06-Oct-2006
!                       paul.vandelst@ssec.wisc.edu
!

MODULE Interpolate_Utility

  ! ------------------
  ! Environment set up
  ! ------------------
  ! Modules used
  USE Linear_Interpolation,     ONLY: Linear_Interpolate
  USE Polynomial_Interpolation, ONLY: Polynomial_Interpolate
  USE Spline_Interpolation,     ONLY: Spline_Initialize, &
                                      Spline_Interpolate
  ! Disable all implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  PRIVATE
  PUBLIC :: Linear_Interpolate
  PUBLIC :: Polynomial_Interpolate
  PUBLIC :: Spline_Initialize
  PUBLIC :: Spline_Interpolate

  ! -----------------
  ! Module parameters
  ! -----------------
  ! RCS Id field
  CHARACTER(*), PRIVATE, PARAMETER :: MODULE_RCS_ID = &

END MODULE Interpolate_Utility


program test_random_number

  implicit none
  integer, allocatable :: seed(:),n(:)
  integer :: z
  Real, allocatable :: r(:)

  call random_seed(size=z)
  allocate(seed(z))
  allocate(n(z+1))
  allocate(r(z+1))
  call random_seed(put=n)
  call random_seed(get=seed)
  !Write(*,*) seed
  CALL RANDOM_NUMBER(r)
  !Write(*,*) "================================================================"
  Write(*,*) r
end program


*> \brief \b ZGEEQU
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGEEQU + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE ZGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX,
*                          INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            INFO, LDA, M, N
*       DOUBLE PRECISION   AMAX, COLCND, ROWCND
*       ..
*       .. Array Arguments ..
*       DOUBLE PRECISION   C( * ), R( * )
*       COMPLEX*16         A( LDA, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ZGEEQU computes row and column scalings intended to equilibrate an
*> M-by-N matrix A and reduce its condition number.  R returns the row
*> scale factors and C the column scale factors, chosen to try to make
*> the largest element in each row and column of the matrix B with
*> elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
*>
*> R(i) and C(j) are restricted to be between SMLNUM = smallest safe
*> number and BIGNUM = largest safe number.  Use of these scaling
*> factors is not guaranteed to reduce the condition number of A but
*> works well in practice.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix A.  M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is COMPLEX*16 array, dimension (LDA,N)
*>          The M-by-N matrix whose equilibration factors are
*>          to be computed.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] R
*> \verbatim
*>          R is DOUBLE PRECISION array, dimension (M)
*>          If INFO = 0 or INFO > M, R contains the row scale factors
*>          for A.
*> \endverbatim
*>
*> \param[out] C
*> \verbatim
*>          C is DOUBLE PRECISION array, dimension (N)
*>          If INFO = 0,  C contains the column scale factors for A.
*> \endverbatim
*>
*> \param[out] ROWCND
*> \verbatim
*>          ROWCND is DOUBLE PRECISION
*>          If INFO = 0 or INFO > M, ROWCND contains the ratio of the
*>          smallest R(i) to the largest R(i).  If ROWCND >= 0.1 and
*>          AMAX is neither too large nor too small, it is not worth
*>          scaling by R.
*> \endverbatim
*>
*> \param[out] COLCND
*> \verbatim
*>          COLCND is DOUBLE PRECISION
*>          If INFO = 0, COLCND contains the ratio of the smallest
*>          C(i) to the largest C(i).  If COLCND >= 0.1, it is not
*>          worth scaling by C.
*> \endverbatim
*>
*> \param[out] AMAX
*> \verbatim
*>          AMAX is DOUBLE PRECISION
*>          Absolute value of largest matrix element.  If AMAX is very
*>          close to overflow or very close to underflow, the matrix
*>          should be scaled.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*>          > 0:  if INFO = i,  and i is
*>                <= M:  the i-th row of A is exactly zero
*>                >  M:  the (i-M)-th column of A is exactly zero
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16GEcomputational
*
*  =====================================================================
      SUBROUTINE ZGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX,
     $                   INFO )
*
*  -- LAPACK computational routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
      DOUBLE PRECISION   AMAX, COLCND, ROWCND
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   C( * ), R( * )
      COMPLEX*16         A( LDA, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J
      DOUBLE PRECISION   BIGNUM, RCMAX, RCMIN, SMLNUM
      COMPLEX*16         ZDUM
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, DIMAG, MAX, MIN
*     ..
*     .. Statement Functions ..
      DOUBLE PRECISION   CABS1
*     ..
*     .. Statement Function definitions ..
      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZGEEQU', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
         ROWCND = ONE
         COLCND = ONE
         AMAX = ZERO
         RETURN
      END IF
*
*     Get machine constants.
*
      SMLNUM = DLAMCH( 'S' )
      BIGNUM = ONE / SMLNUM
*
*     Compute row scale factors.
*
      DO 10 I = 1, M
         R( I ) = ZERO
   10 CONTINUE
*
*     Find the maximum element in each row.
*
      DO 30 J = 1, N
         DO 20 I = 1, M
            R( I ) = MAX( R( I ), CABS1( A( I, J ) ) )
   20    CONTINUE
   30 CONTINUE
*
*     Find the maximum and minimum scale factors.
*
      RCMIN = BIGNUM
      RCMAX = ZERO
      DO 40 I = 1, M
         RCMAX = MAX( RCMAX, R( I ) )
         RCMIN = MIN( RCMIN, R( I ) )
   40 CONTINUE
      AMAX = RCMAX
*
      IF( RCMIN.EQ.ZERO ) THEN
*
*        Find the first zero scale factor and return an error code.
*
         DO 50 I = 1, M
            IF( R( I ).EQ.ZERO ) THEN
               INFO = I
               RETURN
            END IF
   50    CONTINUE
      ELSE
*
*        Invert the scale factors.
*
         DO 60 I = 1, M
            R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM )
   60    CONTINUE
*
*        Compute ROWCND = min(R(I)) / max(R(I))
*
         ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
      END IF
*
*     Compute column scale factors
*
      DO 70 J = 1, N
         C( J ) = ZERO
   70 CONTINUE
*
*     Find the maximum element in each column,
*     assuming the row scaling computed above.
*
      DO 90 J = 1, N
         DO 80 I = 1, M
            C( J ) = MAX( C( J ), CABS1( A( I, J ) )*R( I ) )
   80    CONTINUE
   90 CONTINUE
*
*     Find the maximum and minimum scale factors.
*
      RCMIN = BIGNUM
      RCMAX = ZERO
      DO 100 J = 1, N
         RCMIN = MIN( RCMIN, C( J ) )
         RCMAX = MAX( RCMAX, C( J ) )
  100 CONTINUE
*
      IF( RCMIN.EQ.ZERO ) THEN
*
*        Find the first zero scale factor and return an error code.
*
         DO 110 J = 1, N
            IF( C( J ).EQ.ZERO ) THEN
               INFO = M + J
               RETURN
            END IF
  110    CONTINUE
      ELSE
*
*        Invert the scale factors.
*
         DO 120 J = 1, N
            C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM )
  120    CONTINUE
*
*        Compute COLCND = min(C(J)) / max(C(J))
*
         COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
      END IF
*
      RETURN
*
*     End of ZGEEQU
*
      END