module rabs_recoupling
!
!***** February 2012, wide *****
!-----------------------------------------------------------------------------------------------------------------------
! This module provides a set of procedures which support the analytic integration over the angular coordinates for
! matrix elements with symmetry-adapted subshell states. This includes a collection of routines which are concerned with
! the calculation of recoupling matrices in jj--coupling (see in G. Gaigalas et al., 1997 J. Phys. B: At. Mol.
! Opt. Phys, Vol 30 3747 section 4).
!-----------------------------------------------------------------------------------------------------------------------
   !
   use rabs_angular
   use rabs_constant
   use rabs_csl
   use rabs_rcfp
   implicit none
   !
   private :: recoupling_C_1
                 ! Returns the value of the coefficient C_1 from the paper of G. Gaigalas et al., 1997 J. Phys. B:
                 ! At. Mol. Opt. Phys, Vol 30 3747. The expression of C_1 is given in Eq. (15).
   private :: recoupling_C_2
                 ! Returns the value of the coefficient C_2 from the paper of G. Gaigalas et al., 1997 J. Phys. B:
                 ! At. Mol. Opt. Phys, Vol 30 3747. The expression of C_2 is given in Eq. (16).
   private :: recoupling_C_3
                 ! Returns the value of the coefficient C_3 from the paper of G. Gaigalas et al., 1997 J. Phys. B:
                 ! At. Mol. Opt. Phys, Vol 30 3747. The expression of C_3 is given in Eq. (17).
   private :: recoupling_C_4
                 ! Returns the value of the coefficient C_4 from the paper of G. Gaigalas et al., 1997 J. Phys. B:
                 ! At. Mol. Opt. Phys, Vol 30 3756. The expression of C_4 is given in Eq. (21).
   private :: recoupling_C_5
                 ! Returns the value of the coefficient C_5 from the paper of G. Gaigalas et al., 1997 J. Phys. B:
                 ! At. Mol. Opt. Phys, Vol 30 3747. The expression of C_5 is given in Eq. (23).
   public  :: recoupling_matrix_check
                 ! Checks the angular momentum selection rules for the recoupling coefficients.
   public  :: recoupling_matrix_check_nonscal
                 ! Checks the angular momentum selection rules for the recoupling coefficients of non scalar operator.
   public  :: recoupling_matrix_1p_shells
                 ! Calculates the recoupling matrix for a non scalar operator in the case of one interacting shells.
   public  :: recoupling_matrix_2_shells
                 ! Calculates the recoupling matrix for a scalar operator in the case of two interacting shells.
   public  :: recoupling_matrix_2p_shells
                 ! Calculates the recoupling matrix for a non scalar operator in the case of two interacting shells.
   public  :: recoupling_matrix_3_shells
                 ! Calculates the recoupling matrix for a scalar operator in the case of three interacting shells.
   private :: recoupling_matrix_3_ordered
                 ! Auxiliarity routine for the procedure recoupling_matrix_3_shells
   public  :: recoupling_matrix_4_shells
                 ! Calculates the recoupling matrix for a scalar operator in the case of four interacting shells.
