      SUBROUTINE PELWAK(XMOM,PARA,IFAIL)
C***********************************************************************
C*                                                                     *
C*  FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, *
C*  'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' *
C*                                                                     *
C*  J. R. M. HOSKING                                                   *
C*  IBM RESEARCH DIVISION                                              *
C*  T. J. WATSON RESEARCH CENTER                                       *
C*  YORKTOWN HEIGHTS                                                   *
C*  NEW YORK 10598, U.S.A.                                             *
C*                                                                     *
C*  VERSION 3     AUGUST 1996                                          *
C*                                                                     *
C***********************************************************************
C
C  PARAMETER ESTIMATION VIA L-MOMENTS FOR THE WAKEBY DISTRIBUTION
C
C  PARAMETERS OF ROUTINE:
C  XMOM   * INPUT* ARRAY OF LENGTH 5. CONTAINS THE L-MOMENTS LAMBDA-1,
C                  LAMBDA-2, TAU-3, TAU-4, TAU-5.
C  PARA   *OUTPUT* ARRAY OF LENGTH 5. ON EXIT, CONTAINS THE PARAMETERS
C                  IN THE ORDER XI, ALPHA, BETA, GAMMA, DELTA.
C  IFAIL  *OUTPUT* FAIL FLAG. ON EXIT, IT IS SET AS FOLLOWS.
C                  0 SUCCESSFUL EXIT
C                  1 ESTIMATES COULD ONLY BE OBTAINED BY SETTING XI=0
C                  2 ESTIMATES COULD ONLY BE OBTAINED BY FITTING A
C                    GENERALIZED PARETO DISTRIBUTION
C                  3 L-MOMENTS INVALID
C
C  PROCEDURE:
C  1. LOOK FOR A SOLUTION WITH XI UNCONSTRAINED;
C  2. IF NONE FOUND, LOOK FOR A SOLUTION WITH XI=0;
C  3. IF NONE FOUND, FIT A GENERALIZED PARETO DISTRIBUTION TO THE
C     FIRST 3 L-MOMENTS.
C  ESTIMATES ARE CALCULATED USING THE FORMULAS GIVEN BY GREENWOOD ET AL.
C  (1979, WATER RESOUR. RES., TABLE 5), BUT EXPRESSED IN TERMS OF
C  L-MOMENTS RATHER THAN PROBABILITY WEIGHTED MOMENTS.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION XMOM(5),PARA(5)
      DATA ZERO/0D0/,HALF/0.5D0/,ONE/1D0/,TWO/2D0/,THREE/3D0/,FOUR/4D0/
      DATA X2/2D0/,X3/3D0/,X4/4D0/,X5/5D0/,X7/7D0/,X8/8D0/,X9/9D0/,
     *  X10/10D0/,X11/11D0/,X16/16D0/,X25/25D0/,X29/29D0/,X32/32D0/,
     *  X35/35D0/,X85/85D0/,X125/125D0/,X203/203D0/
C
      IF(DABS(XMOM(2)).LE.ZERO)GOTO 1000
      IF(DABS(XMOM(3)).GE.ONE)GOTO 1000
      IF(DABS(XMOM(4)).GE.ONE)GOTO 1000
      IF(DABS(XMOM(5)).GE.ONE)GOTO 1000
      IFAIL=0
C
C         CALCULATE THE L-MOMENTS (LAMBDA'S)
C
      ALAM1=XMOM(1)
      ALAM2=XMOM(2)
      ALAM3=XMOM(3)*ALAM2
      ALAM4=XMOM(4)*ALAM2
      ALAM5=XMOM(5)*ALAM2
C
C         ESTIMATE N1,N2,N3,C1,C2,C3 WHEN XI.NE.0
C
      XN1= X3*ALAM2-X25*ALAM3 +X32*ALAM4
      XN2=-X3*ALAM2 +X5*ALAM3  +X8*ALAM4
      XN3= X3*ALAM2 +X5*ALAM3  +X2*ALAM4
      XC1= X7*ALAM2-X85*ALAM3+X203*ALAM4-X125*ALAM5
      XC2=-X7*ALAM2+X25*ALAM3  +X7*ALAM4 -X25*ALAM5
      XC3= X7*ALAM2 +X5*ALAM3  -X7*ALAM4  -X5*ALAM5
C
C         ESTIMATE B AND D
C
      XA=XN2*XC3-XC2*XN3
      XB=XN1*XC3-XC1*XN3
      XC=XN1*XC2-XC1*XN2
      DISC=XB*XB-FOUR*XA*XC
      IF(DISC.LT.ZERO)GOTO 10
      DISC=DSQRT(DISC)
      ROOT1=HALF*(-XB+DISC)/XA
      ROOT2=HALF*(-XB-DISC)/XA
      B= DMAX1(ROOT1,ROOT2)
      D=-DMIN1(ROOT1,ROOT2)
      IF(D.GE.ONE)GOTO 10
C
C         ESTIMATE A, C AND XI
C
      A=(ONE+B)*(TWO+B)*(THREE+B)/
     *  (FOUR*(B+D))*((ONE+D)*ALAM2-(THREE-D)*ALAM3)
      C=-(ONE-D)*(TWO-D)*(THREE-D)/
     *  (FOUR*(B+D))*((ONE-B)*ALAM2-(THREE+B)*ALAM3)
      XI=ALAM1-A/(ONE+B)-C/(ONE-D)
C
C         CHECK FOR VALID PARAMETERS
C
      IF(C.GE.ZERO.AND.A+C.GE.ZERO)GOTO 30
C
C         CAN'T FIND VALID ESTIMATES FOR XI UNRESTRICTED, SO TRY XI=0
C
C         ESTIMATE B AND D FOR XI=0
C
   10 IFAIL=1
      XI=ZERO
      ZN1=X4*ALAM1-X11*ALAM2+X9*ALAM3
      ZN2=-ALAM2+X3*ALAM3
      ZN3=ALAM2+ALAM3
      ZC1=X10*ALAM1-X29*ALAM2+X35*ALAM3-X16*ALAM4
      ZC2=-ALAM2+X5*ALAM3-X4*ALAM4
      ZC3=ALAM2-ALAM4
      ZA=ZN2*ZC3-ZC2*ZN3
      ZB=ZN1*ZC3-ZC1*ZN3
      ZC=ZN1*ZC2-ZC1*ZN2
      DISC=ZB*ZB-FOUR*ZA*ZC
      IF(DISC.LT.ZERO)GOTO 20
      DISC=DSQRT(DISC)
      ROOT1=HALF*(-ZB+DISC)/ZA
      ROOT2=HALF*(-ZB-DISC)/ZA
      B= DMAX1(ROOT1,ROOT2)
      D=-DMIN1(ROOT1,ROOT2)
      IF(D.GE.ONE)GOTO 20
C
C         ESTIMATE A AND C
C
      A= (ONE+B)*(TWO+B)/(B+D)*(ALAM1-(TWO-D)*ALAM2)
      C=-(ONE-D)*(TWO-D)/(B+D)*(ALAM1-(TWO+B)*ALAM2)
      IF(C.GE.ZERO.AND.A+C.GE.ZERO)GOTO 30
C
C         CAN'T FIND VALID ESTIMATES EVEN WITH XI=0 -
C         FIT GENERALIZED PARETO DISTRIBUTION INSTEAD
C
   20 IFAIL=2
      D=-(ONE-THREE*XMOM(3))/(ONE+XMOM(3))
      C=(ONE-D)*(TWO-D)*XMOM(2)
      B=ZERO
      A=ZERO
      XI=XMOM(1)-C/(ONE-D)
      IF(D.GT.ZERO)GOTO 30
      A=C
      B=-D
      C=ZERO
      D=ZERO
C
C         COPY RESULTS INTO ARRAY PARA
C
   30 PARA(1)=XI
      PARA(2)=A
      PARA(3)=B
      PARA(4)=C
      PARA(5)=D
      RETURN
C
 1000 IFAIL=3
      DO 1010 I=1,5
 1010 PARA(I)=ZERO
      END


!==========================================================================
elemental subroutine gsw_ct_second_derivatives (sa, pt, ct_sa_sa, ct_sa_pt, &
                                                ct_pt_pt)
!==========================================================================
!
!  Calculates the following three, second-order derivatives of Conservative
!  Temperature
!   (1) CT_SA_SA, the second derivative with respect to Absolute Salinity
!       at constant potential temperature (with p_ref = 0 dbar),
!   (2) CT_SA_pt, the derivative with respect to potential temperature
!       (the regular potential temperature which is referenced to 0 dbar)
!       and Absolute Salinity, and
!   (3) CT_pt_pt, the second derivative with respect to potential
!       temperature (the regular potential temperature which is referenced
!       to 0 dbar) at constant Absolute Salinity.
!
!  SA  =  Absolute Salinity                                        [ g/kg ]
!  pt  =  potential temperature (ITS-90)                          [ deg C ]
!         (whose reference pressure is 0 dbar)
!
!  CT_SA_SA  =  The second derivative of Conservative Temperature with
!               respect to Absolute Salinity at constant potential
!               temperature (the regular potential temperature which
!               has reference sea pressure of 0 dbar).
!               CT_SA_SA has units of:                     [ K/((g/kg)^2) ]
!  CT_SA_pt  =  The derivative of Conservative Temperature with
!               respect to potential temperature (the regular one with
!               p_ref = 0 dbar) and Absolute Salinity.
!               CT_SA_pt has units of:                        [ 1/(g/kg) ]
!  CT_pt_pt  =  The second derivative of Conservative Temperature with
!               respect to potential temperature (the regular one with
!               p_ref = 0 dbar) at constant SA.
!               CT_pt_pt has units of:                              [ 1/K ]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_ct_first_derivatives

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, pt
real (r8), intent(out), optional :: ct_sa_sa, ct_sa_pt, ct_pt_pt

real (r8) :: ct_pt_l, ct_pt_u, ct_sa_l, ct_sa_u, pt_l, pt_u, sa_l, sa_u

real (r8), parameter :: dsa = 1e-3_r8, dpt = 1e-2_r8

if (present(ct_sa_sa)) then

    sa_l = max(sa - dsa, 0.0_r8)
    sa_u = sa + dsa

    call gsw_ct_first_derivatives(sa_l,pt,ct_sa=ct_sa_l)
    call gsw_ct_first_derivatives(sa_u,pt,ct_sa=ct_sa_u)

    ct_sa_sa = (ct_sa_u - ct_sa_l)/(sa_u - sa_l)

end if

if (present(ct_sa_pt) .or. present(ct_pt_pt)) then

    pt_l = pt - dpt
    pt_u = pt + dpt

    if (present(ct_sa_pt) .and. present(ct_pt_pt)) then

        call gsw_ct_first_derivatives(sa,pt_l,ct_sa_l,ct_pt_l)
        call gsw_ct_first_derivatives(sa,pt_u,ct_sa_u,ct_pt_u)

        ct_sa_pt = (ct_sa_u - ct_sa_l)/(pt_u - pt_l)
        ct_pt_pt = (ct_pt_u - ct_pt_l)/(pt_u - pt_l)

    else if (present(ct_sa_pt) .and. .not. present(ct_pt_pt)) then

        call gsw_ct_first_derivatives(sa,pt_l,ct_sa=ct_sa_l)
        call gsw_ct_first_derivatives(sa,pt_u,ct_sa=ct_sa_u)

        ct_sa_pt = (ct_sa_u - ct_sa_l)/(pt_u - pt_l)

    else if (.not. present(ct_sa_pt) .and. present(ct_pt_pt)) then

        call gsw_ct_first_derivatives(sa,pt_l,ct_pt=ct_pt_l)
        call gsw_ct_first_derivatives(sa,pt_u,ct_pt=ct_pt_u)

        ct_pt_pt = (ct_pt_u - ct_pt_l)/(pt_u - pt_l)

    end if

end if

return
end subroutine

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


SUBROUTINE UHYPER(I1B, I2B, JAC, U, DU, D2U, D3U, TEMP, NOEL, CMNAME, &
     INCMPFLAG, NSTATEV, STATEV, NFIELDV, FIELDV, FIELDVINC, &
     NPROPS, PROPS)
  ! ----------------------------------------------------------------------- !
  ! HYPERELASTIC COMPRESSIBLE NEO-HOOKEAN MATERIAL
  ! ----------------------------------------------------------------------- !
  ! CANNOT BE USED FOR PLANE STRESS
  ! PROPS(1)  - C10
  ! PROPS(2)  - D1
  ! ----------------------------------------------------------------------- !
  IMPLICIT NONE
  INTEGER, PARAMETER :: DP=SELECTED_REAL_KIND(14)
  REAL(KIND=DP), PARAMETER :: ZERO=0._DP, ONE=1._DP, TWO=2._DP, THREE=3._DP
  CHARACTER*8, INTENT(IN) :: CMNAME
  INTEGER, INTENT(IN) :: NPROPS, NOEL, NSTATEV, INCMPFLAG, NFIELDV
  REAL(KIND=DP), INTENT(IN) :: I1B, I2B, JAC, PROPS(NPROPS), TEMP
  REAL(KIND=DP), INTENT(INOUT) :: U(2), DU(3), D2U(6), D3U(6), STATEV(NSTATEV)
  REAL(KIND=DP), INTENT(INOUT) :: FIELDV(NFIELDV), FIELDVINC(NFIELDV)
  REAL(KIND=DP) :: C10, D1, U_VOL, U_DEV
  ! -------------------------------------------------------------- UHYPER --- !

  C10 = PROPS(1)
  D1 = PROPS(2)

  ! ENERGY: U
  U_VOL = ONE / D1 * (JAC - ONE) ** 2
  U_DEV = C10 * (I1B - THREE)
  U(1) = U_VOL + U_DEV
  U(2) = U_DEV

  ! FIRST DERIVATIVE OF ENERGY: DU
  DU(1) = C10                       ! DU/DI1B
  DU(2) = ZERO                      ! DU/DI2B
  DU(3) = TWO / D1 * (JAC - ONE)    ! DU/DJ

  ! SECOND DERIVATIVE OF ENERGY: D2U
  D2U(1) = ZERO      ! D(DU/DI1B)/DI1B
  D2U(2) = ZERO      ! D(DU/DI2B)/DI2B
  D2U(3) = TWO / D1  ! D(DU/DJ)/DJ
  D2U(4) = ZERO      ! D(DU/DI1B)/DI2B
  D2U(5) = ZERO      ! D(DU/DI1B)/DJ
  D2U(6) = ZERO      ! D(DU/DI2B)/DJ

  ! THIRD DERIVATIVE OF ENERGY: D3U
  D3U(1) = ZERO      ! D(D(DU/DI1B)/DI1B)/DJ
  D3U(2) = ZERO      ! D(D(DU/DI2B)/DI2B)/DJ
  D3U(3) = ZERO      ! D(D(DU/DI1B)/DI2B)/DJ
  D3U(4) = ZERO      ! D(D(DU/DI1B)/DJ)/DJ
  D3U(5) = ZERO      ! D(D(DU/DI1B)/DJ)/DJ
  D3U(6) = ZERO      ! D(D(DU/DJ)/DJ)/DJ
  RETURN
END SUBROUTINE UHYPER


!
!  Copyright 2016 ARTED developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
subroutine init_Ac_basis_expansion_Houston_probe_decomp
  use global_variables
  implicit none
  integer :: iter
  real(8) :: tt
  real(8) :: f0_1,f0_2,omega_1,omega_2,tpulse_1,tpulse_2,T1_T2

  if(myrank == 0)write(*,"(A)")"== Start: Initialization of vector potential."

  allocate(Actot_BE(0:Nt+2),javt_BE(0:Nt+1,3))
  allocate(Ac_pump_BE(0:Nt+2),Ac_probe_BE(0:Nt+2))

  f0_1=5.338d-9*sqrt(IWcm2_1)      ! electric field in a.u.
  omega_1=omegaev_1/(2d0*Ry)  ! frequency in a.u.
  tpulse_1=tpulsefs_1/0.02418d0 ! pulse duration in a.u.
  f0_2=5.338d-9*sqrt(IWcm2_2)      ! electric field in a.u.
  omega_2=omegaev_2/(2d0*Ry)  ! frequency in a.u.
  tpulse_2=tpulsefs_2/0.02418d0 ! pulse duration in a.u.
  T1_T2=T1_T2fs/0.02418d0 ! pulse duration in a.u.
  javt_BE=0.d0
  Actot_BE = 0d0
  Ac_pump_BE = 0d0
  Ac_probe_BE = 0d0

! 'cos2cos'                          ! laser_type 'cos2cos', 'cos4cos' or 'impulse'
  select case(laser_type)
  case('impulse')
    Actot_BE = dAc
  case('cos2cos')
! pulse shape : A(t)=f0/omega*sin(Pi t/T)**2 *cos (omega t+phi_CEP*2d0*pi)
! pump laser
    do iter=0,Nt+2
      tt=iter*dt
      if (tt<tpulse_1) then
        Actot_BE(iter)=-f0_1/omega_1*(cos(pi*(tt-0.5d0*tpulse_1)/tpulse_1))**2*sin(omega_1*(tt-0.5d0*tpulse_1)+phi_CEP_1*2d0*pi)

        Ac_pump_BE(iter)=-f0_1/omega_1*(cos(pi*(tt-0.5d0*tpulse_1)/tpulse_1))**2*sin(omega_1*(tt-0.5d0*tpulse_1)+phi_CEP_1*2d0*pi)
      end if
    enddo
! probe laser
    do iter=0,Nt+2
      tt=iter*dt
      if ( (tt>0.5d0*(tpulse_1-tpulse_2)+T1_T2) .and. (tt>0.5d0*(tpulse_1-tpulse_2)+T1_T2+tpulse_2) ) then
        Actot_BE(iter)=Actot_BE(iter) &
          &-f0_2/omega_2*(cos(pi*(tt-(0.5d0*tpulse_1+T1_T2))/tpulse_2))**2*sin(omega_2*(tt-(0.5d0*tpulse_1+T1_T2))+phi_CEP_2*2d0*pi)

        Ac_probe_BE(iter)= &
          &-f0_2/omega_2*(cos(pi*(tt-(0.5d0*tpulse_1+T1_T2))/tpulse_2))**2*sin(omega_2*(tt-(0.5d0*tpulse_1+T1_T2))+phi_CEP_2*2d0*pi)
      endif
    enddo
  case('cos4cos')
! pulse shape : A(t)=f0/omega*sin(Pi t/T)**4 *cos (omega t+phi_CEP*2d0*pi)
! pump laser
    do iter=0,Nt+2
      tt=iter*dt
      if (tt<tpulse_1) then
        Actot_BE(iter)=-f0_1/omega_1*(cos(pi*(tt-0.5d0*tpulse_1)/tpulse_1))**4*sin(omega_1*(tt-0.5d0*tpulse_1)+phi_CEP_1*2d0*pi)

        Ac_pump_BE(iter)=-f0_1/omega_1*(cos(pi*(tt-0.5d0*tpulse_1)/tpulse_1))**4*sin(omega_1*(tt-0.5d0*tpulse_1)+phi_CEP_1*2d0*pi)

      end if
    enddo
! probe laser
    do iter=0,Nt+2
      tt=iter*dt
      if ( (tt-0.5d0*tpulse_1 - T1_T2 >-0.5*tpulse_2) .and. (tt-0.5d0*tpulse_1 - T1_T2 < 0.5*tpulse_2) ) then
        Actot_BE(iter)=Actot_BE(iter) &
          &-f0_2/omega_2*(cos(pi*(tt-(0.5d0*tpulse_1+T1_T2))/tpulse_2))**4*sin(omega_2*(tt-(0.5d0*tpulse_1+T1_T2))+phi_CEP_2*2d0*pi)

        Ac_probe_BE(iter)= &
          &-f0_2/omega_2*(cos(pi*(tt-(0.5d0*tpulse_1+T1_T2))/tpulse_2))**4*sin(omega_2*(tt-(0.5d0*tpulse_1+T1_T2))+phi_CEP_2*2d0*pi)
      endif
    enddo
  case('cos_2_4')
! pulse shape : A(t)=f0/omega*sin(Pi t/T)**4 *cos (omega t+phi_CEP*2d0*pi)
! pump laser
    do iter=0,Nt+2
      tt=iter*dt
      if (tt<tpulse_1) then
        Actot_BE(iter)=-f0_1/omega_1*(cos(pi*(tt-0.5d0*tpulse_1)/tpulse_1))**2*sin(omega_1*(tt-0.5d0*tpulse_1)+phi_CEP_1*2d0*pi)

        Ac_pump_BE(iter)=-f0_1/omega_1*(cos(pi*(tt-0.5d0*tpulse_1)/tpulse_1))**2*sin(omega_1*(tt-0.5d0*tpulse_1)+phi_CEP_1*2d0*pi)
      end if
    enddo
! probe laser
    do iter=0,Nt+2
      tt=iter*dt
      if ( (tt-0.5d0*tpulse_1 - T1_T2 >-0.5*tpulse_2) .and. (tt-0.5d0*tpulse_1 - T1_T2 < 0.5*tpulse_2) ) then
        Actot_BE(iter)=Actot_BE(iter) &
          &-f0_2/omega_2*(cos(pi*(tt-(0.5d0*tpulse_1+T1_T2))/tpulse_2))**4*sin(omega_2*(tt-(0.5d0*tpulse_1+T1_T2))+phi_CEP_2*2d0*pi)

        Ac_probe_BE(iter)= &
          &-f0_2/omega_2*(cos(pi*(tt-(0.5d0*tpulse_1+T1_T2))/tpulse_2))**4*sin(omega_2*(tt-(0.5d0*tpulse_1+T1_T2))+phi_CEP_2*2d0*pi)
      endif
    enddo
  case default
    err_message='error in init_Ac'
    call err_finalize
  end select

  if(myrank == 0)write(*,"(A)")"== End: Initialization of vector potential."

  return
end subroutine init_Ac_basis_expansion_Houston_probe_decomp


!==========================================================================
elemental function gsw_alpha_wrt_t_exact (sa, t, p)
!==========================================================================
!
! Calculates thermal expansion coefficient of seawater with respect to
! in-situ temperature
!
! sa     : Absolute Salinity                               [g/kg]
! t      : insitu temperature                              [deg C]
! p      : sea pressure                                    [dbar]
!
! gsw_alpha_wrt_t_exact : thermal expansion coefficient    [1/K]
!                         wrt (in-situ) temperature
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_gibbs

use gsw_mod_kinds

implicit none

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

real (r8) :: gsw_alpha_wrt_t_exact

integer, parameter :: n0=0, n1=1

gsw_alpha_wrt_t_exact = gsw_gibbs(n0,n1,n1,sa,t,p)/gsw_gibbs(n0,n0,n1,sa,t,p)

return
end function


      subroutine besjn (x, jl, nl)

c-----------------------------------------------------------------------
c
c     purpose:  to calculate the spherical bessel functions jl and nl
c               for l = 0 to 30 (no offset)
c
c     arguments:
c       x = argument of jl and nl
c       jl = jl bessel function (abramowitz conventions)
c       nl = nl bessel function (abramowitz yl conventions)
c            Note that this array nl = abramowitz yl.
c       jl and nl must be dimensioned
c            complex*16 jl(ltot+2), nl(ltot+2), with ltot defined in
c            dim.h.
c
c     notes:  jl and nl should be calculated at least to 10 place
c             accuracy for the range 0<x<100 according to spot
c             checks with tables
c
c     error messages written with PRINT statement.
c
c     first coded by r. c. albers on 14 dec 82
c
c     version 3
c
c     last modified: 27 jan 83 by r. c. albers
c     dimension of jl,nl changed from 31 to 26  (10 aug 89) j. rehr
c     modified again, siz, June 1992
c
c-----------------------------------------------------------------------

      implicit double precision (a-h, o-z)
      include '../HEADERS/dim.h'

      complex*16 x
      complex*16 jl(ltot+2), nl(ltot+2)
      complex*16 cjl(ltot+2), sjl(ltot+2), cnl(ltot+2), snl(ltot+2)

      complex*16 xjl,xnl,asx,acx
      complex*16 xi,xi2,xi3,xi4,xi5,xi6,xi7,xi8,xi9,xi10,xi11

      parameter (xcut = 1.d0, xcut1 = 7.51d0, xcut2 = 5.01d0)

      if (dble(x) .le. 0)  stop 'Re(x) is .le. zero in besjn'

      lmaxp1 = ltot+2

      if (dble(x) .lt. xcut .and. abs(dimag(x)) .lt. xcut)  then
c        case Re(x) < 1, just use series expansion
         do 10 il = 1,lmaxp1
            l = il-1
            ifl = 0
            call bjnser (x,l,xjl,xnl,ifl)
            jl(il) = xjl
            nl(il) = xnl
   10    continue

      elseif (dble(x) .lt. xcut1 .and. abs(dimag(x)) .lt. xcut1)  then

c        case 1 <= Re(x) < 7.5

         call bjnser (x,lmaxp1-1,xjl,xnl,1)
         jl(lmaxp1) = xjl

         call bjnser (x,lmaxp1-2,xjl,xnl,1)
         jl(lmaxp1-1) = xjl

         if (dble(x) .lt. xcut2 .and. abs(dimag(x)) .lt. xcut2)  then
c           Re(x) < 5
            call bjnser (x,0,xjl,xnl,2)
            nl(1) = xnl
            call bjnser (x,1,xjl,xnl,2)
            nl(2) = xnl
         else
c           Re(x) >= 5
            asx = sin(x)
            acx = cos(x)
            xi = 1 / x
            xi2 = xi**2
            nl(1) = -acx*xi
            nl(2) = -acx*xi2 - asx*xi
         endif

c        Use recursion relation 10.1.19 to get nl and jl
         do 50 lp1 = 3, lmaxp1
            l = lp1 - 2
            tlxp1 = 2*l + 1
            nl(lp1) = tlxp1 * nl(lp1-1) / x  -  nl(lp1-2)
   50    continue

         do 60 lxx = 3,lmaxp1
            lp1 = lmaxp1+1-lxx
            l = lp1-1
            tlxp3 = 2*l + 3
            jl(lp1) = tlxp3 * jl(lp1+1) / x  -  jl(lp1+2)
   60    continue

      else
c        case Re(x) > 7.5
c        Use AS 10.1.8 and 10.1.9, sjl=P, qjl=Q, note that AS formulae
c        use cos (z - n*pi/2), etc., so cos and sin terms get a bit
c        scrambled (mod 4) here, since n is integer.  These are hard-
c        coded into the terms below.
         xi = 1 / x
         xi2  = xi*xi
         xi3  = xi*xi2
         xi4  = xi*xi3
         xi5  = xi*xi4
         xi6  = xi*xi5
         xi7  = xi*xi6
         xi8  = xi*xi7
         xi9  = xi*xi8
         xi10 = xi*xi9
         xi11 = xi*xi10

         sjl(1) = xi
         sjl(2) = xi2
         sjl(3) = 3*xi3 - xi
         sjl(4) = 15*xi4 - 6*xi2
         sjl(5) = 105*xi5 - 45*xi3 + xi
         sjl(6) = 945*xi6 - 420*xi4 + 15*xi2
         sjl(7) = 10395*xi7 - 4725*xi5 + 210*xi3 - xi
         sjl(8) = 135135*xi8 - 62370*xi6 + 3150*xi4 - 28*xi2
         sjl(9) = 2027025*xi9 - 945945*xi7 + 51975*xi5
     1            - 630*xi3 + xi
         sjl(10) = 34459425*xi10 - 16216200*xi8 + 945945*xi6
     1            - 13860*xi4 + 45*xi2
         sjl(11) = 654729075*xi11 - 310134825*xi9 + 18918900*xi7
     1            - 315315*xi5 + 1485*xi3 - xi
         cjl(1) = 0
         cjl(2) = -xi
         cjl(3) = -3*xi2
         cjl(4) = -15*xi3 + xi
         cjl(5) = -105*xi4 + 10*xi2
         cjl(6) = -945*xi5 + 105*xi3 - xi
         cjl(7) = -10395*xi6 + 1260*xi4 - 21*xi2
         cjl(8) = -135135*xi7 + 17325*xi5 - 378*xi3 + xi
         cjl(9) = -2027025*xi8 + 270270*xi6 - 6930*xi4 + 36*xi2
         cjl(10) = -34459425*xi9 + 4729725*xi7 - 135135*xi5
     1             + 990*xi3 - xi
         cjl(11) = -654729075*xi10 + 91891800*xi8 - 2837835*xi6
     1             + 25740*xi4 - 55*xi2
         do 80 ie = 1,11
            snl(ie) = cjl(ie)
            cnl(ie) = -sjl(ie)
   80    continue
         do 90 lp1 = 12,lmaxp1
            l = lp1-2
            tlxp1 = float(2*l+1)
            sjl(lp1) = tlxp1*xi*sjl(lp1-1)-sjl(lp1-2)
            cjl(lp1) = tlxp1*xi*cjl(lp1-1)-cjl(lp1-2)
            snl(lp1) = tlxp1*xi*snl(lp1-1)-snl(lp1-2)
            cnl(lp1) = tlxp1*xi*cnl(lp1-1)-cnl(lp1-2)
   90    continue
         asx = sin(x)
         acx = cos(x)
         do 110 lp1 = 1,lmaxp1
            jl(lp1) = asx*sjl(lp1)+acx*cjl(lp1)
            nl(lp1) = asx*snl(lp1)+acx*cnl(lp1)
  110    continue
      endif

      return
      end


    subroutine carbo(Patm,temperature,runoff,xmass_carbonate,j)
!   ======================================================
    implicit none

    include 'combine_foam.inc'

    Pmax=1.+0.302483*runoff**0.8
    !Patm=var(12,nbasin)/0.0508d+18 ! obsolete, Patm is now an input argument
    pco2soil=Patm+Pmax/(1+dexp(1.315-0.119*(temperature)))
    SO4soil=SO4_conc(j)

    temper=temperature+273.15

    x1=1.d-7
    x2=1.d-1
    xacc=1.d-10
!    if (value_keep1(j).ne.0) then
!        xn=value_keep1(j)
!    else
    xn=1.d-4
!    endif

!    call rtbis(x1,x2,xacc,out,temper)
    call newton(xn,fx,dfx,xacc,temper)

    out=xn
!    value_keep1(j)=xn

    h2co3soil=betasoil*pco2soil
    hco3soil=ak1soil*h2co3soil/out
    co3soil=hco3soil*ak2soil/out
    Calcium=0.5*(hco3soil+2*co3soil+2.*SO4soil)  !mol/m3
    xmass_carbonate=Calcium !mol/m3

    return
    end


C
C	$Id$
C
      SUBROUTINE CSVORO(NPTS,RLATI,RLONI,NI,NF,IWK,RWK,NC,RLATO,RLONO,
     +                    RC,NCA,NUMV,NV,IER)
      DOUBLE PRECISION RWK(*)
C
C  This subroutine returns vertices for a Voronoi polygon
C  enclosing a given input coordinate.
C
C  Arguments:
C
C    NPTS  (Input)
C      The number of input data points (NPTS > 3)
C    RLATI  (Input)
C      An array, dimensioned for NPTS, containing the latitudes
C      of the input coordinates, in degrees.
C    RLONI  (Input)
C      An array, dimensioned for NPTS, containing the longitudes
C      of the input coordinates, in degrees.
C    NI (Input)
C      The index of the input coordinate for which you want
C      to determine the Voronoi polygon (0 .LE. NI .LE. NPTS).
C    NF (Input)
C      Flag indicating if this is the first call to CSVORO
C      to retrieve Voronoi polygons for this dataset (1=yes,
C      0=no).  Calls subsequent to the first call for a given
C      dataset are much faster than the first call.
C    IWK (Input)
C      Integer work space dimensioned for 27*NPTS.
C    RWK (Input)
C      Double precision work space dimensioned for 9*NPTS.
C    NC (Input)
C      The maximum size of the output arrays RLATO, RLONO, and RC.
C      NC should be 2*NPTS.
C    RLATO (Output)
C      An array of latitude values for the Voronoi indices.  These
C      are circumcenters of circles passing through the Delaunay
C      triangles.  If a coordinate is a boundary point, then
C      the circle may pass through certain "pseudo points" that
C      have been added to the original dataset in order to complete
C      the Voronoi polygon.  RLATO is returned in degrees.
C    RLONO (Output)
C      An array of longitude values for the Voronoi indices.  These
C      are circumcenters of circles passing through the Delaunay
C      triangles.  If a coordinate is a boundary point, then
C      the circle may pass through certain "pseudo points" that
C      have been added to the original dataset in order to complete
C      the Voronoi polygon.  RLONO is returned in degrees.
C    RC (Output)
C      Array containing the arc length (in degrees) of the angle
C      between a circumcenter and its associated triangle vertices.
C    NCA (Output)
C      The actual number of circumcenters returned in RLATO and RLONO.
C      This number may be larger than NPTS if the input dataset has
C      boundary points, since certain "pseudo points" may have been
C      added to the original dataset in order to complete the Voronoi
C      polygon set.
C    NUMV (Output)
C      The number of vertices in the Voronoi polygon enclosing
C      the coordinate (RLATI(NI),RLONI(NI)).
C    NV (Output)
C      An array (dimensioned for NPTS) containing NUMV indices for
C      the Voronoi polygon enclosing the coordinate (RLATI(NI),RLONI(NI)).
C      The indices returned in this array refer to the coordinates
C      returned in RLATO and RLONO.  For example, if the integer
C      "J" is an element of the NV array, then (RLATO(J),RLONO(J))
C      is a vertex of the Voronoi polygon enclosing (RLATI(NI),RLONI(NI)).
C      The indices in NV list out the vertices of the Voronoi in
C      counter-clockwise order.
C    IER (Output)
C      An error return value as per:
C         IER =  0  no error.
C         IER =  1  NPTS < 3.
C         IER =  4  first three coordinates are collinear.
C         IER =  6  internal error
C         IER = -L  if coordinates L and M coincide for some
C                   M > L >= 1 .
C
      PARAMETER (D2R=0.017453293, R2D=57.295778)
      DIMENSION RLATI(NPTS),RLONI(NPTS),IWK(*),RLATO(NC),RLONO(NC),
     +          RC(NC),NV(NPTS)
C
      SAVE
C
      IF (NF.EQ.1) THEN
C
C       Workspace position   Associated Variable     Size
C       ------------------   -------------------   --------
C         IWK(        1)            LIST            6*NPTS
C         IWK( 6*NPTS+1)            LPTR            6*NPTS
C         IWK(12*NPTS+1)            LEND              NPTS
C         IWK(13*NPTS+1)            NEAR              NPTS
C         IWK(14*NPTS+1)            NEXT              NPTS
C         IWK(15*NPTS+1)            LTRI            6*NPTS
C         IWK(21*NPTS+1)            LISTC           6*NPTS
C
C
C  Convert RLATI and RLONI to radians.
C
        N = NPTS
        DO 7 I=1,N
          RWK(3*N+I) = DBLE(D2R*RLATI(I))
          RWK(4*N+I) = DBLE(D2R*RLONI(I))
    7   CONTINUE
C
C  Then convert to Cartesian coordinates.
C
        CALL CSTRANSD(N,RWK(3*N+1),RWK(4*N+1),RWK(1),
     +               RWK(N+1),RWK(2*N+1))
C
        CALL CSTRMESH(NPTS,RWK(1),RWK(N+1),RWK(2*N+1),
     +                IWK(1),IWK(6*NPTS+1),
     +                IWK(12*NPTS+1),LNEW,IWK(13*NPTS+1),
     +                IWK(14*NPTS+1),RWK(3*N+1),IER)
        IF (IER.EQ.0) THEN
            GO TO 210
        ELSE IF (IER.EQ.-1) THEN
            IER = 1
            GO TO 200
        ELSE IF (IER.EQ.-2) THEN
            IER = 4
            GO TO 200
        ELSE IF (IER.EQ.-3) THEN
            IER = 6
            GO TO 200
        ELSE IF (IER.GT.0) THEN
            IER = -IER
            GO TO 200
        ELSE
            IER = 6
            GO TO 200
C
        END IF
  210   CONTINUE
C
        N2 = NPTS*2
        DO 10 I = 1,N2
            RWK(3*N+I) = -99999.
   10   CONTINUE
C
C  Get the pointers to the Voronoi polygon vertices.
C
        CALL CSCRLIST(NPTS,NPTS,RWK(1),RWK(N+1),RWK(2*N+1),
     +                IWK(1),IWK(12*NPTS+1),
     +                IWK(6*NPTS+1),LNEW,IWK(15*NPTS+1),
     +                IWK(21*NPTS+1),NB,
     +                RWK(3*N+1),RWK(5*N+1),RWK(7*N+1),IER)
        IF (IER.EQ.0) THEN
            DO 160 K=1,N2
              RLATO(K) = R2D*REAL(RWK(3*N+K))
              RLONO(K) = R2D*REAL(RWK(5*N+K))
              RC(K)    = R2D*REAL(RWK(7*N+K))
  160       CONTINUE
            GO TO 220
        ELSE IF (IER.EQ.1) THEN
            GO TO 200
        ELSE IF (IER.EQ.2) THEN
            IER = 10
            GO TO 200
        ELSE IF (IER.EQ.3) THEN
            IER = 11
            GO TO 200
        ELSE
            IER = 6
            GO TO 200
        END IF
  220   CONTINUE
C
C  Determine the number of circumcenters returned.
C
        DO 20 I = 1,N2
          IF (RLATO(I).EQ.-99999.) THEN
            NCA = I - 1
            GO TO 25
          END IF
          IF (I.EQ.N2) NCA = N2
   20     CONTINUE
   25   CONTINUE
      END IF
C
C  Return the indices for the desired Voronoi polygon.
C
      LPL = IWK(12*NPTS+NI)
      NUMV = 1
      NV(NUMV) = IWK(21*NPTS+LPL)
      LP = LPL
   30 CONTINUE
      LP = IWK(6*NPTS+LP)
      NUMV = NUMV + 1
      NV(NUMV) = IWK(21*NPTS+LP)
      IF (LP.NE.LPL) GO TO 30
      RETURN
C
  200 CONTINUE
      CALL CSSERR('CSVORO',IER)
      NCA = 0
      NUMV = 0
      RETURN
C
      END


      SUBROUTINE MB02ED( TYPET, K, N, NRHS, T, LDT, B, LDB, DWORK,
     $                   LDWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To solve a system of linear equations  T*X = B  or  X*T = B  with
C     a symmetric positive definite (s.p.d.) block Toeplitz matrix T.
C     T is defined either by its first block row or its first block
C     column, depending on the parameter TYPET.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TYPET   CHARACTER*1
C             Specifies the type of T, as follows:
C             = 'R':  T contains the first block row of an s.p.d. block
C                     Toeplitz matrix, and the system X*T = B is solved;
C             = 'C':  T contains the first block column of an s.p.d.
C                     block Toeplitz matrix, and the system T*X = B is
C                     solved.
C             Note:   in the sequel, the notation x / y means that
C                     x corresponds to TYPET = 'R' and y corresponds to
C                     TYPET = 'C'.
C
C     Input/Output Parameters
C
C     K       (input)  INTEGER
C             The number of rows / columns in T, which should be equal
C             to the blocksize.  K >= 0.
C
C     N       (input)  INTEGER
C             The number of blocks in T.  N >= 0.
C
C     NRHS    (input)  INTEGER
C             The number of right hand sides.  NRHS >= 0.
C
C     T       (input/output)  DOUBLE PRECISION array, dimension
C             (LDT,N*K) / (LDT,K)
C             On entry, the leading K-by-N*K / N*K-by-K part of this
C             array must contain the first block row / column of an
C             s.p.d. block Toeplitz matrix.
C             On exit, if  INFO = 0  and  NRHS > 0,  then the leading
C             K-by-N*K / N*K-by-K part of this array contains the last
C             row / column of the Cholesky factor of inv(T).
C
C     LDT     INTEGER
C             The leading dimension of the array T.
C             LDT >= MAX(1,K),    if TYPET = 'R';
C             LDT >= MAX(1,N*K),  if TYPET = 'C'.
C
C     B       (input/output) DOUBLE PRECISION array, dimension
C             (LDB,N*K) / (LDB,NRHS)
C             On entry, the leading NRHS-by-N*K / N*K-by-NRHS part of
C             this array must contain the right hand side matrix B.
C             On exit, the leading NRHS-by-N*K / N*K-by-NRHS part of
C             this array contains the solution matrix X.
C
C     LDB     INTEGER
C             The leading dimension of the array B.
C             LDB >= MAX(1,NRHS),  if TYPET = 'R';
C             LDB >= MAX(1,N*K),   if TYPET = 'C'.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0,  DWORK(1)  returns the optimal
C             value of LDWORK.
C             On exit, if  INFO = -10,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX(1,N*K*K+(N+2)*K).
C             For optimum performance LDWORK should be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  the reduction algorithm failed. The Toeplitz matrix
C                   associated with T is not (numerically) positive
C                   definite.
C
C     METHOD
C
C     Householder transformations, modified hyperbolic rotations and
C     block Gaussian eliminations are used in the Schur algorithm [1],
C     [2].
C
C     REFERENCES
C
C     [1] Kailath, T. and Sayed, A.
C         Fast Reliable Algorithms for Matrices with Structure.
C         SIAM Publications, Philadelphia, 1999.
C
C     [2] Kressner, D. and Van Dooren, P.
C         Factorizations and linear system solvers for matrices with
C         Toeplitz structure.
C         SLICOT Working Note 2000-2, 2000.
C
C     NUMERICAL ASPECTS
C
C     The implemented method is numerically equivalent with forming
C     the Cholesky factor R and the inverse Cholesky factor of T, using
C     the generalized Schur algorithm, and solving the systems of
C     equations  R*X = L*B  or  X*R = B*L by a blocked backward
C     substitution algorithm.
C                               3 2    2 2
C     The algorithm requires 0(K N  + K N NRHS) floating point
C     operations.
C
C     CONTRIBUTOR
C
C     D. Kressner, Technical Univ. Chemnitz, Germany, December 2000.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000,
C     February 2004.
C
C     KEYWORDS
C
C     Elementary matrix operations, Householder transformation, matrix
C     operations, Toeplitz matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         TYPET
      INTEGER           INFO, K, LDB, LDT, LDWORK, N, NRHS
C     .. Array Arguments ..
      DOUBLE PRECISION  B(LDB,*), DWORK(*), T(LDT,*)
C     .. Local Scalars ..
      INTEGER           I, IERR, MAXWRK, STARTH, STARTI, STARTN,
     $                  STARTR, STARTT
      LOGICAL           ISROW
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DGEMM, DLACPY, DLASET, DPOTRF, DTRMM, DTRSM,
     $                  MB02CX, MB02CY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX, MIN
C
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      INFO  = 0
      ISROW = LSAME( TYPET, 'R' )
C
C     Check the scalar input parameters.
C
      IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN
         INFO = -1
      ELSE IF ( K.LT.0 ) THEN
         INFO = -2
      ELSE IF ( N.LT.0 ) THEN
         INFO = -3
      ELSE IF ( NRHS.LT.0 ) THEN
         INFO = -4
      ELSE IF ( LDT.LT.1 .OR. ( ISROW .AND. LDT.LT.K ) .OR.
     $                   ( .NOT.ISROW .AND. LDT.LT.N*K ) ) THEN
         INFO = -6
      ELSE IF ( LDB.LT.1 .OR. ( ISROW .AND. LDB.LT.NRHS ) .OR.
     $                   ( .NOT.ISROW .AND. LDB.LT.N*K ) ) THEN
         INFO = -8
      ELSE IF ( LDWORK.LT.MAX( 1, N*K*K + ( N + 2 )*K ) ) THEN
         DWORK(1) = MAX( 1, N*K*K + ( N + 2 )*K )
         INFO = -10
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB02ED', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MIN( K, N, NRHS ).EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
      MAXWRK = 0
      STARTN = 1
      STARTT = N*K*K  + 1
      STARTH = STARTT + 3*K
C
      IF ( ISROW ) THEN
C
C        T is the first block row of a block Toeplitz matrix.
C        Bring T to proper form by triangularizing its first block.
C
         CALL DPOTRF( 'Upper', K, T, LDT, IERR )
         IF ( IERR.NE.0 )  THEN
C
C           Error return:  The matrix is not positive definite.
C
            INFO = 1
            RETURN
         END IF
C
         IF ( N.GT.1 )
     $      CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K,
     $                  (N-1)*K, ONE, T, LDT, T(1,K+1), LDT )
C
C        Initialize the generator, do the first Schur step and set
C        B = -B.
C        T contains the nonzero blocks of the positive parts in the
C        generator and the inverse generator.
C        DWORK(STARTN) contains the nonzero blocks of the negative parts
C        in the generator and the inverse generator.
C
         CALL DTRSM( 'Right', 'Upper', 'NonTranspose', 'NonUnit', NRHS,
     $               K, ONE, T, LDT, B, LDB )
         IF ( N.GT.1 )
     $      CALL DGEMM( 'NonTranspose', 'NonTranspose', NRHS, (N-1)*K,
     $                  K, ONE, B, LDB, T(1,K+1), LDT, -ONE, B(1,K+1),
     $                  LDB )
C
         CALL DLASET( 'All', K, K, ZERO, ONE, DWORK(STARTN), K )
         CALL DTRSM(  'Left', 'Upper', 'Transpose', 'NonUnit', K, K,
     $                ONE, T, LDT, DWORK(STARTN), K )
         IF ( N.GT.1 )
     $      CALL DLACPY( 'All', K, (N-1)*K, T(1,K+1), LDT,
     $                   DWORK(STARTN+K*K), K )
         CALL DLACPY( 'All', K, K, DWORK(STARTN), K, T(1,(N-1)*K+1),
     $                LDT )
C
         CALL DTRMM ( 'Right', 'Lower', 'NonTranspose', 'NonUnit', NRHS,
     $                K, ONE, T(1,(N-1)*K+1), LDT, B, LDB )
C
C        Processing the generator.
C
         DO 10  I = 2, N
            STARTR = ( I - 1 )*K + 1
            STARTI = ( N - I )*K + 1
C
C           Transform the generator of T to proper form.
C
            CALL MB02CX( 'Row', K, K, K, T, LDT,
     $                   DWORK(STARTN+(I-1)*K*K), K, DWORK(STARTT), 3*K,
     $                   DWORK(STARTH), LDWORK-STARTH+1, IERR )
C
            IF ( IERR.NE.0 )  THEN
C
C              Error return:  The matrix is not positive definite.
C
               INFO = 1
               RETURN
            END IF
C
            MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) )
            CALL MB02CY( 'Row', 'NoStructure', K, K, (N-I)*K, K,
     $                    T(1,K+1), LDT, DWORK(STARTN+I*K*K), K,
     $                    DWORK(STARTN+(I-1)*K*K), K, DWORK(STARTT),
     $                    3*K, DWORK(STARTH), LDWORK-STARTH+1, IERR )
            MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) )