contains
   !
   function recoupling_C_1(csf_r,csf_s,rank,shell,verify,delta_J)  result(coeff)
   !--------------------------------------------------------------------
   ! Returns the coefficient C_1 from the paper of G. Gaigalas et al.,
   ! 1997 J. Phys. B: At. Mol. Opt. Phys, Vol 30 3747, Eq. (15).
   ! The phase factor is given in the table 2 in this reference.
   !--------------------------------------------------------------------
      !
      logical, intent(in)           :: verify
      type(cs_function), intent(in) :: csf_r, csf_s
      integer, intent(in)           :: rank, shell
      integer, intent(out)          :: delta_J
      real(kind=dp)                 :: coeff
      !
      integer :: J, csf_s_J, csf_s_X, csf_r_J, csf_r_X
      !
      coeff = zero
      csf_r_J = csf_r%subshellJ(shell);   csf_s_J = csf_s%subshellJ(shell)
      !
      select case(shell)
      case(1)
         csf_r_X = csf_r%subshellX(2);   csf_s_X = csf_s%subshellX(2)
         J = csf_r%subshellJ(2)
      case(2)
         csf_r_X = csf_r%subshellX(2);   csf_s_X = csf_s%subshellX(2)
         J = csf_r%subshellJ(1)
      case default
         csf_r_X = csf_r%subshellX(shell);   csf_s_X = csf_s%subshellX(shell)
         J = csf_r%subshellX(shell-1)
      end select
      !
      if (verify) then
         delta_J = wigner_6j_triangle(rank,csf_s_J,csf_r_J,J,csf_r_X,csf_s_X)
      else
         delta_J = 1
         coeff = wigner_6j_symbol(rank,csf_s_J,csf_r_J,J,csf_r_X,csf_s_X)
         coeff = coeff * sqrt((csf_r_J + one) * (csf_s_X + one))
         if (mod(J+csf_r_X+csf_s_J+rank ,4) /= 0) coeff = - coeff
         if (shell == 1) then
            if (mod(csf_r_J+csf_s_J+2*J-csf_r_X-csf_s_X, 4) /= 0) coeff = -coeff
         end if
      end if
      !
   end function recoupling_C_1
   !
   !
   function recoupling_C_2(csf_r,csf_s,rank,shell_1,shell_2,verify,delta_J)    &
                                                                   result(coeff)
   !--------------------------------------------------------------------
   ! Returns the coefficient C_2 from the paper of G. Gaigalas et al.,
   ! 1997 J. Phys. B: At. Mol. Opt. Phys, Vol 30 3747, Eq. (16).
   ! The phase factor is given in the table 2 in this reference.
   !--------------------------------------------------------------------
      !
      logical, intent(in)           :: verify
      type(cs_function), intent(in) :: csf_r, csf_s
      integer, intent(in)           :: rank, shell_1, shell_2
      integer, intent(out)          :: delta_J
      real(kind=dp)                 :: coeff
      !
      integer          :: run, csf_J, csf_r_X, csf_s_X, csf_r_X_1, csf_s_X_1
      real(kind=dp)    :: coeff_run
      !
      coeff = one
      !
      if (shell_1 == 1) then
         run = 3
      else
         run = shell_1 + 1
      end if
      !
      delta_J = 1
    1 if (run < shell_2) then
         csf_J     = csf_r%subshellJ(run)
         csf_r_X   = csf_r%subshellX(run-1);  csf_s_X   = csf_s%subshellX(run-1)
         csf_r_X_1 = csf_r%subshellX(run);    csf_s_X_1 = csf_s%subshellX(run)
         if (verify) then
            delta_J = wigner_6j_triangle(rank,csf_s_X,csf_r_X,csf_J,           &
                                                           csf_r_X_1,csf_s_X_1)
            if (delta_J == 0) return
         else
            coeff_run = wigner_6j_symbol(rank,csf_s_X,csf_r_X,csf_J,           &
                                                            csf_r_X_1,csf_s_X_1)
            coeff_run = coeff_run * sqrt((csf_r_X + one) * (csf_s_X_1 + one))
            if (mod(rank+csf_J+csf_r_X+csf_s_X_1,4) /= 0) coeff_run = -coeff_run
            coeff = coeff * coeff_run
         end if
         run = run + 1
         go to 1
      end if
      !
   end function recoupling_C_2
   !
   !
   function recoupling_C_3(csf_r,csf_s,rank,shell,nwshells,verify,delta_J)      &
                                                                  result(coeff)
   !--------------------------------------------------------------------
   ! Returns the coefficient C_3 from the paper of G. Gaigalas et al.,
   ! 1997 J. Phys. B: At. Mol. Opt. Phys, Vol 30 3747, Eq. (17).
   ! The phase factor is given in the table 3 in this reference.
   !--------------------------------------------------------------------
      !
      logical, intent(in)           :: verify
      type(cs_function), intent(in) :: csf_r, csf_s
      integer, intent(in)           :: rank, shell, nwshells
      integer, intent(out)          :: delta_J
      real(kind=dp)                 :: coeff
      !
      integer :: T_r, T_s, T1_r, T1_s, JI
      !
      coeff = zero
      T1_r = csf_r%subshellX(nwshells);       T1_s = csf_s%subshellX(nwshells)
      if (shell == nwshells) then
         T_r = csf_r%subshellJ(nwshells);     T_s = csf_s%subshellJ(nwshells)
         JI  = csf_r%subshellX(nwshells-1)
      else
         T_r = csf_r%subshellX(nwshells-1);   T_s = csf_s%subshellX(nwshells-1)
         JI  = csf_r%subshellJ(nwshells)
      end if
      if (verify) then
         delta_J = wigner_6j_triangle(rank,T_s,T_r,JI,T1_r,T1_s)
      else
         coeff = wigner_6j_symbol(rank,T_s,T_r,JI,T1_r,T1_s)
         coeff = coeff * sqrt((T_r + one) * (T1_s + one))
         if (mod(rank+JI+T_s+T1_r,4) /= 0) coeff = - coeff
         delta_J = 1
         if (shell == nwshells) return
         if (mod(T_r+T_s-T1_s-T1_r+2*JI, 4) /= 0) coeff = -coeff
      end if
      !
   end function recoupling_C_3
   !
   !
   function recoupling_C_4(csf_r,csf_s,rank_1,rank_2,rank,shell_1,shell_2,     &
                                              verify,delta_J)      result(coeff)
   !--------------------------------------------------------------------
   ! Returns the coefficient C_4 from the paper of G. Gaigalas et al.,
   ! 1997 J. Phys. B: At. Mol. Opt. Phys, Vol 30 3747, Eq. (23).
   ! The phase factor is given in the table 4 in this reference.
   !--------------------------------------------------------------------
      !
      logical, intent(in)           :: verify
      type(cs_function), intent(in) :: csf_r, csf_s
      integer, intent(in)           :: rank, rank_1, rank_2, shell_1, shell_2
      integer, intent(out)          :: delta_J
      real(kind=dp)                 :: coeff
      !
      integer   :: csf_s_J_2, csf_r_J_2, csf_s_X_1, csf_r_X_1, csf_s_X, csf_r_X
      !
      coeff = zero
      !
      csf_r_J_2 = csf_r%subshellJ(shell_2); csf_s_J_2 = csf_s%subshellJ(shell_2)
      csf_r_X   = csf_r%subshellX(shell_2); csf_s_X   = csf_s%subshellX(shell_2)
      !
      if (shell_1 == 1  .and.  shell_2 == 2) then
         csf_r_X_1 = csf_r%subshellJ(shell_1)
         csf_s_X_1 = csf_s%subshellJ(shell_1)
      else
         csf_r_X_1 = csf_r%subshellX(shell_2-1)
         csf_s_X_1 = csf_s%subshellX(shell_2-1)
      end if
      !
      if (verify) then
         delta_J = wigner_9j_triangle(csf_s_X_1,rank_1,csf_r_X_1,              &
                                      csf_s_J_2,rank_2,csf_r_J_2,              &
                                      csf_s_X  ,rank  ,csf_r_X)
      else
         delta_J = 1
         coeff = wigner_9j_symbol(csf_s_X_1,rank_1,csf_r_X_1,                  &
                                  csf_s_J_2,rank_2,csf_r_J_2,                  &
                                  csf_s_X  ,rank  ,csf_r_X  ,.true.)
         coeff = coeff * sqrt((csf_r_X_1 + one)*(rank + one)*(csf_r_J_2 + one) &
                                                            *(csf_s_X   + one))
      end if
      !
   end function recoupling_C_4
   !
   !
   function recoupling_C_5(csf_r,csf_s,rank,shell_1,shell_2,verify,delta_J)    &
                                                                   result(coeff)
   !--------------------------------------------------------------------
   ! Returns the coefficient C_5 from the paper of G. Gaigalas et al.,
   ! 1997 J. Phys. B: At. Mol. Opt. Phys, Vol 30 3747, Eq. (23).
   ! The phase factor is given in the table 5 in this reference.
   !--------------------------------------------------------------------
      !
      logical, intent(in)           :: verify
      type(cs_function), intent(in) :: csf_r, csf_s
      integer, intent(in)           :: rank, shell_1, shell_2
      integer, intent(out)          :: delta_J
      real(kind=dp)                 :: coeff
      !
      integer    :: csf_s_J, csf_r_J, csf_s_J_2, csf_r_J_2, csf_X_2
      !
      coeff = zero
      !
      csf_r_J_2 = csf_r%subshellJ(shell_2); csf_s_J_2 = csf_s%subshellJ(shell_2)
      csf_X_2   = csf_r%subshellX(shell_2)
      !
      if (shell_1 == 1  .and.  shell_2 == 2) then
         csf_r_J = csf_r%subshellJ(shell_1); csf_s_J = csf_s%subshellJ(shell_1)
      else
         csf_r_J = csf_r%subshellX(shell_2-1)
         csf_s_J = csf_s%subshellX(shell_2-1)
      end if
      !
      if (verify) then
         delta_J = wigner_6j_triangle(rank,csf_s_J_2,csf_r_J_2,csf_X_2,        &
                                                               csf_r_J,csf_s_J)
      else
         delta_J = 1
         coeff = wigner_6j_symbol(rank,csf_s_J_2,csf_r_J_2,csf_X_2,            &
                                                               csf_r_J,csf_s_J)
         coeff = coeff * sqrt((csf_s_J_2 + one) * (csf_r_J + one))
         if (mod(csf_X_2+csf_s_J+csf_r_J_2+rank ,4) /= 0) coeff = - coeff
      end if
      !
   end function recoupling_C_5
   !
   !
   function recoupling_matrix_check(csf_r,csf_s,shell_1,shell_2,shell_3,       &
                                   shell_4,nwshells,nwcore,switch) result(coeff)
   !--------------------------------------------------------------------
   ! Checks the angular momentum selection rules for the recoupling
   ! coefficients in the cases of one, two, three or four interacting
   ! shells.
   !--------------------------------------------------------------------
      !
      type(cs_function), intent(in) :: csf_r, csf_s
      integer, intent(in)           :: shell_1, shell_2, shell_3, shell_4
      integer, intent(in)           :: nwshells, nwcore, switch
      real(kind=dp)                 :: coeff
      !
      integer     :: i, shell
      !
      coeff = one
      if (nwshells == 1) return
      !
      if (switch == 0) then
         do i = nwcore + 1, nwshells
            if (i > 1) then
               if (csf_r%subshellX(i) /= csf_s%subshellX(i)) coeff = zero
            end if
            if (csf_r%subshellJ(i) /= csf_s%subshellJ(i)) coeff = zero
            if (csf_r%seniority(i) /= csf_s%seniority(i)) coeff = zero
            if (coeff == zero) return
         end do
      else if (shell_1 == 1  .and.  shell_2 == 2) then
         do i = nwcore + 1, nwshells
            if (i > 1) then
               if (csf_r%subshellX(i) /= csf_s%subshellX(i)) coeff = zero
            end if
            if (i > 2) then
               if (csf_r%subshellJ(i) /= csf_s%subshellJ(i)) coeff = zero
               if (csf_r%seniority(i) /= csf_s%seniority(i)) coeff = zero
            end if
            if (coeff == zero) return
         end do
      else
         if (shell_1 == 2) then
            shell = 1
         else
            shell = shell_1
         end if
         do i = nwcore + 1, nwshells
            if (i < shell  .or.  i >= shell_2) then
               if(i > 1) then
                  if (csf_r%subshellX(i) /= csf_s%subshellX(i)) coeff = zero
               end if
            end if
            if(i == shell_1) then
            else if (i == shell_2) then
            else if (switch == 2 .and. i == shell_3) then
            else if (switch == 3 .and. i == shell_3) then
            else if (switch == 3 .and. i == shell_4) then
            else
               if (csf_r%subshellJ(i) /= csf_s%subshellJ(i)) coeff = zero
               if (csf_r%seniority(i) /= csf_s%seniority(i)) coeff = zero
            end if
            if (coeff == zero) return
            end do
      end if
      !
   end function recoupling_matrix_check
   !
   !
   function recoupling_matrix_check_nonscal(csf_r,csf_s,rank,shell_1,       &
                                     shell_2,nwshells,nwcore) result(coeff)
   !--------------------------------------------------------------------
   ! Checks the angular momentum selection rules for the recoupling
   ! coefficients in the cases of one ore two interacting shells
   ! for non scalar operatro
   !--------------------------------------------------------------------
      !
      type(cs_function), intent(in) :: csf_r, csf_s
      integer, intent(in)           :: shell_1, shell_2
      integer, intent(in)           :: nwshells, nwcore, rank
      real(kind=dp)                 :: coeff
      !
      integer     :: i
      !
      coeff = zero
      if (triangle(csf_r%totalJ+1,rank+1,csf_s%totalJ+1) == 0) return
      coeff = one
      if (nwshells == 1) return
      !
      do i = nwcore + 1, nwshells
         if (i /= shell_1) then
            if (i /= shell_2) then
               if (csf_r%subshellJ(i) /= csf_s%subshellJ(i)) coeff = zero
               if (csf_r%seniority(i) /= csf_s%seniority(i)) coeff = zero
            end if
         end if
         if (coeff == zero) return
      end do
      if (nwshells <= 2) return
      if (nwshells-shell_2 > 0) then
         do i=shell_2,nwshells
            if (triangle(csf_r%subshellX(i)+1,rank+1,csf_s%subshellX(i)+1) &
                == 0) coeff = zero
         end do
      end if
      if (coeff == zero) return
      if (shell_1 <= nwcore) return
      do i = nwcore, shell_1-1
         if (i == 0) cycle
         if (csf_r%subshellX(i) /= csf_s%subshellX(i)) coeff = zero
      end do
      !
   end function recoupling_matrix_check_nonscal
   !
   !
   function recoupling_matrix_1p_shells(csf_r,csf_s,rank,shell_1,verify,       &
                                       nwshells,nwcore,delta_J)   result(coeff)
   !--------------------------------------------------------------------
   ! Calculates the recoupling matrix for a scalar operator in the case
   ! of two interacting shells. See G. Gaigalas et al., 1997 J. Phys. B:
   ! At. Mol. Opt. Phys, Vol 30 3747, Eq. (14) (p. 3756).
   !--------------------------------------------------------------------
      !
      logical, intent(in)           :: verify
      type(cs_function), intent(in) :: csf_r, csf_s
      integer, intent(in)           :: rank, shell_1, nwshells, nwcore
      integer, intent(out)          :: delta_J
      real(kind=dp)                 :: coeff
      !
      integer                       :: run, run_correction
      !
      delta_J = 1
      coeff = one / sqrt((csf_r%subshellJ(shell_1) + one))
      if (nwshells == 1 ) return
      delta_J = 0
      if ((nwshells) /= 2) then
         coeff = coeff * recoupling_C_3                                       &
                         (csf_r,csf_s,rank,shell_1,nwshells,verify,delta_J)
         if (delta_J == 0) return
         if (shell_1 == nwshells) return
         delta_J = 0
      end if
      coeff = coeff * recoupling_C_1(csf_r,csf_s,rank,shell_1,verify,delta_J)
      if (delta_J == 0) return
      run_correction = nwshells - shell_1
      if(shell_1 == 1) run_correction = run_correction - 1
      if(run_correction <= 1) return
      delta_J = 0
      coeff = coeff * recoupling_C_2                                          &
                            (csf_r,csf_s,rank,shell_1,nwshells,verify,delta_J)
      !
   end function recoupling_matrix_1p_shells
   !
   !
   function recoupling_matrix_2_shells(csf_r,csf_s,rank,shell_1,shell_2,verify,&
                                                        delta_J)   result(coeff)
   !--------------------------------------------------------------------
   ! Calculates the recoupling matrix for a scalar operator in the case
   ! of two interacting shells. See G. Gaigalas et al., 1997 J. Phys. B:
   ! At. Mol. Opt. Phys, Vol 30 3747, Eq. (22) (p. 3756).
   !--------------------------------------------------------------------
      !
      logical, intent(in)           :: verify
      type(cs_function), intent(in) :: csf_r, csf_s
      integer, intent(in)           :: rank, shell_1, shell_2
      integer, intent(out)          :: delta_J
      real(kind=dp)                 :: coeff
      !
      delta_J = 0
      coeff = one / sqrt((csf_r%subshellJ(shell_1) + one) *                    &
                         (csf_r%subshellJ(shell_2) + one))
      if (rank /= 0 .or. verify) then
         coeff = coeff *                                                       &
                 recoupling_C_5(csf_r,csf_s,rank,shell_1,shell_2,verify,delta_J)
         if (delta_J == 0) return
         coeff = coeff * sqrt((csf_r%subshellJ(shell_2) + one) /               &
                              ((rank + one) * (csf_s%subshellJ(shell_2) + one)))
         if (shell_1 == 1 .and. shell_2 == 2) return
         coeff = coeff * recoupling_C_1(csf_r,csf_s,rank,shell_1,verify,delta_J)
         if (delta_J == 0) return
         if (shell_1 == 1) then
            if (shell_2 - 1 - shell_1 <= 1) return
         else
            if (shell_2 - shell_1     <= 1) return
         end if
         coeff = coeff *                                                       &
                 recoupling_C_2(csf_r,csf_s,rank,shell_1,shell_2,verify,delta_J)
      else
         delta_J = 1
      end if
      !
   end function recoupling_matrix_2_shells
   !
   !
   function recoupling_matrix_2p_shells(csf_r,csf_s,rank_1,rank_2,rank,shell_1,&
                         shell_2,verify,nwshells,nwcore,delta_J)   result(coeff)
   !--------------------------------------------------------------------
   ! Calculates the recoupling matrix for a non scalar operator in the case
   ! of two interacting shells. See G. Gaigalas et al., 1997 J. Phys. B:
   ! At. Mol. Opt. Phys, Vol 30 3747, Eq. (19) (p. 3756).
   !--------------------------------------------------------------------
      !
      logical, intent(in)           :: verify
      type(cs_function), intent(in) :: csf_r, csf_s
      integer, intent(in)           :: rank_1, rank_2, rank, shell_1, shell_2
      integer, intent(in)           :: nwshells, nwcore
      integer, intent(out)          :: delta_J
      real(kind=dp)                 :: coeff
      !
      integer                       :: run, run_correction
      !
      delta_J = 1
      coeff = one / sqrt((csf_r%subshellJ(shell_1) + one)                      &
                        *(csf_r%subshellJ(shell_2) + one))
      if ((nwshells - shell_2) > 1) then
         delta_J = 0
         coeff = coeff * recoupling_C_2                                        &
                            (csf_r,csf_s,rank,shell_2,nwshells,verify,delta_J)
         if (delta_J == 0) return
         delta_J = 0
      end if
      if (shell_2 /= nwshells) then
         coeff = coeff * recoupling_C_3                                        &
                         (csf_r,csf_s,rank,shell_2,nwshells,verify,delta_J)
         if (delta_J == 0) return
         delta_J = 0
      end if
      coeff = coeff * recoupling_C_4(csf_r,csf_s,rank_1,rank_2,rank,shell_1,   &
                                                         shell_2,verify,delta_J)
      if (delta_J == 0) return
      if (shell_1 == 1 .and. shell_2 == 2) return
      delta_J = 0
      coeff = coeff * recoupling_C_1(csf_r,csf_s,rank_1,shell_1,verify,delta_J)
      if (delta_J == 0) return
      run_correction = shell_2 - shell_1
      if(shell_1 == 1) run_correction = run_correction - 1
      if(run_correction <= 1) return
      delta_J = 0
      coeff = coeff * recoupling_C_2                                          &
                            (csf_r,csf_s,rank_1,shell_1,shell_2,verify,delta_J)
      !
   end function recoupling_matrix_2p_shells
   !
   !
   function recoupling_matrix_3_shells(csf_r,csf_s,rank_1,rank_2,rank_3,       &
                          shell_1,shell_2,shell_3,verify,delta_J)  result(coeff)
   !--------------------------------------------------------------------
   ! Calculates the recoupling matrix for a scalar operator in the case
   ! of three interacting shells. See G. Gaigalas et al., 1997 J. Phys. B:
   ! At. Mol. Opt. Phys, Vol 30 3747, Eq. (26) (p. 3758).
   !--------------------------------------------------------------------
      !
      logical, intent(in)           :: verify
      type(cs_function), intent(in) :: csf_r, csf_s
      integer, intent(in)           :: rank_1, rank_2, rank_3
      integer, intent(in)           :: shell_1, shell_2, shell_3
      integer, intent(out)          :: delta_J
      real(kind=dp)                 :: coeff
      !
      if ((shell_3 > shell_1)  .and. (shell_3 > shell_2)) then
         if (shell_1 < shell_2) then
            coeff = recoupling_matrix_3_ordered(csf_r,csf_s,rank_1,rank_2,     &
                                  rank_3,shell_1,shell_2,shell_3,verify,delta_J)
         else if (shell_1 > shell_2) then
            coeff = recoupling_matrix_3_ordered(csf_r,csf_s,rank_2,rank_1,     &
                                  rank_3,shell_2,shell_1,shell_3,verify,delta_J)
            if (mod(rank_1 + rank_2 - rank_3,4) /= 0) coeff = -coeff
         else if (rabs_use_stop) then
            stop "recoupling_matrix_3_shells(): program stop A."
         end if
      else if ((shell_3 < shell_1)  .and. (shell_3 < shell_2)) then
         if (shell_1 < shell_2) then
            coeff = recoupling_matrix_3_ordered(csf_r,csf_s,rank_3,rank_1,     &
                                  rank_2,shell_3,shell_1,shell_2,verify,delta_J)
            if (mod(rank_3,2) /= 0) coeff = -coeff
         else if (shell_1 > shell_2) then
            coeff = recoupling_matrix_3_ordered(csf_r,csf_s,rank_3,rank_2,     &
                                  rank_1,shell_3,shell_2,shell_1,verify,delta_J)
            if (mod(rank_1 + rank_2 + rank_3,4) /= 0) coeff = -coeff
         else if (rabs_use_stop) then
            stop "recoupling_matrix_3_shells(): program stop B."
         end if
      else
         if (shell_1 < shell_2) then
            coeff = recoupling_matrix_3_ordered(csf_r,csf_s,rank_1,rank_3,     &
                                  rank_2,shell_1,shell_3,shell_2,verify,delta_J)
            if (mod(rank_1 - rank_2 - rank_3,4) /= 0) coeff = -coeff
         else if (shell_1 > shell_2) then
            coeff = recoupling_matrix_3_ordered(csf_r,csf_s,rank_2,rank_3,     &
                                  rank_1,shell_2,shell_3,shell_1,verify,delta_J)
            if (mod(rank_1,2) /= 0) coeff = -coeff
         else if (rabs_use_stop) then
            stop "recoupling_matrix_3_shell(): program stop C."
         end if
      end if
      !
   end function recoupling_matrix_3_shells
   !
   !
   function recoupling_matrix_3_ordered(csf_r,csf_s,rank_1,rank_2,rank,shell_1,&
                                 shell_2,shell_3,verify,delta_J)   result(coeff)
   !--------------------------------------------------------------------
   ! Auxiliary routine for recoupling_matrix_3_shells.
   !--------------------------------------------------------------------
      !
      logical, intent(in)           :: verify
      type(cs_function), intent(in) :: csf_r, csf_s
      integer, intent(in)           :: rank_1, rank_2, rank
      integer, intent(in)           :: shell_1, shell_2, shell_3
      integer, intent(out)          :: delta_J
      real(kind=dp)                 :: coeff
      !
      coeff = one / sqrt( (csf_r%subshellJ(shell_1) + one) *                   &
              (csf_r%subshellJ(shell_2) + one) * (rank + one) *                &
              (csf_s%subshellJ(shell_3) + one))
      if (shell_3 - shell_2 > 1) then
         coeff = coeff *                                                       &
                 recoupling_C_2(csf_r,csf_s,rank,shell_2,shell_3,verify,delta_J)
         if (delta_J == 0) return
      end if
      coeff = coeff *                                                          &
                 recoupling_C_5(csf_r,csf_s,rank,shell_1,shell_3,verify,delta_J)
      if (delta_J == 0) return
      coeff = coeff * recoupling_C_4(csf_r,csf_s,rank_1,rank_2,rank,shell_1,   &
                                                         shell_2,verify,delta_J)
      if (delta_J == 0) return
      if (shell_1 == 1 .and. shell_2 == 2) return
      coeff = coeff * recoupling_C_1(csf_r,csf_s,rank_1,shell_1,verify,delta_J)
      if (delta_J == 0) return
      if (shell_1 == 1) then
         if (shell_2 - 1 - shell_1 <= 1) return
      else
         if (shell_2 - shell_1     <= 1) return
      end if
      coeff = coeff *                                                          &
              recoupling_C_2(csf_r,csf_s,rank_1,shell_1,shell_2,verify,delta_J)
      !
   end function recoupling_matrix_3_ordered
   !
   !
   function recoupling_matrix_4_shells(csf_r,csf_s,rank_1,rank_2,rank_3,rank_4,&
            rank,shell_1,shell_2,shell_3,shell_4,verify,delta_J)   result(coeff)
   !--------------------------------------------------------------------
   ! Calculates the recoupling matrix for a scalar operator in the case
   ! of four interacting shells. See G. Gaigalas et al., 1997 J. Phys. B:
   ! At. Mol. Opt. Phys, Vol 30 3747, Eq. (33) (p. 3760).
   !--------------------------------------------------------------------
      !
      logical, intent(in)           :: verify
      type(cs_function), intent(in) :: csf_r, csf_s
      integer, intent(in)           :: rank_1, rank_2, rank_3, rank_4, rank
      integer, intent(in)           :: shell_1, shell_2, shell_3, shell_4
      integer, intent(out)          :: delta_J
      real(kind=dp)                 :: coeff
      !
      coeff = one / sqrt( (csf_r%subshellJ(shell_1) + one) *                   &
              (csf_r%subshellJ(shell_2) + one)*(csf_r%subshellJ(shell_3) + one)&
                            * (rank_4 + one)*(csf_s%subshellJ(shell_4) + one) )
      if (shell_3 - shell_2 > 1) then
         coeff = coeff *                                                       &
               recoupling_C_2(csf_r,csf_s,rank,shell_2,shell_3,verify,delta_J)
         if (delta_J == 0) return
      end if
      if (shell_4 - shell_3 > 1) then
         coeff=coeff *                                                         &
               recoupling_C_2(csf_r,csf_s,rank_4,shell_3,shell_4,verify,delta_J)
         if (delta_J == 0) return
      end if
      coeff = coeff *                                                          &
              recoupling_C_5(csf_r,csf_s,rank_4,shell_1,shell_4,verify,delta_J)
      if (delta_J == 0) return
      coeff = coeff * recoupling_C_4(csf_r,csf_s,rank_1,rank_2,rank,shell_1,   &
                                                         shell_2,verify,delta_J)
      if (delta_J == 0) return
      coeff = coeff * recoupling_C_4(csf_r,csf_s,rank,rank_3,rank_4,shell_2,   &
                                                         shell_3,verify,delta_J)
      if (delta_J == 0) return
      if (shell_1 == 1 .and. shell_2 == 2) return
      coeff = coeff * recoupling_C_1(csf_r,csf_s,rank_1,shell_1,verify,delta_J)
      if (delta_J == 0) return
      if (shell_1 == 1) then
         if (shell_2 - 1 - shell_1 <= 1) return
      else
         if (shell_2 - shell_1     <= 1) return
      end if
      coeff = coeff *                                                          &
              recoupling_C_2(csf_r,csf_s,rank_1,shell_1,shell_2,verify,delta_J)
      !
   end function recoupling_matrix_4_shells
   !