C
C           Block Gaussian eliminates the i-th block in B.
C
            CALL DTRSM( 'Right', 'Upper', 'NonTranspose', 'NonUnit',
     $                  NRHS, K, -ONE, T, LDT, B(1,STARTR), LDB )
            IF ( N.GT.I )
     $         CALL DGEMM( 'NonTranspose', 'NonTranspose', NRHS,
     $                     (N-I)*K, K, ONE, B(1,STARTR), LDB, T(1,K+1),
     $                     LDT, ONE, B(1,STARTR+K), LDB )
C
C           Apply hyperbolic transformations on the negative generator.
C
            CALL DLASET( 'All', K, K, ZERO, ZERO, T(1,STARTI), LDT )
            CALL MB02CY( 'Row', 'NoStructure', K, K, (I-1)*K, K,
     $                   T(1,STARTI), LDT, DWORK(STARTN), K,
     $                   DWORK(STARTN+(I-1)*K*K), K, DWORK(STARTT), 3*K,
     $                   DWORK(STARTH), LDWORK-STARTH+1, IERR )
            MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) )
C
C           Note that  DWORK(STARTN+(I-1)*K*K)  serves simultaneously
C           as the transformation container as well as the new block in
C           the negative generator.
C
            CALL MB02CY( 'Row', 'Triangular', K, K, K, K,
     $                   T(1,(N-1)*K+1), LDT, DWORK(STARTN+(I-1)*K*K),
     $                   K, DWORK(STARTN+(I-1)*K*K), K, DWORK(STARTT),
     $                   3*K, DWORK(STARTH), LDWORK-STARTH+1, IERR )
            MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) )