end module rabs_recoupling


!
! PP_MD
!
! Module containing forward, tangent-linear and adjoint subroutines
! for partial pressure to/from mass density units conversion.
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 24-Sep-2009
!                       paul.vandelst@noaa.gov
!

MODULE PP_MD

  ! -----------------
  ! Environment setup
  ! -----------------
  ! Modules used
  USE Type_Kinds, ONLY: fp
  USE Profile_Utility_Parameters, ONLY: ZERO, ONE, &
                                        MAX_N_MOLECULAR_SPECIES, &
                                        R0, MOLECULAR_WEIGHT, &
                                        PA_TO_HPA, HPA_TO_PA
  ! Disable all implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  PRIVATE
  PUBLIC :: PP_to_MD, PP_to_MD_TL, PP_to_MD_AD
  PUBLIC :: MD_to_PP, MD_to_PP_TL, MD_to_PP_AD

  ! -----------------
  ! Module parameters
  ! -----------------
  CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = &

CONTAINS

!------------------------------------------------------------------------------
!:sdoc+:
! NAME:
!       PP_to_MD
!
! PURPOSE:
!       Elemental subroutine to convert gas concentrations from partial
!       pressure to mass density.
!
! CALLING SEQUENCE:
!       CALL PP_to_MD( Temperature              , &  ! Input
!                      Partial_Pressure         , &  ! Input
!                      Mass_Density             , &  ! Output
!                      Molecule_ID = Molecule_ID  )  ! Optional Input
!
! INPUTS:
!       Temperature:       Atmospheric temperature
!                          UNITS:      Kelvin, K
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Scalar or any rank
!                          ATTRIBUTES: INTENT(IN)
!
!       Partial_Pressure:  Partial pressure of gas.
!                          UNITS:      hectoPascals, hPa
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Same as Temperature
!                          ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       Mass_Density:      Mass density of gas.
!                          Set to zero for invalid input.
!                          UNITS:      g/m^3
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Same as input Temperature
!                          ATTRIBUTES: INTENT(OUT)
!
! OPTIONAL INPUTS:
!       Molecule_ID:       HITRAN molecular designation identifying the
!                          molecule for which the concentration units
!                          conversion is required. If not specified, the
!                          default value is that for water vapor.
!                          Valid values are:
!                            1: H2O       9: SO2      17: HI       25: H2O2
!                            2: CO2      10: NO2      18: ClO      26: C2H2
!                            3: O3       11: NH3      19: OCS      27: C2H6
!                            4: N2O      12: HNO3     20: H2CO     28: PH3
!                            5: CO       13: OH       21: HOCl     29: COF2
!                            6: CH4      14: HF       22: N2       30: SF6
!                            7: O2       15: HCl      23: HCN      31: H2S
!                            8: NO       16: HBr      24: CH3Cl    32: HCOOH
!                          UNITS:      N/A
!                          TYPE:       INTEGER
!                          DIMENSION:  Scalar
!                          ATTRIBUTES: OPTIONAL, INTENT(IN)
!
! PROCEDURE:
!       The ideal gas law is
!
!         p.V = n.R.T
!
!       where,
!         p = Pressure
!         V = volume
!         n = number of moles of the gas,
!         R = molar gas constant,
!         T = Temperature.
!
!       This can be written in terms of the number of molecules, N,
!
!                 N
!         p.V = ---- . R.T                  ..............(1)
!                NA
!
!       where NA = Avogadro's constant (number of molecules in 1 mole.)
!
!       Eqn.(1) can be recast to provide the number of molecules in the
!       volume, the number density, nd,
!
!               N     p.NA
!         nd = --- = ------  molecules/m^3  ..............(2)
!               V     R.T
!
!       The mass density is related to the number density by the simple
!       relation,
!
!                    MW
!         md = nd . ----                    ..............(3)
!                    NA
!
!       Substituting equation (2) into (3) gives,
!
!               p.MW
!         md = ------  g/m^3                ..............(4)
!               R.T
!
!       The value of p0 used in this routine is expressed in pascals (Pa) whereas
!       the input partial Pressure is expected to be hPa (more common unit). Thus
!       there is a factor of 100 to include,
!
!               100.p.MW
!         md = ----------  g/m^3
!                 R.T
!
! UNITS ANALYSIS:
!       p  :  kg.m^-1.s^-2  (Pascals)
!       MW :  g.mol^-1
!       R  :  J.mol^-1.K^-1 == kg.m^2.s^-2.mol^-1.K^-1
!       T  :  K
!
!                  kg       g      s^2.mol.K     1
!         md == ------- . ----- . ----------- . ---
!                m.s^2     mol      kg.m^2       K
!
!                 g
!            == -----
!                m^3
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 08-Nov-2004
!                       paul.vandelst@noaa.gov
!:sdoc-:
!------------------------------------------------------------------------------

  ELEMENTAL SUBROUTINE PP_to_MD( &
    Temperature     , &  ! Input
    Partial_Pressure, &  ! Input
    Mass_Density    , &  ! Output
    Molecule_ID       )  ! Optional Input
    ! Arguments
    REAL(fp),          INTENT(IN)  :: Temperature
    REAL(fp),          INTENT(IN)  :: Partial_Pressure
    REAL(fp),          INTENT(OUT) :: Mass_Density
    INTEGER, OPTIONAL, INTENT(IN)  :: Molecule_ID
    ! Local variables
    INTEGER :: Id

    ! Setup
    Mass_Density = ZERO
    IF ( Temperature < ZERO .OR. Partial_Pressure < ZERO ) RETURN
    IF ( PRESENT( Molecule_ID ) ) THEN
      IF ( Molecule_ID < 1 .OR. Molecule_ID > MAX_N_MOLECULAR_SPECIES ) RETURN
      Id = Molecule_ID
    ELSE
      Id = 1  ! Default value is for water vapor
    END IF

    ! Convert partial pressure to mass density
    Mass_Density = HPA_TO_PA * Partial_Pressure * MOLECULAR_WEIGHT(Id) / (Temperature * R0)

  END SUBROUTINE PP_to_MD