C
C           Finally the Gaussian elimination is applied on the inverse
C           generator.
C
            CALL DGEMM( 'NonTranspose', 'NonTranspose', NRHS, (I-1)*K,
     $                  K, ONE, B(1,STARTR), LDB, T(1,STARTI), LDT, ONE,
     $                  B, LDB )
            CALL DTRMM( 'Right', 'Lower', 'NonTranspose', 'NonUnit',
     $                  NRHS, K, ONE, T(1,(N-1)*K+1), LDT, B(1,STARTR),
     $                  LDB )
   10    CONTINUE
C
      ELSE
C
C        T is the first block column of a block Toeplitz matrix.
C        Bring T to proper form by triangularizing its first block.
C
         CALL DPOTRF( 'Lower', K, T, LDT, IERR )
         IF ( IERR.NE.0 )  THEN
C
C           Error return:  The matrix is not positive definite.
C
            INFO = 1
            RETURN
         END IF
C
         IF ( N.GT.1 )
     $      CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit',
     $                  (N-1)*K, K, ONE, T, LDT, T(K+1,1), LDT )
C
C        Initialize the generator, do the first Schur step and set
C        B = -B.
C        T contains the nonzero blocks of the positive parts in the
C        generator and the inverse generator.
C        DWORK(STARTN) contains the nonzero blocks of the negative parts
C        in the generator and the inverse generator.
C
         CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit', K,
     $               NRHS, ONE, T, LDT, B, LDB )
         IF ( N.GT.1 )
     $      CALL DGEMM( 'NonTranspose', 'NonTranspose', (N-1)*K, NRHS,
     $                  K, ONE, T(K+1,1), LDT, B, LDB, -ONE, B(K+1,1),
     $                  LDB )
C
         CALL DLASET( 'All', K, K, ZERO, ONE, DWORK(STARTN), N*K )
         CALL DTRSM(  'Right', 'Lower', 'Transpose', 'NonUnit', K, K,
     $                ONE, T, LDT, DWORK(STARTN), N*K )
         IF ( N.GT.1 )
     $      CALL DLACPY( 'All', (N-1)*K, K, T(K+1,1), LDT,
     $                   DWORK(STARTN+K), N*K )
         CALL DLACPY( 'All', K, K, DWORK(STARTN), N*K, T((N-1)*K+1,1),
     $                LDT )
C
         CALL DTRMM ( 'Left', 'Upper', 'NonTranspose', 'NonUnit', K,
     $                NRHS, ONE, T((N-1)*K+1,1), LDT, B, LDB )
C
C        Processing the generator.
C
         DO 20  I = 2, N
            STARTR = ( I - 1 )*K + 1
            STARTI = ( N - I )*K + 1
C
C           Transform the generator of T to proper form.
C
            CALL MB02CX( 'Column', K, K, K, T, LDT,
     $                   DWORK(STARTN+(I-1)*K), N*K, DWORK(STARTT), 3*K,
     $                   DWORK(STARTH), LDWORK-STARTH+1, IERR )
C
            IF ( IERR.NE.0 )  THEN
C
C              Error return:  The matrix is not positive definite.
C
               INFO = 1
               RETURN
            END IF
C
            MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) )
            CALL MB02CY( 'Column', 'NoStructure', K, K, (N-I)*K, K,
     $                   T(K+1,1), LDT, DWORK(STARTN+I*K), N*K,
     $                   DWORK(STARTN+(I-1)*K), N*K, DWORK(STARTT),
     $                   3*K, DWORK(STARTH), LDWORK-STARTH+1, IERR )
            MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) )
C
C           Block Gaussian eliminates the i-th block in B.
C
            CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit', K,
     $                  NRHS, -ONE, T, LDT, B(STARTR,1), LDB )
            IF ( N.GT.I )
     $         CALL DGEMM( 'NonTranspose', 'NonTranspose', (N-I)*K,
     $                     NRHS, K, ONE, T(K+1,1), LDT, B(STARTR,1),
     $                     LDB, ONE, B(STARTR+K,1), LDB )
C
C           Apply hyperbolic transformations on the negative generator.
C
            CALL DLASET( 'All', K, K, ZERO, ZERO, T(STARTI,1), LDT )
            CALL MB02CY( 'Column', 'NoStructure', K, K, (I-1)*K, K,
     $                   T(STARTI,1), LDT, DWORK(STARTN), N*K,
     $                   DWORK(STARTN+(I-1)*K), N*K, DWORK(STARTT), 3*K,
     $                   DWORK(STARTH), LDWORK-STARTH+1, IERR )
            MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) )
C
C           Note that  DWORK(STARTN+(I-1)*K)  serves simultaneously
C           as the transformation container as well as the new block in
C           the negative generator.
C
            CALL MB02CY( 'Column', 'Triangular', K, K, K, K,
     $                   T((N-1)*K+1,1), LDT, DWORK(STARTN+(I-1)*K),
     $                   N*K, DWORK(STARTN+(I-1)*K), N*K, DWORK(STARTT),
     $                   3*K, DWORK(STARTH), LDWORK-STARTH+1, IERR )
            MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) )
C
C           Finally the Gaussian elimination is applied on the inverse
C           generator.
C
            CALL DGEMM( 'NonTranspose', 'NonTranspose', (I-1)*K, NRHS,
     $                  K, ONE, T(STARTI,1), LDT, B(STARTR,1), LDB, ONE,
     $                  B, LDB )
            CALL DTRMM( 'Left', 'Upper', 'NonTranspose', 'NonUnit',
     $                  K, NRHS, ONE, T((N-1)*K+1,1), LDT, B(STARTR,1),
     $                  LDB )
C
   20    CONTINUE
C
      END IF
C
      DWORK(1) = MAX( 1, STARTH - 1 + MAXWRK )
C
      RETURN
C
C *** Last line of MB02ED ***
      END


c =========================================================
      subroutine rp1(maxmx,meqn,mwaves,mbc,mx,ql,qr,auxl,auxr,
     &		       wave,s,amdq,apdq)
c =========================================================
c
c     # solve Riemann problems for the 1D shallow water equations
c     #   (h)_t + (u h)_x = 0
c     #   (uh)_t + ( uuh + .5*gh^2 )_x = 0
c     # using Roe's approximate Riemann solver with entropy fix for
c     # transonic rarefractions.
c
c     # On input, ql contains the state vector at the left edge of each cell
c     #           qr contains the state vector at the right edge of each cell
c     # On output, wave contains the waves,
c     #            s the speeds,
c     #            amdq the  left-going flux difference  A^- \Delta q
c     #            apdq the right-going flux difference  A^+ \Delta q
c
c     # Note that the i'th Riemann problem has left state qr(i-1,:)
c     #                                    and right state ql(i,:)
c     # From the basic clawpack routine step1, rp is called with ql = qr = q.
c
c     Here meqn=mwaves=2 should be passed from the calling routine
c
      implicit double precision (a-h,o-z)
      dimension   ql(1-mbc:maxmx+mbc, meqn)
      dimension   qr(1-mbc:maxmx+mbc, meqn)
      dimension    s(1-mbc:maxmx+mbc, mwaves)
      dimension wave(1-mbc:maxmx+mbc, meqn, mwaves)
      dimension amdq(1-mbc:maxmx+mbc, meqn)
      dimension apdq(1-mbc:maxmx+mbc, meqn)
      dimension auxl(1-mbc:maxmx+mbc, *)
      dimension auxr(1-mbc:maxmx+mbc, *)
c
c     # local storage
c     ---------------
      dimension delta(2)
      logical efix
      common /comrp/ grav
      data efix /.true./    !# use entropy fix for transonic rarefactions

c
      do 30 i=2-mbc,mx+mbc
c
c
c     # compute  Roe-averaged quantities:
         ubar = (qr(i-1,2)/dsqrt(qr(i-1,1)) + ql(i,2)/dsqrt(ql(i,1)))/
     .       ( dsqrt(qr(i-1,1)) + dsqrt(ql(i,1)) )
         cbar=dsqrt(0.5d0*grav*(qr(i-1,1) + ql(i,1)))

c     # delta(1)=h(i)-h(i-1) and  delta(2)=hu(i)-hu(i-1)
      delta(1) = ql(i,1) - qr(i-1,1)
      delta(2) = ql(i,2) - qr(i-1,2)

c # compute coeffs in the evector expansion of delta(1),delta(2)
      a1 = 0.5d0*(-delta(2) + (ubar + cbar) * delta(1))/cbar
      a2 = 0.5d0*( delta(2) - (ubar - cbar) * delta(1))/cbar

c     # finally, compute the waves.
         wave(i,1,1) = a1
         wave(i,2,1) = a1*(ubar - cbar)
         s(i,1) = ubar - cbar

         wave(i,1,2) = a2
         wave(i,2,2) = a2*(ubar + cbar)
         s(i,2) = ubar + cbar

   30 continue

c     # compute Godunov flux f0:
c     --------------------------

      if (efix) go to 110

c     # no entropy fix
c     ----------------------------------------------
c     # amdq = SUM s*wave   over left-going waves
c     # apdq = SUM s*wave   over right-going waves

      do 100 m=1,2
         do 100 i=2-mbc, mx+mbc
            amdq(i,m) = 0.d0
            apdq(i,m) = 0.d0
            do 90 mw=1,mwaves
               if (s(i,mw) .lt. 0.d0) then
                   amdq(i,m) = amdq(i,m) + s(i,mw)*wave(i,m,mw)
                 else
                   apdq(i,m) = apdq(i,m) + s(i,mw)*wave(i,m,mw)
                 endif
   90          continue
  100       continue
      go to 900
c
c    -----------------------------------------------
c

  110 continue

c     # With entropy fix
c     ------------------
c
c    # compute flux differences amdq and apdq.
c    # First compute amdq as sum of s*wave for left going waves.
c    # Incorporate entropy fix by adding a modified fraction of wave
c    # if s should change sign.
c
      do 200 i=2-mbc,mx+mbc

c ------------------------------------------------------
c        # check 1-wave:
c        ---------------
c
c        # u-c in left state (cell i-1)
         s0 = qr(i-1,2)/qr(i-1,1) - dsqrt(grav*qr(i-1,1))

c        # check for fully supersonic case:
	 if (s0.ge.0.d0 .and. s(i,1).gt.0.d0)  then
c            # everything is right-going
	     do 60 m=1,2
		amdq(i,m) = 0.d0
   60           continue
	     go to 200
	     endif
c
c        # u-c to right of 1-wave
         hr1  = qr(i-1,1) + wave(i,1,1)
         uhr1 = qr(i-1,2) + wave(i,2,1)
         s1 =  uhr1/hr1 - dsqrt(grav*hr1)

         if (s0.lt.0.d0 .and. s1.gt.0.d0) then
c            # transonic rarefaction in the 1-wave
	     sfract = s0 * (s1-s(i,1)) / (s1-s0)
	   else if (s(i,1) .lt. 0.d0) then
c	     # 1-wave is leftgoing
	     sfract = s(i,1)
	   else
c	     # 1-wave is rightgoing
             sfract = 0.d0   !# this shouldn't happen since s0 < 0
	   endif

	 do 120 m=1,2
	    amdq(i,m) = sfract*wave(i,m,1)
  120       continue

c -------------------------------------------------------
c        # check 2-wave:
c        ---------------
c        # u+c in right state  (cell i)
         s3 = ql(i,2)/ql(i,1) + dsqrt(grav*ql(i,1))

c        # u+c to left of 2-wave
         hl2  = ql(i,1) - wave(i,1,2)
         uhl2 = ql(i,2) - wave(i,2,2)
         s2 = uhl2/hl2 + dsqrt(grav*hl2)

         if (s2 .lt. 0.d0 .and. s3.gt.0.d0) then
c            # transonic rarefaction in the 2-wave
	     sfract = s2 * (s3-s(i,2)) / (s3-s2)
	   else if (s(i,2) .lt. 0.d0) then
c            # 2-wave is leftgoing
	     sfract = s(i,2)
	   else
c            # 2-wave is rightgoing
	     go to 200
	   endif
c
	 do 160 m=1,2
	    amdq(i,m) = amdq(i,m) + sfract*wave(i,m,2)
  160       continue
  200    continue
c
c
c     # compute the rightgoing flux differences:
c     # df = SUM s*wave   is the total flux difference and apdq = df - amdq
c
      do 220 m=1,2
	 do 220 i = 2-mbc, mx+mbc
	    df = 0.d0
	    do 210 mw=1,mwaves
	       df = df + s(i,mw)*wave(i,m,mw)
  210          continue
	    apdq(i,m) = df - amdq(i,m)
  220       continue

  900 continue
      return
      end


!***********************************/
!	Name:非構造セルの簡易接触判定関数
!	Alias:BoundaryBoxMethod
!	Description:名前の通り境界矩形法を用いて判別する
!	Type:integer
!	Input:CountUpVertex
!	Output:iTrueOrFalse
!	Note:
!	Author:Akitaka Toyota
!	Date:2017.12.26
!	Update:2017.12.26
!	Other:
!***********************************/

function BoundaryBoxMethod(CUV) result(iToF)
use StructVar_Mod
implicit none

    type(CountUpVertex), intent(in) :: CUV

    integer :: iToF
    !double precision :: SquareArea, AreaSum

        !SquareArea = dot_product(CUV%TargetCoords(0,1:3) - CUV%DonorCoords(0,1:3), &
        !                        &   CUV%TargetCoords(0,1:3) - CUV%DonorCoords(0,1:3))

        !AreaSum = CUV%TargetVolume + CUV%DonorVolume

        !if(SquareArea > AreaSum) then !このときセル間距離は明らかに遠く，接触していない
        if(dot_product(CUV%TargetCoords(0,1:3) - CUV%DonorCoords(0,1:3), &
                                &   CUV%TargetCoords(0,1:3) - CUV%DonorCoords(0,1:3)) > &
                                &   CUV%TargetVolume + CUV%DonorVolume) then
            iToF = 0
        else
            iToF = 1
        end if
    return
end function BoundaryBoxMethod


!
!***********************************************************************
!                                                                      *
      MODULE jj2lsj_C
!                                                                      *
!     This module contains the (numerical) values of the subshell      *
!     terms in LS-coupling and in it are define some global variables  *
!     for jj2LSJ program.                                              *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                     last update: May 2011   *
!                                                                      *
!***********************************************************************
      USE vast_kind_param, ONLY:  LONG, DOUBLE
!
! Define some global data for the jj2LSJ transformation program
!
      type :: subshell_term_LS
         integer :: l_shell ! angular momentum l
         integer :: w       ! w
         integer :: Q       ! Subshell total quasispin 2*Q
         integer :: LL      ! Subshell total angular momentum 2*L
         integer :: S       ! Subshell Total sinp 2*S
      end type subshell_term_LS
!
      type :: LS_jj_me