!------------------------------------------------------------------------------
!:sdoc+:
! NAME:
!       PP_to_MD_TL
!
! PURPOSE:
!       Tangent-linear form of elemental subroutine to convert gas
!       concentrations from partial pressure to mass density.
!
! CALLING SEQUENCE:
!       CALL PP_to_MD_TL( Temperature              , &  ! FWD Input
!                         Partial_Pressure         , &  ! FWD Input
!                         Temperature_TL           , &  ! TL  Input
!                         Partial_Pressure_TL      , &  ! TL  Input
!                         Mass_Density_TL          , &  ! TL  Output
!                         Molecule_ID = Molecule_ID  )  ! Optional Input
!
! INPUTS:
!       Temperature:          Atmospheric temperature
!                             UNITS:      Kelvin, K
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Scalar or any rank
!                             ATTRIBUTES: INTENT(IN)
!
!       Partial_Pressure:     Partial pressure of gas.
!                             UNITS:      hectoPascals, hPa
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Same as Temperature
!                             ATTRIBUTES: INTENT(IN)
!
!       Temperature_TL:       Tangent-linear atmospheric temperature
!                             UNITS:      Kelvin, K
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Same as Temperature
!                             ATTRIBUTES: INTENT(IN)
!
!       Partial_Pressure_TL:  Tangent-linear partial pressure of gas.
!                             UNITS:      hectoPascals, hPa
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Same as Temperature
!                             ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       Mass_Density_TL:      Tangent-linear mass density of gas.
!                             Set to zero for invalid input.
!                             UNITS:      g/m^3
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Same as input Temperature
!                             ATTRIBUTES: INTENT(OUT)
!
! OPTIONAL INPUTS:
!       Molecule_ID:          HITRAN molecular designation identifying the
!                             molecule for which the concentration units
!                             conversion is required. If not specified, the
!                             default value is that for water vapor.
!                             Valid values are:
!                               1: H2O       9: SO2      17: HI       25: H2O2
!                               2: CO2      10: NO2      18: ClO      26: C2H2
!                               3: O3       11: NH3      19: OCS      27: C2H6
!                               4: N2O      12: HNO3     20: H2CO     28: PH3
!                               5: CO       13: OH       21: HOCl     29: COF2
!                               6: CH4      14: HF       22: N2       30: SF6
!                               7: O2       15: HCl      23: HCN      31: H2S
!                               8: NO       16: HBr      24: CH3Cl    32: HCOOH
!                             UNITS:      N/A
!                             TYPE:       INTEGER
!                             DIMENSION:  Scalar
!                             ATTRIBUTES: OPTIONAL, INTENT(IN)
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 24-Sep-2009
!                       paul.vandelst@noaa.gov
!:sdoc-:
!------------------------------------------------------------------------------

  ELEMENTAL SUBROUTINE PP_to_MD_TL( &
    Temperature        , &  ! FWD Input
    Partial_Pressure   , &  ! FWD Input
    Temperature_TL     , &  ! TL  Input
    Partial_Pressure_TL, &  ! TL  Input
    Mass_Density_TL    , &  ! TL  Output
    Molecule_ID          )  ! Optional Input
    ! Arguments
    REAL(fp),          INTENT(IN)  :: Temperature
    REAL(fp),          INTENT(IN)  :: Partial_Pressure
    REAL(fp),          INTENT(IN)  :: Temperature_TL
    REAL(fp),          INTENT(IN)  :: Partial_Pressure_TL
    REAL(fp),          INTENT(OUT) :: Mass_Density_TL
    INTEGER, OPTIONAL, INTENT(IN)  :: Molecule_ID
    ! Local variables
    INTEGER :: Id
    REAL(fp) :: c

    ! Setup
    Mass_Density_TL = ZERO
    IF ( Temperature < ZERO .OR. Partial_Pressure < ZERO ) RETURN
    IF ( PRESENT( Molecule_ID ) ) THEN
      IF ( Molecule_ID < 1 .OR. Molecule_ID > MAX_N_MOLECULAR_SPECIES ) RETURN
      Id = Molecule_ID
    ELSE
      Id = 1  ! Default value is for water vapor
    END IF

    ! Tangent-linear form of partial pressure to mass density conversion
    c = HPA_TO_PA * MOLECULAR_WEIGHT(Id) / R0
    Mass_Density_TL = c * ((Temperature * Partial_Pressure_TL) - &
                           (Partial_Pressure * Temperature_TL)) / Temperature**2

  END SUBROUTINE PP_to_MD_TL