!         sequence
         integer       :: w, Q, L, S, J, Nm, Qm, Jm, Qp, Jp
         integer       :: factor
         integer(LONG) :: nom, denom
      end type LS_jj_me
!
! Define the values of all LS-jj transformation coefficients
!
      integer, parameter :: LS_jj_number_p3 =  10, LS_jj_number_p4  =    9, &
                            LS_jj_number_p5 =   2, LS_jj_number_p6  =    1, &
                            LS_jj_number_d3 =  65, LS_jj_number_d4  =  166, &
                            LS_jj_number_d5 = 184, LS_jj_number_d6  =  166, &
                            LS_jj_number_d7 =  65, LS_jj_number_d8  =   19, &
                            LS_jj_number_d9 =   2, LS_jj_number_d10 =    1, &
                            LS_jj_number_f3 = 216, LS_jj_number_f4  = 1210, &
                            LS_jj_number_f5 =3799, LS_jj_number_f6  = 7313, &
                            LS_jj_number_f7 =8003
!
! Define all possible antisymetric subshell terms in LS-coupling
!
   type(subshell_term_LS), dimension(1:2), parameter ::   &
      term_LS_s =(/                                       &
      subshell_term_LS(0, 0, 0, 0, 1),                    &
      subshell_term_LS(0, 0, 1, 0, 0)  /)
   type(subshell_term_LS), dimension(1:6), parameter ::   &
      term_LS_p =(/                                       &
      subshell_term_LS(1, 0, 0, 0, 3),                    &
      subshell_term_LS(1, 0, 2, 2, 1),                    &
      subshell_term_LS(1, 0, 0, 4, 1),                    &
      subshell_term_LS(1, 0, 3, 0, 0),                    &
      subshell_term_LS(1, 0, 1, 2, 2),                    &
      subshell_term_LS(1, 0, 1, 4, 0)  /)
   type(subshell_term_LS), dimension(1:32), parameter ::  &
      term_LS_d =(/                                       &
      subshell_term_LS(2, 0, 0, 0, 5),                    &
      subshell_term_LS(2, 0, 0, 0, 1),                    &
      subshell_term_LS(2, 0, 2, 2, 3),                    &
      subshell_term_LS(2, 0, 2, 2, 1),                    &
      subshell_term_LS(2, 0, 4, 4, 1),                    &
      subshell_term_LS(2, 0, 2, 4, 1),                    &
      subshell_term_LS(2, 0, 0, 4, 3),                    &
      subshell_term_LS(2, 0, 0, 4, 1),                    &
      subshell_term_LS(2, 0, 2, 6, 3),                    &
      subshell_term_LS(2, 0, 2, 6, 1),                    &
      subshell_term_LS(2, 0, 0, 6, 1),                    &
      subshell_term_LS(2, 0, 2, 8, 1),                    &
      subshell_term_LS(2, 0, 0, 8, 3),                    &
      subshell_term_LS(2, 0, 0, 8, 1),                    &
      subshell_term_LS(2, 0, 2,10, 1),                    &
      subshell_term_LS(2, 0, 0,12, 1),                    &
      subshell_term_LS(2, 0, 5, 0, 0),                    &
      subshell_term_LS(2, 0, 1, 0, 0),                    &
      subshell_term_LS(2, 0, 3, 2, 2),                    &
      subshell_term_LS(2, 0, 1, 2, 2),                    &
      subshell_term_LS(2, 0, 1, 4, 4),                    &
      subshell_term_LS(2, 0, 1, 4, 2),                    &
      subshell_term_LS(2, 0, 3, 4, 0),                    &
      subshell_term_LS(2, 0, 1, 4, 0),                    &
      subshell_term_LS(2, 0, 3, 6, 2),                    &
      subshell_term_LS(2, 0, 1, 6, 2),                    &
      subshell_term_LS(2, 0, 1, 6, 0),                    &
      subshell_term_LS(2, 0, 1, 8, 2),                    &
      subshell_term_LS(2, 0, 3, 8, 0),                    &
      subshell_term_LS(2, 0, 1, 8, 0),                    &
      subshell_term_LS(2, 0, 1,10, 2),                    &
      subshell_term_LS(2, 0, 1,12, 0)  /)
   type(subshell_term_LS), dimension(1:238), parameter :: &
      term_LS_f =(/                                       &
      subshell_term_LS(3, 0, 0, 0, 7),                    &
      subshell_term_LS(3, 0, 2, 2, 5),                    &
      subshell_term_LS(3, 0, 0, 4, 5),                    &
      subshell_term_LS(3, 0, 2, 6, 5),                    &
      subshell_term_LS(3, 0, 0, 8, 5),                    &
      subshell_term_LS(3, 0, 2,10, 5),                    &
      subshell_term_LS(3, 0, 0,12, 5),                    &
      subshell_term_LS(3, 1, 4, 0, 3),                    &
      subshell_term_LS(3, 2, 0, 0, 3),                    &
      subshell_term_LS(3, 1, 2, 2, 3),                    &
      subshell_term_LS(3, 2, 2, 2, 3),                    &
      subshell_term_LS(3, 1, 4, 4, 3),                    &
      subshell_term_LS(3, 2, 2, 4, 3),                    &
      subshell_term_LS(3, 3, 2, 4, 3),                    &
      subshell_term_LS(3, 4, 0, 4, 3),                    &
      subshell_term_LS(3, 5, 0, 4, 3),                    &
      subshell_term_LS(3, 6, 0, 4, 3),                    &
      subshell_term_LS(3, 1, 4, 6, 3),                    &
      subshell_term_LS(3, 2, 2, 6, 3),                    &
      subshell_term_LS(3, 3, 2, 6, 3),                    &
      subshell_term_LS(3, 4, 2, 6, 3),                    &
      subshell_term_LS(3, 5, 0, 6, 3),                    &
      subshell_term_LS(3, 1, 4, 8, 3),                    &
      subshell_term_LS(3, 2, 2, 8, 3),                    &
      subshell_term_LS(3, 3, 2, 8, 3),                    &
      subshell_term_LS(3, 4, 2, 8, 3),                    &
      subshell_term_LS(3, 5, 0, 8, 3),                    &
      subshell_term_LS(3, 6, 0, 8, 3),                    &
      subshell_term_LS(3, 7, 0, 8, 3),                    &
      subshell_term_LS(3, 1, 2,10, 3),                    &
      subshell_term_LS(3, 2, 2,10, 3),                    &
      subshell_term_LS(3, 3, 2,10, 3),                    &
      subshell_term_LS(3, 4, 0,10, 3),                    &
      subshell_term_LS(3, 5, 0,10, 3),                    &
      subshell_term_LS(3, 1, 4,12, 3),                    &
      subshell_term_LS(3, 2, 2,12, 3),                    &
      subshell_term_LS(3, 3, 2,12, 3),                    &
      subshell_term_LS(3, 4, 0,12, 3),                    &
      subshell_term_LS(3, 5, 0,12, 3),                    &
      subshell_term_LS(3, 1, 2,14, 3),                    &
      subshell_term_LS(3, 2, 2,14, 3),                    &
      subshell_term_LS(3, 3, 0,14, 3),                    &
      subshell_term_LS(3, 1, 2,16, 3),                    &
      subshell_term_LS(3, 2, 0,16, 3),                    &
      subshell_term_LS(3, 3, 0,16, 3),                    &
      subshell_term_LS(3, 0, 2,18, 3),                    &
      subshell_term_LS(3, 0, 0,20, 3),                    &
      subshell_term_LS(3, 1, 0, 0, 1),                    &
      subshell_term_LS(3, 2, 0, 0, 1),                    &
      subshell_term_LS(3, 1, 4, 2, 1),                    &
      subshell_term_LS(3, 2, 2, 2, 1),                    &
      subshell_term_LS(3, 3, 2, 2, 1),                    &
      subshell_term_LS(3, 4, 2, 2, 1),                    &
      subshell_term_LS(3, 5, 0, 2, 1),                    &
      subshell_term_LS(3, 1, 4, 4, 1),                    &
      subshell_term_LS(3, 2, 4, 4, 1),                    &
      subshell_term_LS(3, 3, 2, 4, 1),                    &
      subshell_term_LS(3, 4, 2, 4, 1),                    &
      subshell_term_LS(3, 5, 2, 4, 1),                    &
      subshell_term_LS(3, 6, 0, 4, 1),                    &
      subshell_term_LS(3, 7, 0, 4, 1),                    &
      subshell_term_LS(3, 1, 6, 6, 1),                    &
      subshell_term_LS(3, 2, 4, 6, 1),                    &
      subshell_term_LS(3, 3, 2, 6, 1),                    &
      subshell_term_LS(3, 4, 2, 6, 1),                    &
      subshell_term_LS(3, 5, 2, 6, 1),                    &
      subshell_term_LS(3, 6, 2, 6, 1),                    &
      subshell_term_LS(3, 7, 2, 6, 1),                    &
      subshell_term_LS(3, 8, 0, 6, 1),                    &
      subshell_term_LS(3, 9, 0, 6, 1),                    &
      subshell_term_LS(3,10, 0, 6, 1),                    &
      subshell_term_LS(3, 1, 4, 8, 1),                    &
      subshell_term_LS(3, 2, 4, 8, 1),                    &
      subshell_term_LS(3, 3, 2, 8, 1),                    &
      subshell_term_LS(3, 4, 2, 8, 1),                    &
      subshell_term_LS(3, 5, 2, 8, 1),                    &
      subshell_term_LS(3, 6, 2, 8, 1),                    &
      subshell_term_LS(3, 7, 0, 8, 1),                    &
      subshell_term_LS(3, 8, 0, 8, 1),                    &
      subshell_term_LS(3, 9, 0, 8, 1),                    &
      subshell_term_LS(3,10, 0, 8, 1),                    &
      subshell_term_LS(3, 1, 4,10, 1),                    &
      subshell_term_LS(3, 2, 4,10, 1),                    &
      subshell_term_LS(3, 3, 2,10, 1),                    &
      subshell_term_LS(3, 4, 2,10, 1),                    &
      subshell_term_LS(3, 5, 2,10, 1),                    &
      subshell_term_LS(3, 6, 2,10, 1),                    &
      subshell_term_LS(3, 7, 2,10, 1),                    &
      subshell_term_LS(3, 8, 0,10, 1),                    &
      subshell_term_LS(3, 9, 0,10, 1),                    &
      subshell_term_LS(3, 1, 4,12, 1),                    &
      subshell_term_LS(3, 2, 2,12, 1),                    &
      subshell_term_LS(3, 3, 2,12, 1),                    &
      subshell_term_LS(3, 4, 2,12, 1),                    &
      subshell_term_LS(3, 5, 2,12, 1),                    &
      subshell_term_LS(3, 6, 0,12, 1),                    &
      subshell_term_LS(3, 7, 0,12, 1),                    &
      subshell_term_LS(3, 8, 0,12, 1),                    &
      subshell_term_LS(3, 9, 0,12, 1),                    &
      subshell_term_LS(3, 1, 4,14, 1),                    &
      subshell_term_LS(3, 2, 2,14, 1),                    &
      subshell_term_LS(3, 3, 2,14, 1),                    &
      subshell_term_LS(3, 4, 2,14, 1),                    &
      subshell_term_LS(3, 5, 2,14, 1),                    &
      subshell_term_LS(3, 6, 0,14, 1),                    &
      subshell_term_LS(3, 7, 0,14, 1),                    &
      subshell_term_LS(3, 1, 4,16, 1),                    &
      subshell_term_LS(3, 2, 2,16, 1),                    &
      subshell_term_LS(3, 3, 2,16, 1),                    &
      subshell_term_LS(3, 4, 0,16, 1),                    &
      subshell_term_LS(3, 5, 0,16, 1),                    &
      subshell_term_LS(3, 1, 2,18, 1),                    &
      subshell_term_LS(3, 2, 2,18, 1),                    &
      subshell_term_LS(3, 3, 0,18, 1),                    &
      subshell_term_LS(3, 4, 0,18, 1),                    &
      subshell_term_LS(3, 1, 2,20, 1),                    &
      subshell_term_LS(3, 2, 0,20, 1),                    &
      subshell_term_LS(3, 0, 2,22, 1),                    &
      subshell_term_LS(3, 0, 0,24, 1),                    &
      subshell_term_LS(3, 0, 1, 6, 6),                    &
      subshell_term_LS(3, 1, 3, 4, 4),                    &
      subshell_term_LS(3, 2, 1, 4, 4),                    &
      subshell_term_LS(3, 3, 1, 4, 4),                    &
      subshell_term_LS(3, 1, 3, 6, 4),                    &
      subshell_term_LS(3, 2, 1, 6, 4),                    &
      subshell_term_LS(3, 1, 3, 8, 4),                    &
      subshell_term_LS(3, 2, 1, 8, 4),                    &
      subshell_term_LS(3, 3, 1, 8, 4),                    &
      subshell_term_LS(3, 0, 1, 2, 4),                    &
      subshell_term_LS(3, 1, 1,10, 4),                    &
      subshell_term_LS(3, 2, 1,10, 4),                    &
      subshell_term_LS(3, 0, 3, 0, 4),                    &
      subshell_term_LS(3, 1, 3,12, 4),                    &
      subshell_term_LS(3, 2, 1,12, 4),                    &
      subshell_term_LS(3, 0, 1,14, 4),                    &
      subshell_term_LS(3, 0, 1,16, 4),                    &
      subshell_term_LS(3, 1, 5, 6, 2),                    &
      subshell_term_LS(3, 2, 3, 6, 2),                    &
      subshell_term_LS(3, 6, 1, 6, 2),                    &
      subshell_term_LS(3, 8, 1, 6, 2),                    &
      subshell_term_LS(3, 1, 3, 4, 2),                    &
      subshell_term_LS(3, 2, 3, 4, 2),                    &
      subshell_term_LS(3, 3, 1, 4, 2),                    &
      subshell_term_LS(3, 4, 1, 4, 2),                    &
      subshell_term_LS(3, 3, 3, 6, 2),                    &
      subshell_term_LS(3, 5, 1, 6, 2),                    &
      subshell_term_LS(3, 1, 3, 8, 2),                    &
      subshell_term_LS(3, 2, 3, 8, 2),                    &
      subshell_term_LS(3, 4, 1, 8, 2),                    &
      subshell_term_LS(3, 5, 1, 8, 2),                    &
      subshell_term_LS(3, 5, 1, 4, 2),                    &
      subshell_term_LS(3, 4, 3, 6, 2),                    &
      subshell_term_LS(3, 7, 1, 6, 2),                    &
      subshell_term_LS(3, 9, 1, 6, 2),                    &
      subshell_term_LS(3, 3, 3, 8, 2),                    &
      subshell_term_LS(3, 6, 1, 8, 2),                    &
      subshell_term_LS(3, 7, 1, 8, 2),                    &
      subshell_term_LS(3, 1, 5, 2, 2),                    &
      subshell_term_LS(3, 2, 3, 2, 2),                    &
      subshell_term_LS(3, 3, 3, 2, 2),                    &
      subshell_term_LS(3, 1, 5,10, 2),                    &
      subshell_term_LS(3, 2, 3,10, 2),                    &
      subshell_term_LS(3, 3, 3,10, 2),                    &
      subshell_term_LS(3, 4, 3,10, 2),                    &
      subshell_term_LS(3, 4, 1, 2, 2),                    &
      subshell_term_LS(3, 5, 1,10, 2),                    &
      subshell_term_LS(3, 6, 1,10, 2),                    &
      subshell_term_LS(3, 5, 1, 2, 2),                    &
      subshell_term_LS(3, 6, 1, 2, 2),                    &
      subshell_term_LS(3, 7, 1,10, 2),                    &
      subshell_term_LS(3, 8, 1,10, 2),                    &
      subshell_term_LS(3, 9, 1,10, 2),                    &
      subshell_term_LS(3, 1, 3,12, 2),                    &
      subshell_term_LS(3, 2, 3,12, 2),                    &
      subshell_term_LS(3, 3, 1,12, 2),                    &
      subshell_term_LS(3, 3, 1,12, 2),                    &
      subshell_term_LS(3, 5, 1,12, 2),                    &
      subshell_term_LS(3, 6, 1,12, 2),                    &
      subshell_term_LS(3, 1, 3,14, 2),                    &
      subshell_term_LS(3, 2, 3,14, 2),                    &
      subshell_term_LS(3, 3, 1,14, 2),                    &
      subshell_term_LS(3, 4, 1,14, 2),                    &
      subshell_term_LS(3, 5, 1,14, 2),                    &
      subshell_term_LS(3, 6, 1,14, 2),                    &
      subshell_term_LS(3, 1, 3,16, 2),                    &
      subshell_term_LS(3, 2, 1,16, 2),                    &
      subshell_term_LS(3, 3, 1,16, 2),                    &
      subshell_term_LS(3, 1, 3,18, 2),                    &
      subshell_term_LS(3, 2, 1,18, 2),                    &
      subshell_term_LS(3, 3, 1,18, 2),                    &
      subshell_term_LS(3, 0, 1,20, 2),                    &
      subshell_term_LS(3, 0, 1,22, 2),                    &
      subshell_term_LS(3, 2, 1, 6, 0),                    &
      subshell_term_LS(3, 3, 1, 6, 0),                    &
      subshell_term_LS(3, 4, 1, 6, 0),                    &
      subshell_term_LS(3, 1, 5, 4, 0),                    &
      subshell_term_LS(3, 2, 3, 4, 0),                    &
      subshell_term_LS(3, 3, 3, 4, 0),                    &
      subshell_term_LS(3, 1, 3, 6, 0),                    &
      subshell_term_LS(3, 1, 5, 8, 0),                    &
      subshell_term_LS(3, 2, 3, 8, 0),                    &
      subshell_term_LS(3, 3, 3, 8, 0),                    &
      subshell_term_LS(3, 5, 1, 4, 0),                    &
      subshell_term_LS(3, 5, 1, 8, 0),                    &
      subshell_term_LS(3, 6, 1, 4, 0),                    &
      subshell_term_LS(3, 6, 1, 8, 0),                    &
      subshell_term_LS(3, 7, 1, 8, 0),                    &
      subshell_term_LS(3, 8, 1, 8, 0),                    &
      subshell_term_LS(3, 4, 3, 4, 0),                    &
      subshell_term_LS(3, 4, 3, 8, 0),                    &
      subshell_term_LS(3, 1, 3,10, 0),                    &
      subshell_term_LS(3, 2, 3,10, 0),                    &
      subshell_term_LS(3, 0, 1, 2, 0),                    &
      subshell_term_LS(3, 3, 1,10, 0),                    &
      subshell_term_LS(3, 4, 1,10, 0),                    &
      subshell_term_LS(3, 1, 7, 0, 0),                    &
      subshell_term_LS(3, 1, 5,12, 0),                    &
      subshell_term_LS(3, 2, 3, 0, 0),                    &
      subshell_term_LS(3, 2, 3,12, 0),                    &
      subshell_term_LS(3, 3, 3,12, 0),                    &
      subshell_term_LS(3, 3, 1, 0, 0),                    &
      subshell_term_LS(3, 4, 1,12, 0),                    &
      subshell_term_LS(3, 5, 1,12, 0),                    &
      subshell_term_LS(3, 4, 1, 0, 0),                    &
      subshell_term_LS(3, 6, 1,12, 0),                    &
      subshell_term_LS(3, 7, 1,12, 0),                    &
      subshell_term_LS(3, 1, 3,14, 0),                    &
      subshell_term_LS(3, 2, 1,14, 0),                    &
      subshell_term_LS(3, 3, 1,14, 0),                    &
      subshell_term_LS(3, 1, 3,16, 0),                    &
      subshell_term_LS(3, 2, 3,16, 0),                    &
      subshell_term_LS(3, 3, 1,16, 0),                    &
      subshell_term_LS(3, 4, 1,16, 0),                    &
      subshell_term_LS(3, 1, 1,18, 0),                    &
      subshell_term_LS(3, 2, 1,18, 0),                    &
      subshell_term_LS(3, 1, 3,20, 0),                    &
      subshell_term_LS(3, 2, 1,20, 0),                    &
      subshell_term_LS(3, 0, 1,24, 0)  /)
   type(subshell_term_LS), dimension(1:1), parameter ::   &
      term_LS_g1 =(/                                      &
      subshell_term_LS(4, 0, 8, 8, 1)  /)
   type(subshell_term_LS), dimension(1:9), parameter ::   &
      term_LS_g2 =(/                                      &
      subshell_term_LS(4, 0, 9, 0, 0),                    &
      subshell_term_LS(4, 0, 7, 2, 2),                    &
      subshell_term_LS(4, 0, 7, 4, 0),                    &
      subshell_term_LS(4, 0, 7, 6, 2),                    &
      subshell_term_LS(4, 0, 7, 8, 0),                    &
      subshell_term_LS(4, 0, 7,10, 2),                    &
      subshell_term_LS(4, 0, 7,12, 0),                    &
      subshell_term_LS(4, 0, 7,14, 2),                    &
      subshell_term_LS(4, 0, 7,16, 0)  /)
   type(subshell_term_LS), dimension(1:1), parameter ::   &
      term_LS_h1 =(/                                      &
      subshell_term_LS(5, 0,10,10, 1)  /)
   type(subshell_term_LS), dimension(1:11), parameter ::  &
      term_LS_h2 =(/                                      &
      subshell_term_LS(5, 0,11, 0, 0),                    &
      subshell_term_LS(5, 0, 9, 2, 2),                    &
      subshell_term_LS(5, 0, 9, 4, 0),                    &
      subshell_term_LS(5, 0, 9, 6, 2),                    &
      subshell_term_LS(5, 0, 9, 8, 0),                    &
      subshell_term_LS(5, 0, 9,10, 2),                    &
      subshell_term_LS(5, 0, 9,12, 0),                    &
      subshell_term_LS(5, 0, 9,14, 2),                    &
      subshell_term_LS(5, 0, 9,16, 0),                    &
      subshell_term_LS(5, 0, 9,18, 2),                    &
      subshell_term_LS(5, 0, 9,20, 0)  /)
   type(subshell_term_LS), dimension(1:1), parameter ::   &
      term_LS_i1 =(/                                      &
      subshell_term_LS(6, 0,12,12, 1)  /)
   type(subshell_term_LS), dimension(1:13), parameter ::  &
      term_LS_i2 =(/                                      &
      subshell_term_LS(6, 0,13, 0, 0),                    &
      subshell_term_LS(6, 0,11, 2, 2),                    &
      subshell_term_LS(6, 0,11, 4, 0),                    &
      subshell_term_LS(6, 0,11, 6, 2),                    &
      subshell_term_LS(6, 0,11, 8, 0),                    &
      subshell_term_LS(6, 0,11,10, 2),                    &
      subshell_term_LS(6, 0,11,12, 0),                    &
      subshell_term_LS(6, 0,11,14, 2),                    &
      subshell_term_LS(6, 0,11,16, 0),                    &
      subshell_term_LS(6, 0,11,18, 2),                    &
      subshell_term_LS(6, 0,11,20, 0),                    &
      subshell_term_LS(6, 0,11,22, 2),                    &
      subshell_term_LS(6, 0,11,24, 0)  /)
   type(subshell_term_LS), dimension(1:1), parameter ::   &
      term_LS_k1 =(/                                      &
      subshell_term_LS(7, 0,14,14, 1)  /)
   type(subshell_term_LS), dimension(1:15), parameter ::  &
      term_LS_k2 =(/                                      &
      subshell_term_LS(7, 0,15, 0, 0),                    &
      subshell_term_LS(7, 0,13, 2, 2),                    &
      subshell_term_LS(7, 0,13, 4, 0),                    &
      subshell_term_LS(7, 0,13, 6, 2),                    &
      subshell_term_LS(7, 0,13, 8, 0),                    &
      subshell_term_LS(7, 0,13,10, 2),                    &
      subshell_term_LS(7, 0,13,12, 0),                    &
      subshell_term_LS(7, 0,13,14, 2),                    &
      subshell_term_LS(7, 0,13,16, 0),                    &
      subshell_term_LS(7, 0,13,18, 2),                    &
      subshell_term_LS(7, 0,13,20, 0),                    &
      subshell_term_LS(7, 0,13,22, 2),                    &
      subshell_term_LS(7, 0,13,24, 0),                    &
      subshell_term_LS(7, 0,13,26, 2),                    &
      subshell_term_LS(7, 0,13,28, 0) /)
   type(subshell_term_LS), dimension(1:1), parameter ::   &
      term_LS_l1 =(/                                      &
      subshell_term_LS(8, 0,16,16, 1)  /)
   type(subshell_term_LS), dimension(1:17), parameter ::  &
      term_LS_l2 =(/                                      &
      subshell_term_LS(8, 0,17, 0, 0),                    &
      subshell_term_LS(8, 0,15, 2, 2),                    &
      subshell_term_LS(8, 0,15, 4, 0),                    &
      subshell_term_LS(8, 0,15, 6, 2),                    &
      subshell_term_LS(8, 0,15, 8, 0),                    &
      subshell_term_LS(8, 0,15,10, 2),                    &
      subshell_term_LS(8, 0,15,12, 0),                    &
      subshell_term_LS(8, 0,15,14, 2),                    &
      subshell_term_LS(8, 0,15,16, 0),                    &
      subshell_term_LS(8, 0,15,18, 2),                    &
      subshell_term_LS(8, 0,15,20, 0),                    &
      subshell_term_LS(8, 0,15,22, 2),                    &
      subshell_term_LS(8, 0,15,24, 0),                    &
      subshell_term_LS(8, 0,15,26, 2),                    &
      subshell_term_LS(8, 0,15,28, 0),                    &
      subshell_term_LS(8, 0,15,30, 2),                    &
      subshell_term_LS(8, 0,15,32, 0) /)
   type(subshell_term_LS), dimension(1:1), parameter ::   &
      term_LS_m1 =(/                                      &
      subshell_term_LS(9, 0,18,18, 1)  /)
   type(subshell_term_LS), dimension(1:19), parameter ::  &
      term_LS_m2 =(/                                      &
      subshell_term_LS(9, 0,19, 0, 0),                    &
      subshell_term_LS(9, 0,17, 2, 2),                    &
      subshell_term_LS(9, 0,17, 4, 0),                    &
      subshell_term_LS(9, 0,17, 6, 2),                    &
      subshell_term_LS(9, 0,17, 8, 0),                    &
      subshell_term_LS(9, 0,17,10, 2),                    &
      subshell_term_LS(9, 0,17,12, 0),                    &
      subshell_term_LS(9, 0,17,14, 2),                    &
      subshell_term_LS(9, 0,17,16, 0),                    &
      subshell_term_LS(9, 0,17,18, 2),                    &
      subshell_term_LS(9, 0,17,20, 0),                    &
      subshell_term_LS(9, 0,17,22, 2),                    &
      subshell_term_LS(9, 0,17,24, 0),                    &
      subshell_term_LS(9, 0,17,26, 2),                    &
      subshell_term_LS(9, 0,17,28, 0),                    &
      subshell_term_LS(9, 0,17,30, 2),                    &
      subshell_term_LS(9, 0,17,32, 0),                    &
      subshell_term_LS(9, 0,17,34, 2),                    &
      subshell_term_LS(9, 0,17,36, 0) /)
      END MODULE jj2lsj_C