!------------------------------------------------------------------------------
!:sdoc+:
! NAME:
!       PP_to_MD_AD
!
! PURPOSE:
!       Adjoint form of elemental subroutine to convert gas
!       concentrations from partial pressure to mass density.
!
! CALLING SEQUENCE:
!       CALL PP_to_MD_AD( Temperature              , &  ! FWD Input
!                         Partial_Pressure         , &  ! FWD Input
!                         Mass_Density_AD          , &  ! AD  Input
!                         Temperature_AD           , &  ! AD  Output
!                         Partial_Pressure_AD      , &  ! AD  Output
!                         Molecule_ID = Molecule_ID  )  ! Optional Input
!
! INPUTS:
!       Temperature:          Atmospheric temperature
!                             UNITS:      Kelvin, K
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Scalar or any rank
!                             ATTRIBUTES: INTENT(IN)
!
!       Partial_Pressure:     Partial pressure of gas.
!                             UNITS:      hectoPascals, hPa
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Same as Temperature
!                             ATTRIBUTES: INTENT(IN)
!
!       Mass_Density_AD:      Adjoint mass density of gas.
!                             *** SET TO ZERO ON EXIT ***
!                             UNITS:      g/m^3
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Same as Temperature
!                             ATTRIBUTES: INTENT(IN OUT)
!
! OUTPUTS:
!       Temperature_AD:       Adjoint atmospheric temperature
!                             *** MUST HAVE VALUE ON ENTRY ***
!                             UNITS:      Kelvin, K
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Same as input Temperature
!                             ATTRIBUTES: INTENT(IN OUT)
!
!       Partial_Pressure_AD:  Adjoint partial pressure of gas.
!                             *** MUST HAVE VALUE ON ENTRY ***
!                             UNITS:      hectoPascals, hPa
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Same as input Temperature
!                             ATTRIBUTES: INTENT(IN OUT)
!
! OPTIONAL INPUTS:
!       Molecule_ID:          HITRAN molecular designation identifying the
!                             molecule for which the concentration units
!                             conversion is required. If not specified, the
!                             default value is that for water vapor.
!                             Valid values are:
!                               1: H2O       9: SO2      17: HI       25: H2O2
!                               2: CO2      10: NO2      18: ClO      26: C2H2
!                               3: O3       11: NH3      19: OCS      27: C2H6
!                               4: N2O      12: HNO3     20: H2CO     28: PH3
!                               5: CO       13: OH       21: HOCl     29: COF2
!                               6: CH4      14: HF       22: N2       30: SF6
!                               7: O2       15: HCl      23: HCN      31: H2S
!                               8: NO       16: HBr      24: CH3Cl    32: HCOOH
!                             UNITS:      N/A
!                             TYPE:       INTEGER
!                             DIMENSION:  Scalar
!                             ATTRIBUTES: OPTIONAL, INTENT(IN)
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 24-Sep-2009
!                       paul.vandelst@noaa.gov
!:sdoc-:
!------------------------------------------------------------------------------

  ELEMENTAL SUBROUTINE PP_to_MD_AD( &
    Temperature        , &  ! FWD Input
    Partial_Pressure   , &  ! FWD Input
    Mass_Density_AD    , &  ! AD  Input
    Temperature_AD     , &  ! AD  Output
    Partial_Pressure_AD, &  ! AD  Output
    Molecule_ID          )  ! Optional Input
    ! Arguments
    REAL(fp),          INTENT(IN)     :: Temperature
    REAL(fp),          INTENT(IN)     :: Partial_Pressure
    REAL(fp),          INTENT(IN OUT) :: Mass_Density_AD
    REAL(fp),          INTENT(IN OUT) :: Temperature_AD
    REAL(fp),          INTENT(IN OUT) :: Partial_Pressure_AD
    INTEGER, OPTIONAL, INTENT(IN)     :: Molecule_ID
    ! Local variables
    INTEGER :: Id
    REAL(fp) :: c

    ! Setup
    IF ( Temperature < ZERO .OR. Partial_Pressure < ZERO ) THEN
      Mass_Density_AD     = ZERO
      Temperature_AD      = ZERO
      Partial_Pressure_AD = ZERO
      RETURN
    END IF
    IF ( PRESENT( Molecule_ID ) ) THEN
      IF ( Molecule_ID < 1 .OR. Molecule_ID > MAX_N_MOLECULAR_SPECIES ) THEN
        Mass_Density_AD     = ZERO
        Temperature_AD      = ZERO
        Partial_Pressure_AD = ZERO
        RETURN
      END IF
      Id = Molecule_ID
    ELSE
      Id = 1  ! Default value is for water vapor
    END IF

    ! Adjoint form of partial pressure to mass density conversion
    c = HPA_TO_PA * MOLECULAR_WEIGHT(Id) / R0
    Temperature_AD = Temperature_AD - (c * Partial_Pressure * Mass_Density_AD / Temperature**2)
    Partial_Pressure_AD = Partial_Pressure_AD + (c * Mass_Density_AD / Temperature)
    Mass_Density_AD = ZERO

  END SUBROUTINE PP_to_MD_AD