! Function and utilities to compute
! magnetic and electric dipoles
module dipole_functions
    use meshread_mod
    use tools
    implicit none

    real(8), parameter, private :: pi = 4d0 * atan(1d0)
    complex(8), parameter, private :: IU = (0d0, 1d0)

    private :: Dipole, CurlDipole

contains
    ! Computes the Electric Dipole fields on the nodes of the mesh
    subroutine ElectricDipoleOnGmsh(pol, src, k, w, mu, msh, Einc, Hinc)
        type(Mesh), intent(in) :: msh
        real(8), intent(in) :: k         ! wavenumber [1/m]
        real(8), intent(in) :: w         ! angular frequency [rad/s]
        real(8), intent(in) :: mu        ! permeability [H/m]
        real(8), intent(in) :: pol(3), src(3)
        complex(8), allocatable, intent(out) :: Einc(:, :), Hinc(:, :)

        call DipoleFieldsOnGmsh(pol, src, k, msh, Hinc, Einc)

        ! Adjust constants
        Einc = Einc * (-1d0/k**2)
        Hinc = Hinc / (-IU * w * mu)
    end subroutine ElectricDipoleOnGmsh

    ! Computes the Electric Dipole fields on the evaluation mesh
    subroutine ElectricDipoleOnEvlMsh(pol, src, k, w, mu, xEvl, Einc, Hinc)
        real(8), intent(in) :: xEvl(:, :)
        real(8), intent(in) :: k         ! wavenumber [1/m]
        real(8), intent(in) :: w         ! angular frequency [rad/s]
        real(8), intent(in) :: mu        ! permeability [H/m]
        real(8), intent(in) :: pol(3), src(3)
        complex(8), allocatable, intent(out) :: Einc(:, :), Hinc(:, :)

        call DipoleFieldsOnEvlMsh(pol, src, k, xEvl, Hinc, Einc)

        ! Adjust constants
        Einc = Einc * (-1d0/k**2)
        Hinc = Hinc / (-IU * w * mu)
    end subroutine ElectricDipoleOnEvlMsh

    ! Computes the Dipole and the CurlDipole fields on the evaluation mesh
    subroutine DipoleFieldsOnEvlMsh(pol, src, k, xEvl, Eeval, Heval)
        real(8), intent(in) :: xEvl(:, :)
        real(8), intent(in) :: k, pol(3), src(3)
        complex(8), allocatable, intent(out) :: Eeval(:, :), Heval(:, :)
        integer :: j, nEvl

        nEvl = size(xEvl, 1)
        allocate(Eeval(nEvl, 3))
        allocate(Heval(nEvl, 3))

        do j = 1, nEvl
            Eeval(j,:) = Dipole(pol, src, k, xEvl(j, :))
            Heval(j,:) = CurlDipole(pol, src, k, xEvl(j, :))
        end do
    end subroutine DipoleFieldsOnEvlMsh

    ! Computes the Dipole and the CurlDipole fields on the nodes of the mesh
    subroutine DipoleFieldsOnGmsh(pol, src, k, msh, Einc, Hinc)
        type(Mesh), intent(in) :: msh
        real(8), intent(in) :: k, pol(3), src(3)
        complex(8), allocatable, intent(out) :: Einc(:, :), Hinc(:, :)
        integer :: j

        allocate(Einc(1:msh%nbNod, 3))
        allocate(Hinc(1:msh%nbNod, 3))

        do j = 1, msh%nbNod
            Einc(j,:) = Dipole(pol, src, k, msh%POS(j,:))
            Hinc(j,:) = CurlDipole(pol, src, k, msh%POS(j,:))
        end do
    end subroutine DipoleFieldsOnGmsh

    ! Computes the CurlDipole field on the nodes of the mesh
    function CurlDipoleOnGmsh(pol, src, k, msh) result(F)
        type(Mesh), intent(in) :: msh
        real(8), intent(in) :: k, pol(3), src(3)
        complex(8) :: F(msh%nbNod, 3)
        integer :: j

        do j=1,msh%nbNod
            F(j,:) = CurlDipole(pol, src, k, msh%POS(j,:))
        end do
    end function CurlDipoleOnGmsh

    ! Computes the Dipole field on the nodes of the mesh
    function DipoleOnGmsh(pol, src, k, msh) result(F)
        type(Mesh), intent(in) :: msh
        real(8), intent(in) :: k, pol(3), src(3)
        complex(8) :: F(msh%nbNod, 3)
        integer :: j

        do j=1,msh%nbNod
            F(j,:) = CurlDipole(pol, src, k, msh%POS(j,:))
        end do
    end function DipoleOnGmsh

    ! Computes the curl of a dipole: curl(cross(p, grad(G)))
    function CurlDipole(pol, src, k, pt) result(res)
        real(8), intent(in) :: k, pol(3), src(3), pt(3)
        complex(8) :: res(3)
        real(8) :: R, Rvec(3), Rhat(3)
        real(8) :: kR, kR2

        Rvec = pt - src
        R = sqrt(sum(Rvec * Rvec))
        Rhat = Rvec / R
        kR = k * R
        kR2 = kR ** 2

        res = -(1d0 + IU/kR - 1d0/kR2)*pol  &
              + (1d0 + 3d0*IU/kR - 3d0/kR2)*sum(pol*Rhat)*Rhat
        res = res * k**2 * exp(IU*k*R)/(4d0*pi*R)
    end function CurlDipole

    ! Computes a dipole: cross(p, grad(G))
    function Dipole(pol, src, k, pt) result(F)
        real(8), intent(in) :: k, pol(3), src(3), pt(3)
        complex(8) :: F(3)
        complex(8) :: G, dG
        real(8) :: R,Rvec(3)

        Rvec = pt-src
        R = sqrt(sum(Rvec*Rvec))
        G = exp(iu*k*R)/(4d0*PI*R)
        dG = (iu*k-1.0d0/R)*G
        F = dG/R*cross(pol,Rvec)
    end function Dipole