!------------------------------------------------------------------------------
!:sdoc+:
! NAME:
!       MD_to_PP
!
! PURPOSE:
!       Elemental subroutine to convert gas concentration mass density
!       to partial pressure.
!
! CALLING SEQUENCE:
!       CALL MD_to_PP( Temperature              , &  ! Input
!                      Mass_Density             , &  ! Input
!                      Partial_Pressure         , &  ! Output
!                      Molecule_ID = Molecule_ID  )  ! Optional Input
!
! INPUTS:
!       Temperature:       Atmospheric temperature
!                          UNITS:      Kelvin, K
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Scalar or any rank
!                          ATTRIBUTES: INTENT(IN)
!
!       Mass_Density:      Mass density of gas.
!                          UNITS:      g/m^3
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Same as Temperature
!                          ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       Partial_Pressure:  Partial pressure of gas.
!                          Set to zero for invalid input.
!                          UNITS:      hectoPascals, hPa
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Same as input Temperature
!                          ATTRIBUTES: INTENT(OUT)
!
! OPTIONAL INPUTS:
!       Molecule_ID:       HITRAN molecular designation identifying the
!                          molecule for which the concentration units
!                          conversion is required. If not specified, the
!                          default value is that for water vapor.
!                          Valid values are:
!                            1: H2O       9: SO2      17: HI       25: H2O2
!                            2: CO2      10: NO2      18: ClO      26: C2H2
!                            3: O3       11: NH3      19: OCS      27: C2H6
!                            4: N2O      12: HNO3     20: H2CO     28: PH3
!                            5: CO       13: OH       21: HOCl     29: COF2
!                            6: CH4      14: HF       22: N2       30: SF6
!                            7: O2       15: HCl      23: HCN      31: H2S
!                            8: NO       16: HBr      24: CH3Cl    32: HCOOH
!                          UNITS:      N/A
!                          TYPE:       INTEGER
!                          DIMENSION:  Scalar
!                          ATTRIBUTES: OPTIONAL, INTENT(IN)
!
! PROCEDURE:
!       The ideal gas law is
!
!         p.V = n.R.T
!
!       where,
!         p = Pressure
!         V = volume
!         n = number of moles of the gas,
!         R = molar gas constant,
!         T = Temperature.
!
!       This can be written in terms of the number of molecules, N,
!
!                 N
!         p.V = ---- . R.T                  ..............(1)
!                NA
!
!       where NA = Avogadro's constant (number of molecules in 1 mole.)
!
!       Eqn.(1) can be recast to provide the number of molecules in the
!       volume, the number density, nd,
!
!               N     p.NA
!         nd = --- = ------  molecules/m^3  ..............(2)
!               V     R.T
!
!       The mass density is related to the number density by the simple
!       relation,
!
!                    MW
!         md = nd . ----                    ..............(3)
!                    NA
!
!       Substituting equation (2) into (3) gives,
!
!               p.MW
!         md = ------  g/m^3                ..............(4)
!               R.T
!
!       and inverting equation (4) gives,
!
!              md.R.T
!         p = -------- Pa
!                MW
!
!       The pressure result above is determined in units of Pascals, so there
!       is a factor of 100 to include to return the pressure in units of
!       hectoPascals,
!
!              md.R.T
!         p = -------- hPa
!              100.MW
!
! UNITS ANALYSIS:
!       md :  g.m^-3
!       R  :  J.mol^-1.K^-1 == kg.m^2.s^-2.mol^-1.K^-1
!       T  :  K
!       MW :  g.mol^-1
!
!                g        kg.m^2          mol
!         p == ----- . ----------- . K . -----
!               m^3     s^2.mol.K          g
!
!                 kg
!           == -------
!               m.s^2
!
!               kg.m.s^-2      F
!           == ----------- == --- == pressure.
!                  m^2         A
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 08-Nov-2004
!                       paul.vandelst@noaa.gov
!:sdoc-:
!------------------------------------------------------------------------------

  ELEMENTAL SUBROUTINE MD_to_PP( &
    Temperature     , &  ! Input
    Mass_Density    , &  ! Input
    Partial_Pressure, &  ! Output
    Molecule_ID       )  ! Optional Input
    ! Arguments
    REAL(fp),          INTENT(IN)  :: Temperature
    REAL(fp),          INTENT(IN)  :: Mass_Density
    REAL(fp),          INTENT(OUT) :: Partial_Pressure
    INTEGER, OPTIONAL, INTENT(IN)  :: Molecule_ID
    ! Local variables
    INTEGER :: Id

    ! Setup
    Partial_Pressure = ZERO
    IF ( Temperature < ZERO .OR. Mass_Density < ZERO ) RETURN
    IF ( PRESENT( Molecule_ID ) ) THEN
      IF ( Molecule_ID < 1 .OR. Molecule_ID > MAX_N_MOLECULAR_SPECIES ) RETURN
      Id = Molecule_ID
    ELSE
      Id = 1  ! Default value is for water vapor
    END IF

    ! Convert mass density to partial pressure
    Partial_Pressure = PA_TO_HPA * Mass_Density * R0 * Temperature / MOLECULAR_WEIGHT(Id)

  END SUBROUTINE MD_to_PP

!------------------------------------------------------------------------------
!:sdoc+:
! NAME:
!       MD_to_PP_TL
!
! PURPOSE:
!       Tangent-linear form of elemental subroutine to convert gas
!       concentration mass density to partial pressure.
!
! CALLING SEQUENCE:
!       CALL MD_to_PP_TL( Temperature              , &  ! FWD Input
!                         Mass_Density             , &  ! FWD Input
!                         Temperature_TL           , &  ! TL  Input
!                         Mass_Density_TL          , &  ! TL  Input
!                         Partial_Pressure_TL      , &  ! TL  Output
!                         Molecule_ID = Molecule_ID  )  ! Optional Input
!
! INPUTS:
!       Temperature:          Atmospheric temperature
!                             UNITS:      Kelvin, K
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Scalar or any rank
!                             ATTRIBUTES: INTENT(IN)
!
!       Mass_Density:         Mass density of gas.
!                             UNITS:      g/m^3
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Same as Temperature
!                             ATTRIBUTES: INTENT(IN)
!
!       Temperature_TL:       Tangent-linear atmospheric temperature
!                             UNITS:      Kelvin, K
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Same as Temperature
!                             ATTRIBUTES: INTENT(IN)
!
!       Mass_Density_TL:      Tangent-linear mass density of gas.
!                             UNITS:      g/m^3
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Same as Temperature
!                             ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       Partial_Pressure_TL:  Tangent-linear partial pressure of gas.
!                             Set to zero for invalid input.
!                             UNITS:      hectoPascals, hPa
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Same as input Temperature
!                             ATTRIBUTES: INTENT(OUT)
!
! OPTIONAL INPUTS:
!       Molecule_ID:          HITRAN molecular designation identifying the
!                             molecule for which the concentration units
!                             conversion is required. If not specified, the
!                             default value is that for water vapor.
!                             Valid values are:
!                               1: H2O       9: SO2      17: HI       25: H2O2
!                               2: CO2      10: NO2      18: ClO      26: C2H2
!                               3: O3       11: NH3      19: OCS      27: C2H6
!                               4: N2O      12: HNO3     20: H2CO     28: PH3
!                               5: CO       13: OH       21: HOCl     29: COF2
!                               6: CH4      14: HF       22: N2       30: SF6
!                               7: O2       15: HCl      23: HCN      31: H2S
!                               8: NO       16: HBr      24: CH3Cl    32: HCOOH
!                             UNITS:      N/A
!                             TYPE:       INTEGER
!                             DIMENSION:  Scalar
!                             ATTRIBUTES: OPTIONAL, INTENT(IN)
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 24-Sep-2009
!                       paul.vandelst@noaa.gov
!:sdoc-:
!------------------------------------------------------------------------------

  ELEMENTAL SUBROUTINE MD_to_PP_TL( &
    Temperature        , &  ! FWD Input
    Mass_Density       , &  ! FWD Input
    Temperature_TL     , &  ! TL  Input
    Mass_Density_TL    , &  ! TL  Input
    Partial_Pressure_TL, &  ! TL  Output
    Molecule_ID          )  ! Optional Input
    ! Arguments
    REAL(fp),          INTENT(IN)  :: Temperature
    REAL(fp),          INTENT(IN)  :: Mass_Density
    REAL(fp),          INTENT(IN)  :: Temperature_TL
    REAL(fp),          INTENT(IN)  :: Mass_Density_TL
    REAL(fp),          INTENT(OUT) :: Partial_Pressure_TL
    INTEGER, OPTIONAL, INTENT(IN)  :: Molecule_ID
    ! Local variables
    INTEGER :: Id
    REAL(fp) :: c

    ! Setup
    Partial_Pressure_TL = ZERO
    IF ( Temperature < ZERO .OR. Mass_Density < ZERO ) RETURN
    IF ( PRESENT( Molecule_ID ) ) THEN
      IF ( Molecule_ID < 1 .OR. Molecule_ID > MAX_N_MOLECULAR_SPECIES ) RETURN
      Id = Molecule_ID
    ELSE
      Id = 1  ! Default value is for water vapor
    END IF

    ! Tangent-linear form of mass density to partial pressure conversion
    c = PA_TO_HPA * R0 / MOLECULAR_WEIGHT(Id)
    Partial_Pressure_TL = c * ((Mass_Density * Temperature_TL) + &
                               (Temperature * Mass_Density_TL) )

  END SUBROUTINE MD_to_PP_TL