end module


	SUBROUTINE IPRELRISK
     . (XALPHA,POWER,XP0,XN,XM,UORF,P1L,ODDSL,RL,P1H,ODDSH,RH)
!MS$ATTRIBUTES REFERENCE :: P1L
!MS$ATTRIBUTES REFERENCE :: ODDSL
!MS$ATTRIBUTES REFERENCE :: RL
!MS$ATTRIBUTES REFERENCE :: P1H
!MS$ATTRIBUTES REFERENCE :: ODDSH
!MS$ATTRIBUTES REFERENCE :: RH
	IMPLICIT NONE

	REAL*4 XALPHA,POWER,XP0,XN,XM,P1L,ODDSL,RL,P1H,ODDSH,RH
	INTEGER*4 UORF
C
C	Relative risk CALCULATIONS FOR INDEPENDENT PROPORTIONS
C	DERIVE Relative risk FOR EACH GROUP IN A TRIAL OF TWO TREATMENTS
C	OR A CASE-CONTROL STUDY.
C	NORMAL APPROXIMATION ASSUMED
C
C       Power formula from:  Schlesselman:  Case-control Studies: Design,
C       Conduct, Analysis.  New York: Oxford U. Press 1982: 144-152.
C		See also:  FRIEDMAN, FURBERG AND DEMETS:
C		FUNDAMENTALS OF CLINICAL TRIALS. BOSTON: WRIGHT PSG. 1982:75.
C
C INPUT:
C	ALPHA	Type I error probability (two tailed)
C	POWER	The desired statistical power
C	P0	True probability of exposure in control group when CASECTL=Y
C		True probability of event in control group when CASECTL=N
C	N	Number of case patients
C	M	Ratio of control to case
C	CASECTRL 1 for case-control studies
C			2 for prospective studies
C	UORF =1 for uncorrected chi-square test
C        =2 for Fisher's exact test
C OUTPUT:
C	RELRISK	Relative risk of cases relative to controls that can be
C		detected with power POWER (when casectl=N)
C	ODDSRATIO Oddsratio of cases to controls that can be detected
C		with power POWER (when casectl=Y)
C	P1	True probability of exposure in case group that can be
C		detected with power POWER when CASECTL=Y
C		True probability of event in experimantal group that can
C		be detected with power POWER when CASECTL=N
C
C
C  Globals
C
C    Declare variables in common to be made available to the function.
C
	REAL ALPHA,BETA,P0,N,M,Q0,Q1
	COMMON/IPCOM/ALPHA,BETA,P0,N,M,Q0,Q1
C
C    Declare functions.
C
	EXTERNAL CHISQSIZE
	REAL CHISQSIZE
	EXTERNAL FISHERSIZ
	REAL FISHERSIZ
C
C    Locals
C
	INTEGER ERRORL,ERRORH
	REAL E1,EPS,Y1,Y2,Q1L,Q1H
C
C Code:
C
	ALPHA=XALPHA
	BETA=1.-POWER
	P0=XP0
	N=XN
	M=XM
C
C    Set error tolerance values.
C
	EPS=.0001*MIN(P0,1.-P0)
	E1=.0001*MIN(P0,1.-P0)
C
C    Use bisection with appropriate routine for Chi-squared or Fisher's
C    exact test.
C
	IF (UORF.EQ.1) THEN
C
C    Set initial end points for lower end point.
C
	    Y1=0.0
	    Y2=P0-EPS
C
C    Solve the equation for the lower solution.
C
	    CALL BISEC(Y1,Y2,EPS,E1,CHISQSIZE,P1L,ERRORL)
C
C    Set initial end points for high end point.
C
	    Y1=P0+EPS
	    Y2=1.
C
C    Solve the equation for the upper solution.
C
	    CALL BISEC(Y1,Y2,EPS,E1,CHISQSIZE,P1H,ERRORH)
	ELSE
C
C    Case of Fisher's exact test.
C
	    Y1=0.0
	    Y2=0.9999*P0
	    CALL BISEC(Y1,Y2,EPS,E1,FISHERSIZ,P1L,ERRORL)
	    Y1=0.9999*P0+0.0001
	    Y2=1.
	    CALL BISEC(Y1,Y2,EPS,E1,FISHERSIZ,P1H,ERRORH)
	END IF
C
C    Calculate the relative risk and odds ratio for low end.
C    21-Jan-1992 - Added calculation of Q1L to fix calculation of ODDSL.
C
	IF (ERRORL.EQ.0) THEN
		RL=P1L/P0
		Q1L=1.-P1L
		ODDSL=(P1L*Q0)/(P0*Q1L)
	ELSE
		P1L=0
		RL=0
		Q1L=0
		ODDSL=0
	END IF
C
C    Calculate the relative risk and odds ratio for high end.
C    21-Jan-1992 - Added calculation of Q1H to fix calculation of ODDSH.
C
	IF (ERRORH.EQ.0) THEN
		RH=P1H/P0
		Q1H=1.-P1H
		ODDSH=(P1H*Q0)/(P0*Q1H)
	ELSE
		P1H=0
		RH=0
		Q1H=0
		ODDSH=0
	END IF
C
C	Done.
C
	RETURN
	END