!------------------------------------------------------------------------------
!:sdoc+:
! NAME:
!       MD_to_PP_AD
!
! PURPOSE:
!       Adjoint form of elemental subroutine to convert gas
!       concentration mass density to partial pressure.
!
! CALLING SEQUENCE:
!       CALL MD_to_PP_AD( Temperature              , &  ! FWD Input
!                         Mass_Density             , &  ! FWD Input
!                         Partial_Pressure_AD      , &  ! AD  Input
!                         Temperature_AD           , &  ! AD  Output
!                         Mass_Density_AD          , &  ! AD  Output
!                         Molecule_ID = Molecule_ID  )  ! Optional Input
!
! INPUTS:
!       Temperature:          Atmospheric temperature
!                             UNITS:      Kelvin, K
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Scalar or any rank
!                             ATTRIBUTES: INTENT(IN)
!
!       Mass_Density:         Mass density of gas.
!                             UNITS:      g/m^3
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Same as Temperature
!                             ATTRIBUTES: INTENT(IN)
!
!       Partial_Pressure_AD:  Adjoint partial pressure of gas.
!                             *** SET TO ZERO ON EXIT ***
!                             UNITS:      hectoPascals, hPa
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Same as Temperature
!                             ATTRIBUTES: INTENT(IN OUT)
!
! OUTPUTS:
!       Temperature_AD:       Adjoint atmospheric temperature
!                             *** MUST HAVE VALUE ON ENTRY ***
!                             UNITS:      Kelvin, K
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Same as input Temperature
!                             ATTRIBUTES: INTENT(IN OUT)
!
!       Mass_Density_AD:      Adjoint mass density of gas.
!                             *** MUST HAVE VALUE ON ENTRY ***
!                             UNITS:      g/m^3
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Same as input Temperature
!                             ATTRIBUTES: INTENT(IN OUT)
!
! OPTIONAL INPUTS:
!       Molecule_ID:          HITRAN molecular designation identifying the
!                             molecule for which the concentration units
!                             conversion is required. If not specified, the
!                             default value is that for water vapor.
!                             Valid values are:
!                               1: H2O       9: SO2      17: HI       25: H2O2
!                               2: CO2      10: NO2      18: ClO      26: C2H2
!                               3: O3       11: NH3      19: OCS      27: C2H6
!                               4: N2O      12: HNO3     20: H2CO     28: PH3
!                               5: CO       13: OH       21: HOCl     29: COF2
!                               6: CH4      14: HF       22: N2       30: SF6
!                               7: O2       15: HCl      23: HCN      31: H2S
!                               8: NO       16: HBr      24: CH3Cl    32: HCOOH
!                             UNITS:      N/A
!                             TYPE:       INTEGER
!                             DIMENSION:  Scalar
!                             ATTRIBUTES: OPTIONAL, INTENT(IN)
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 24-Sep-2009
!                       paul.vandelst@noaa.gov
!:sdoc-:
!------------------------------------------------------------------------------

  ELEMENTAL SUBROUTINE MD_to_PP_AD( &
    Temperature        , &  ! FWD Input
    Mass_Density       , &  ! FWD Input
    Partial_Pressure_AD, &  ! AD  Input
    Temperature_AD     , &  ! AD  Output
    Mass_Density_AD    , &  ! AD  Output
    Molecule_ID          )  ! Optional Input
    ! Arguments
    REAL(fp),          INTENT(IN)     :: Temperature
    REAL(fp),          INTENT(IN)     :: Mass_Density
    REAL(fp),          INTENT(IN OUT) :: Partial_Pressure_AD
    REAL(fp),          INTENT(IN OUT) :: Temperature_AD
    REAL(fp),          INTENT(IN OUT) :: Mass_Density_AD
    INTEGER, OPTIONAL, INTENT(IN)     :: Molecule_ID
    ! Local variables
    INTEGER :: Id
    REAL(fp) :: c

    ! Setup
    IF ( Temperature < ZERO .OR. Mass_Density < ZERO ) THEN
      Partial_Pressure_AD = ZERO
      Temperature_AD      = ZERO
      Mass_Density_AD     = ZERO
      RETURN
    END IF
    IF ( PRESENT( Molecule_ID ) ) THEN
      IF ( Molecule_ID < 1 .OR. Molecule_ID > MAX_N_MOLECULAR_SPECIES ) THEN
        Partial_Pressure_AD = ZERO
        Temperature_AD      = ZERO
        Mass_Density_AD     = ZERO
        RETURN
      END IF
      Id = Molecule_ID
    ELSE
      Id = 1  ! Default value is for water vapor
    END IF

    ! Adjoint form of mass density to partial pressure conversion
    c = PA_TO_HPA * R0 / MOLECULAR_WEIGHT(Id)
    Mass_Density_AD = Mass_Density_AD + (c * Temperature  * Partial_Pressure_AD)
    Temperature_AD  = Temperature_AD  + (c * Mass_Density * Partial_Pressure_AD)
    Partial_Pressure_AD = ZERO

  END SUBROUTINE MD_to_PP_AD

END MODULE PP_MD


C
C**************************  CELL_NOD_TRA ******************************
C
C  transfer cell-values to nodal values taking into account
C  possible coarsening of the triangulation (dostep>1)
C
C***********************************************************************
C
      subroutine cell_nod_tra(ntri,nnod,tp2d,triang,conccel,concnod,
     1                        delta_x,delta_y,arenod,pondcel,pondnod)
C
      implicit none
      integer ntri,nnod
      integer k,ii,inod,i,icell
      integer tp2d(*),triang(4,*)
      real*8  concnod(*),conccel(*)
      real*8  mass_node(nnod)
      real*8  delta_x,delta_y,arenod(*)
      real*8  pondcel(*),pondnod(*)
C
      call init0r(nnod,mass_node)
      call init0r(nnod,concnod)
      do k=1,nnod
        tp2d(k)=0
      end do

      DO K=1,ntri
         icell = k/2 + mod(k,2)
         DO II=1,3
            INOD=TRIANG(II,K)
            mass_node(INOD) = mass_node(INOD) + conccel(icell) *
     1                        delta_x*delta_y*pondcel(icell)
            TP2d(INOD)=TP2d(INOD)+1
         END DO
      END DO
      DO i=1,NNOD
         if (pondnod(i).NE.0.0d0) then
            concnod(i) = mass_node(i)/(TP2d(i)*arenod(i)*pondnod(i))
         end if
      END DO
C
      RETURN
      END


PROGRAM smwidth
  USE ReadParam
  USE Func_PSI
  USE WDecay
  USE ZDecay
  USE tDecay
  USE H0Decay
  IMPLICIT NONE
  REAL(KIND(1d0))::reslo,resqcd,resqed,resqcdqed,argarg,resmass
  CHARACTER(len=100)::paramcard
  INTEGER,PARAMETER::PID_Z=23,PID_W=24,PID_H=25,PID_t=6
  CHARACTER(len=1)::cscheme
  Skip_scheme=.TRUE.
  IF(iargc().NE.3)THEN
     WRITE(*,*)"ERROR: Please input three arguments"
     STOP
  ENDIF
  CALL getarg(1,paramcard)
  CALL getarg(2,identcard)
  CALL getarg(3,cscheme)
  IF(cscheme.EQ."2")THEN
     Decay_scheme=2
  ELSE
     Decay_scheme=1
  ENDIF
  CALL ReadParamCard(paramcard)
  resqcdqed=SMWWidth(1,1)
  WRITE(*,*)" --------------------------"
  WRITE(*,*)" Decay Widths (GeV) in SM: "
  WRITE(*,100)'decay',PID_W,resqcdqed
  resqcdqed=SMZWidth(1,1)
  WRITE(*,100)'decay',PID_Z,resqcdqed
  ! include finite-width effect which is also at NLO EW order
  resqcdqed=SMtWidth(1,1,.FALSE.,.TRUE.)
  WRITE(*,100)'decay',PID_t,resqcdqed
  resqcdqed=SMHWidth(0)
  WRITE(*,100)'decay',PID_H,resqcdqed
  WRITE(*,*)" --------------------------"
  RETURN
100 FORMAT(2X,A5,2X,I2,2X,E12.6)
END PROGRAM smwidth


!========================================================================
!
!                   S P E C F E M 2 D  Version 7 . 0
!                   --------------------------------
!
!     Main historical authors: Dimitri Komatitsch and Jeroen Tromp
!                        Princeton University, USA
!                and CNRS / University of Marseille, France
!                 (there are currently many more authors!)
! (c) Princeton University and CNRS / University of Marseille, April 2014
!
! This software is a computer program whose purpose is to solve
! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
! using a spectral-element method (SEM).
!
! This software is governed by the CeCILL license under French law and
! abiding by the rules of distribution of free software. You can use,
! modify and/or redistribute the software under the terms of the CeCILL
! license as circulated by CEA, CNRS and Inria at the following URL
! "http://www.cecill.info".
!
! As a counterpart to the access to the source code and rights to copy,
! modify and redistribute granted by the license, users are provided only
! with a limited warranty and the software's author, the holder of the
! economic rights, and the successive licensors have only limited
! liability.
!
! In this respect, the user's attention is drawn to the risks associated
! with loading, using, modifying and/or developing or reproducing the
! software by the user in light of its specific status of free software,
! that may mean that it is complicated to manipulate, and that also
! therefore means that it is reserved for developers and experienced
! professionals having in-depth computer knowledge. Users are therefore
! encouraged to load and test the software's suitability as regards their
! requirements in conditions enabling the security of their systems and/or
! data to be ensured and, more generally, to use and operate it in the
! same conditions as regards security.
!
! The full text of the license is available in file "LICENSE".
!
!========================================================================

! compute analytical initial plane wave for Bielak's conditions

subroutine compute_Bielak_conditions(coord,iglob,nglob,it,deltat,dxUx,dxUz,dzUx,dzUz,veloc_horiz,veloc_vert, &
     x0_source, z0_source, A_plane, B_plane, C_plane, anglesource, anglesource_refl, &
     c_inc, c_refl, time_offset,f0)

  implicit none

  include "constants.h"

  integer, intent(in) :: iglob,nglob,it

  double precision, intent(in) :: deltat

  double precision, intent(out) :: dxUx,dxUz,dzUx,dzUz,veloc_horiz,veloc_vert

  double precision, dimension(NDIM,nglob), intent(in) :: coord

  double precision :: time_veloc,time_traction,t,x,z

  double precision, external :: ricker_Bielak_veloc

  double precision x0_source, z0_source, anglesource, anglesource_refl
  double precision c_inc, c_refl, time_offset, f0
  double precision, dimension(NDIM) :: A_plane, B_plane, C_plane

! get the coordinates of the mesh point
  x = coord(1,iglob) - x0_source
  z = z0_source - coord(2,iglob)

! times for velocity and traction are staggered i.e. separated by deltat/2.d0
  time_veloc = (it-1)*deltat + deltat/2.d0 + time_offset
  time_traction = time_veloc + deltat/2.d0

  t = time_traction

!!$!SV30
!!$
!!$!analytical expression of the displacement for a SV 30 degrees and 0.3333 poisson ratio
!!$!  Ux = sqrt(3.d0)/2.d0 * rickertest(t - x/2.d0 + (9 - z) * sqrt(3.d0)/2.d0) &
!!$!     + sqrt(3.d0)/2.d0 * rickertest(t - x/2.d0 - (9 - z) * sqrt(3.d0)/2.d0) &
!!$!     + sqrt(3.d0) * rickertest(t - x/2.d0)
!!$!  Uz = - HALF * rickertest(t - x/2.d0 + (9 - z) * sqrt(3.d0)/2.d0) &
!!$!       + HALF * rickertest(t - x/2.d0 - (9 - z) * sqrt(3.d0)/2.d0)
!!$
!!$
!!$! derivatives of analytical expression of horizontal and vertical displacements,
!!$! computed using the "Mathematica" script in UTILS/deriv_ricker_spatial.m
!!$  dxUx = (sqrt(3.d0)*a*((-8*t + 4*x)*exp(-a*(t - x/2.d0)**2) + &
!!$      ((2*t - x)*(-2 + a*(-2*t + x)**2))*exp(-a*(t - x/2.d0)**2) + &
!!$      (2*(-2*t + x - sqrt(3.d0)*(-9 + z)))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
!!$      ((1 - (a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/2.d0)* &
!!$         (-2*t + x - sqrt(3.d0)*(-9 + z)))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
!!$      (2*(-2*t + x + sqrt(3.d0)*(-9 + z)))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
!!$      ((1 - (a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/2.d0)* &
!!$         (-2*t + x + sqrt(3.d0)*(-9 + z)))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0)))/4.d0
!!$
!!$  dzUx = (3*a*(((t + (-x + sqrt(3.d0)*(-9 + z))/2.d0)* &
!!$         (1 - (a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/2.d0))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) - &
!!$      ((1 - (a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/2.d0)* &
!!$         (t - x/2.d0 - (sqrt(3.d0)*(-9 + z))/2.d0))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
!!$      (2*t - x + sqrt(3.d0)*(-9 + z))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
!!$      (-2*t + x + sqrt(3.d0)*(-9 + z))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0)))/2.d0
!!$
!!$  dxUz = (a*((2*t - x - sqrt(3.d0)*(-9 + z))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
!!$      (-2*t + x - sqrt(3.d0)*(-9 + z))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
!!$      ((1 - (a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/2.d0)* &
!!$         (-2*t + x - sqrt(3.d0)*(-9 + z)))/2.d0*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) - &
!!$      ((1 - (a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/2.d0)* &
!!$         (-2*t + x + sqrt(3.d0)*(-9 + z)))/2.d0*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0)))/2.d0
!!$
!!$  dzUz = (sqrt(3.d0)*a*(((t + (-x + sqrt(3.d0)*(-9 + z))/2.d0)* &
!!$         (1 - (a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/2.d0))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
!!$      (2*t - x - sqrt(3.d0)*(-9 + z))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
!!$      ((1 - (a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/2.d0)* &
!!$         (t - x/2.d0 - (sqrt(3.d0)*(-9 + z))/2.d0))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
!!$      (2*t - x + sqrt(3.d0)*(-9 + z))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0)))/2.d0

! to compute the derivative of the displacement, we take the velocity ricker expression and we multiply by
! the derivative of the interior argument of ricker_Bielak_veloc

  dxUx = A_plane(1) * ricker_Bielak_veloc(t - sin(anglesource)*x/c_inc + cos(anglesource)*z/c_inc,f0) * (-sin(anglesource)/c_inc)&
       + B_plane(1) * ricker_Bielak_veloc(t - sin(anglesource)*x/c_inc - cos(anglesource)*z/c_inc,f0) * (-sin(anglesource)/c_inc)&
       + C_plane(1) * ricker_Bielak_veloc(t - sin(anglesource_refl)*x/c_refl - cos(anglesource_refl)*z/c_refl,f0)&
       * (-sin(anglesource_refl)/c_refl)

  dzUx = A_plane(1) * ricker_Bielak_veloc(t - sin(anglesource)*x/c_inc + cos(anglesource)*z/c_inc,f0) * (-cos(anglesource)/c_inc)&
       + B_plane(1) * ricker_Bielak_veloc(t - sin(anglesource)*x/c_inc - cos(anglesource)*z/c_inc,f0) * (cos(anglesource)/c_inc)&
       + C_plane(1) * ricker_Bielak_veloc(t - sin(anglesource_refl)*x/c_refl - cos(anglesource_refl)*z/c_refl,f0)&
       * (cos(anglesource_refl)/c_refl)

  dxUz = A_plane(2) * ricker_Bielak_veloc(t - sin(anglesource)*x/c_inc + cos(anglesource)*z/c_inc,f0) * (-sin(anglesource)/c_inc)&
       + B_plane(2) * ricker_Bielak_veloc(t - sin(anglesource)*x/c_inc - cos(anglesource)*z/c_inc,f0) * (-sin(anglesource)/c_inc)&
       + C_plane(2) * ricker_Bielak_veloc(t - sin(anglesource_refl)*x/c_refl - cos(anglesource_refl)*z/c_refl,f0)&
       * (-sin(anglesource_refl)/c_refl)

  dzUz = A_plane(2) * ricker_Bielak_veloc(t - sin(anglesource)*x/c_inc + cos(anglesource)*z/c_inc,f0) * (-cos(anglesource)/c_inc)&
       + B_plane(2) * ricker_Bielak_veloc(t - sin(anglesource)*x/c_inc - cos(anglesource)*z/c_inc,f0) * (cos(anglesource)/c_inc)&
       + C_plane(2) * ricker_Bielak_veloc(t - sin(anglesource_refl)*x/c_refl - cos(anglesource_refl)*z/c_refl,f0)&
       * (cos(anglesource_refl)/c_refl)

  t = time_veloc

!!$!SV30
!!$! analytical expression of the two components of the velocity vector
!!$      veloc_horiz = (sqrt(3.d0)/2.d0) * ricker_Bielak_veloc(t - x/2.d0 + (9 - z) * (sqrt(3.d0)/2.d0)) &
!!$        + (sqrt(3.d0)/2.d0) * ricker_Bielak_veloc(t - x/2.d0 - (9 - z) * (sqrt(3.d0)/2.d0)) &
!!$        + sqrt(3.d0) * ricker_Bielak_veloc(t - x/2.d0)
!!$      veloc_vert = - HALF * ricker_Bielak_veloc(t - x/2.d0 + (9 - z) * (sqrt(3.d0)/2.d0)) &
!!$        + HALF * ricker_Bielak_veloc(t - x/2.d0 - (9 - z) * (sqrt(3.d0)/2.d0))

  veloc_horiz = A_plane(1) * ricker_Bielak_veloc(t - sin(anglesource)*x/c_inc + cos(anglesource)*z/c_inc,f0) &
       + B_plane(1) * ricker_Bielak_veloc(t - sin(anglesource)*x/c_inc - cos(anglesource)*z/c_inc,f0) &
       + C_plane(1) * ricker_Bielak_veloc(t - sin(anglesource_refl)*x/c_refl - cos(anglesource_refl)*z/c_refl,f0)
  veloc_vert = A_plane(2) * ricker_Bielak_veloc(t - sin(anglesource)*x/c_inc + cos(anglesource)*z/c_inc,f0) &
       + B_plane(2) * ricker_Bielak_veloc(t - sin(anglesource)*x/c_inc - cos(anglesource)*z/c_inc,f0) &
       + C_plane(2) * ricker_Bielak_veloc(t - sin(anglesource_refl)*x/c_refl - cos(anglesource_refl)*z/c_refl,f0)

end subroutine compute_Bielak_conditions

! ********

! compute time variation of the source for analytical initial plane wave
double precision function ricker_Bielak_integrale_displ(t,f0)

  implicit none

  include "constants.h"

  double precision :: t,f0,a

  a = pi*pi*f0*f0

! Ricker
  ricker_Bielak_integrale_displ = t*exp(-a*t**2)

end function ricker_Bielak_integrale_displ

! ********

! compute time variation of the source for analytical initial plane wave
double precision function ricker_Bielak_displ(t,f0)

  implicit none

  include "constants.h"

  double precision :: t,f0,a

  a = pi*pi*f0*f0

! Ricker
  ricker_Bielak_displ = (1 - 2*a*t**2)*exp(-a*t**2)

end function ricker_Bielak_displ

! *******

! compute time variation of the source for analytical initial plane wave
double precision function ricker_Bielak_veloc(t,f0)

  implicit none

  include "constants.h"

  double precision :: t,f0,a

  a = pi*pi*f0*f0

! first time derivative of a Ricker
  ricker_Bielak_veloc = - 2*a*t*(3 - 2*a*t**2)*exp(-a*t**2)

end function ricker_Bielak_veloc

! *******

! compute time variation of the source for analytical initial plane wave
double precision function ricker_Bielak_accel(t,f0)

  implicit none

  include "constants.h"

  double precision :: t,f0,a

  a = pi*pi*f0*f0

! second time derivative of a Ricker
  ricker_Bielak_accel = - 2*a*(3 - 12*a*t**2 + 4*a**2*t**4)* exp(-a*t**2)

end function ricker_Bielak_accel