! All the functions are defines here
! Moment to calculate the moment of the size distribution
! coag to calculate the coagulation coefficient. Harmonic mean of free molecular regime, and continuum regime is used
! cond to calculate the condensation coefficient. Harmonic mean of free molecular regime, and continuum regime is used
! nucl to calculate the critical particle size, and the rate of nucleation
! reac to calculate the rate of reaction

module function_list
    use global_variables
    use derived_variables
    implicit none
    double precision :: ns, mu, lam, mm1, v1, r1, s1, sig, tau, K, vg_zero, t_start, t_final, delta_t, n_d

contains

    function moment(Nv,vgv,sdv,kv)
        implicit none
        double precision :: Nv,vgv,sdv, moment
        double precision :: kv
        call derived(ns, mu, lam, mm1, v1, r1, s1, sig, tau, K, vg_zero, t_start, delta_t, n_d)
        moment = Nv*(vgv)**(kv)*exp(9.0/2*(kv*kv)*log(sdv)*log(sdv))
    end function moment

    function coag(sd,rg,flag)

		double precision :: sd,rg,M0
		integer :: flag
        double precision :: b0, b2, c1, c2, lnsig, b5, com0fm, com0cn, com2fm, com2cn, com0, com2
		double precision, dimension(2) :: coag

		if ((flag == 0) .OR. (sd <= 1e-5) .OR. (rg <= 1e-15)) then
			coag(1) = 0.0
			coag(2) = 0.0

		else
			b0 = 0.633 + 0.092*sd*sd - 0.022*sd*sd*sd
			b2 = 0.39 + 0.5*sd - 0.214*sd*sd + 0.029*sd*sd*sd
			c1 = (6.0*kb*T*rg/rho)**(1.0/2)
			c2 = 2.0*kb*T/(3.0*mu)

			lnsig = log(sd)*log(sd)
			b5 = 1.257

			com0fm = c1 * b0 * ( exp(25.0/8* lnsig) + 2.0*exp(5.0/8*lnsig) + exp(1.0/8*lnsig) )
			com0cn = c2 * ( 1.0 + exp(lnsig) + b5 * (lam/rg) * exp(1.0/2 * lnsig) * (1.0 + exp(2.0*lnsig)) )

			com2fm = 2.0 * c1 * b2 * exp(3.0/2*lnsig) * ( exp(25.0/8* lnsig) + 2.0*exp(5.0/8*lnsig) + exp(1.0/8*lnsig) )
			com2cn = 2.0 * c2 * ( 1.0 + exp(lnsig) + b5 * (lam/rg) * exp(-1.0/2 * lnsig) * (1.0 + exp(-2.0*lnsig)))

			com0 = (com0fm * com0cn) / (com0fm + com0cn)
			com2 = (com2fm * com2cn) / (com2fm + com2cn)
			coag(1) = com0
			coag(2) = com2
		end if
    end function coag

    function cond(M0,sd,vg,flag)
        implicit none
        double precision :: lnsig, A, F1, F2, C1, etac1, delc1, psic1, etac2, delc2, psic2, M0
        double precision :: sd,vg
        double precision, dimension(3) :: cond
        integer :: flag

        lnsig = log(sd)*log(sd)
        A  = 1.0/3
        F1 = (36.0*PI)**A * v1 * ns * sqrt(kb*T/2.0/PI/mm1)
        F2 = sqrt(8.0*kb*T/(PI*mm1))
        C1 = (48.0*PI*PI)**A*ns*v1*lam/3.0

        if ((flag == 0) .or. (vg <= 0.0)) then
            cond(1) = 0.0
            cond(2) = 0.0
            cond(3) = 0.0

        elseif (flag== 1) then
            etac1 = v1**A /tau * vg**(2.0*A) * exp(2.0*lnsig)
            delc1 = etac1
            psic1 = 2.0 * v1**A /tau *vg**(2.0*A) * exp(8.0 * lnsig)
            etac2 = 8.0/3/tau/(2.0*r1) *lam * v1**(2.0*A) * vg**A * exp(lnsig/2)
            delc2 = etac2
            psic2 = 16.0/3/tau/(2.0*r1) * lam * v1 **(2.0*A) * vg**(A) * exp(3.5 * lnsig)
            cond(1) = etac1 * etac2 / (etac1 + etac2)
            cond(2) = delc1 * delc2 / (delc1 + delc2)
            cond(3) = psic1 * psic2 / (psic1 + psic2)
        elseif (flag ==2) then
            cond(1) = 0.0
            cond(2) = 0.0
            cond(3) = 0.0
        end if
    end function cond

    function nucl(S,flag)
        double precision :: S, sigmad, xks, kstar, coef1, pep, coef2, x11
        double precision, dimension(2) :: nucl
        integer :: flag

        if ((S < 1.001) .or. (flag == 0)) then
            nucl(1) = 0.0
            nucl(2) = 0.0

        elseif (flag == 1) then
            sigmad = gam * v1 ** (2.0/3) / (kb * T)
            xks = PI/6 * (4.0 * sigmad)**(3.0)
            kstar = xks / (log(S))**(3.0)
            coef1 = (2.0 / 9.0 / PI) ** (1.0/3)
            pep = kstar * (log (S)/2)
            if (pep < 60000.0) then
                coef2 = exp(-pep)
                x11 = ns / tau * S**(2.0) * coef1 * sigmad **(0.5) * coef2
                nucl(1) = kstar
                nucl(2) = x11

            else
                nucl(1) = 0.0
                nucl(2) = 0.0
            end if
        end if

        if (flag ==2) then
            nucl(1) = 1.0
            nucl(2) = 1.54*1e6 * exp(-74.03e3/(8.314*T)) * S * ns
        end if
    end function nucl

    function reac(flag)
        implicit none
        integer :: flag
        double precision :: Reac

        if (flag == 0) then
            Reac = 0.0
        else
            Reac = r_rate*(ns/tau)
        end if
    end function reac

end module function_list

!program test_function_list
!    use function_list
!    use derived_variables
!    implicit none
!    double precision :: ss1 = 100.0
!    double precision, dimension(2) :: nuclout
!
!    double precision :: momout
!    double precision,dimension(2) :: coagout
!    double precision,dimension(3) :: condout
!    double precision :: num_zero_0 = 1e11, dpg_zero_0 = 10.0e-9, sigma_g_zero_0 = 1.5, vg_zero_0
!
!    double precision :: insd = 1.0, momo = 0.0
!    call derived(ns, mu, lam, mm1, v1, r1, s1, sig, tau, K, vg_zero, t_start, delta_t, n_d)
!
!    vg_zero_0 = (22.0/7.0/6.0) * (dpg_zero_0)**3.0
!    momout  = moment(num_zero_0,vg_zero_0,sigma_g_zero_0,momo)
!    nuclout = nucl(ss1,1)
!    coagout = coag(insd,r1,1)
!    condout = cond(insd,v1,1)
!    print*, num_zero_0,vg_zero_0,sigma_g_zero_0
!    print*, momout
!    print*, coagout(1), coagout(2)
!    print*, condout(1), condout(2), condout(3)
!    print*, nuclout(1), nuclout(2)
!    print*, ns
!
!end program test_function_list


!*************************************************************************
!  subroutine rhs_nys_OldBasis(crhs, ntrain, nip) bind(C, name="AL4SAN_RHS")
   subroutine rhs_nys_OldBasis(nip, ntrain, crhs, m, n, local_nt, nb) bind(C, name="acoustic_generate_rhs")
    use, intrinsic :: iso_c_binding
    use global_com
    use global_geom,only:nsupan,sunod
    use global_dim
    use gaussintegraldata
    !implicit none
    integer::j,q,ielement1,ielement2,ielement0, m, local_nt, nb,n
    real(kind=dp)::vos1(2),vos2(2),vos3(2)
    integer::nodeo_sn(nnpt)
    real(kind=dp)::vcsio(2)
    real(kind=dp)::vippo(3),vhh1(3)
    real(kind=dp)::vuo(3),vvo(3),jacobo,vnormalo(3),vcpuvo(3),zeta(2,nipp),rNodes_field(3,nnpt)
    integer(c_int) ::ntrain
    integer(c_int) ::nip
    complex(c_double_complex), dimension(nb):: crhs
!    complex(c_double_complex), dimension(ntriangle*nipp):: crhs
    vos1=(/1.0_dp,0.0_dp/)  !right angle triangle vertex points in (u,v) space
    vos2=(/0.0_dp,1.0_dp/)  !the first number is u value, the second number is v value
    vos3=(/0.0_dp,0.0_dp/)
    !print*,"AL4SAN_RHS:",ntrain
  !  allocate(crhs(ntriangle*nipp))
   ! crhs=(0.0_dp,0.0_dp)
!   PRINT*,m, (m+local_nt-1), local_nt, nb
    counter=1
    do q=m,(m+local_nt-1)
!    do q=1,ntriangle
       nodeo_sn(:)=nsupan(:,q)  !serial numbers of curve triangle vertex points
       rNodes_field(:,:) = sunod(:,nodeo_sn)
       do j=1,nipp
                vcsio = alphao(j)*vos1+betao(j)*vos2+gammao(j)*vos3

                CALL mapGaussPtTo3Ddomain(vcsio(1),vcsio(2),nnpt,rNodes_field,vippo)
                ielement0=(counter-1)*nipp+j
                crhs(ielement0)=(-1.0_dp)*exp(cjvk*dot_product(vkk,vippo))
               !PRINT*,crhs(ielement0)
               !PRINT*,ielement0
       enddo
      counter=counter+1
    enddo

    !PRINT*,crhs(1)
    !PRINT*,crhs(2)

    !PRINT*,crhs(ntrain*nip-1)
    !PRINT*,crhs(ntrain*nip)
    return
  end subroutine rhs_nys_OldBasis
!*************************************************************************


module mod_general_bt
  use mod_prec
  use mod_error_id
  use mod_utility
  use mod_orth_band_types
  use mod_band_types
  use mod_general_ub
  implicit none

  private

  public :: f_general_bt, f_d_general_bt, f_z_general_bt, &
       f_general_to_bt, f_d_general_to_bt, f_z_general_to_bt, &
       general_to_bt, d_general_to_bt, z_general_to_bt, &
       d_bt_of_general, z_bt_of_general, bt_of_general, bt

  interface bt_of_general
     module procedure d_bt_of_general, z_bt_of_general
  end interface bt_of_general

  interface bt
     module procedure d_bt_of_general, z_bt_of_general
  end interface bt

  interface f_general_bt
     module procedure f_d_general_bt, f_z_general_bt
  end interface f_general_bt

  interface f_general_to_bt
     module procedure f_d_general_to_bt, f_z_general_to_bt
  end interface f_general_to_bt

  interface general_to_bt
     module procedure d_general_to_bt, z_general_to_bt
  end interface general_to_bt

contains

  function d_bt_of_general(a, ubw, lbwmax, ubwmax, tol, error) result(bt)
    type(d_bt), allocatable :: bt
    real(kind=dp), target, dimension(:,:), intent(inout) :: a
    type(error_info), intent(inout), optional :: error
    real(kind=dp), intent(in) :: tol
    integer(kind=int32), intent(in) :: ubw, lbwmax, ubwmax
    type(routine_info), parameter :: info=info_d_bt_of_general
    integer(kind=int32) :: n

    if (failure(error)) return
    call push_id(info, error)

    n=size(a,1)
    bt=d_new_bt(n,lbwmax,ubwmax)

    call d_general_to_bt(a,bt,ubw,tol,error)

    call pop_id(error)

  end function d_bt_of_general

  subroutine f_d_general_bt(a, n, lbws, lbwmax, numrotst, kst, cst, sst, tol, error)
    real(kind=dp), target, dimension(n,n), intent(inout) :: a
    integer(kind=int32), dimension(n,lbwmax), intent(out) :: kst
    real(kind=dp), dimension(n,lbwmax), intent(out) :: cst, sst
    real(kind=dp), intent(in) :: tol
    integer(kind=int32), dimension(n), intent(out) :: numrotst
    integer(kind=int32), dimension(n), intent(out) :: lbws
    type(error_info), intent(inout), optional :: error
    integer(kind=int32), intent(in) :: n, lbwmax
    !
    integer(kind=int32), dimension(lbwmax,n) :: jsu
    real(kind=dp), dimension(lbwmax,n) :: csu, ssu
    type(routine_info), parameter :: info=info_f_d_general_bt

    if (failure(error)) return
    call push_id(info, error)

    call ip_transpose(a)
    call f_d_general_ub(a,n,lbws,lbwmax,numrotst,jsu,csu,ssu,tol,error)
    if (success(error)) then
       call ip_transpose(a)
       kst=transpose(jsu)
       cst=transpose(csu)
       sst=transpose(ssu)
    endif
    call pop_id(error)

  end subroutine f_d_general_bt

  ! Errors:
  ! 0: no error
  ! 1: insufficient lower bw in bt%bc
  subroutine f_d_general_to_bt(a, n, b, lbw, ubw, lbwmax, ubwmax, &
       numrotst, kst, cst, sst, tol, error)
    real(kind=dp), target, dimension(n,n), intent(inout) :: a
    integer(kind=int32), dimension(n,lbwmax), intent(out) :: kst
    real(kind=dp), dimension(n,lbwmax), intent(out) :: cst, sst
    real(kind=dp), dimension(n,ubwmax+lbwmax+1), intent(out) :: b
    real(kind=dp), intent(in) :: tol
    integer(kind=int32), dimension(n), intent(out) :: numrotst
    integer(kind=int32), intent(out) :: lbw
    type(error_info), intent(inout), optional :: error
    integer(kind=int32), intent(in) :: n, ubw, ubwmax, lbwmax
    !
    integer(kind=int32), dimension(n) :: lbws
    type(routine_info), parameter :: info=info_f_d_general_to_bt

    if (failure(error)) return
    call push_id(info, error)

    if (n == 1) then
       numrotst=0;
       sst=0.0_dp; cst=0.0_dp; kst=0
       lbw=0
       b(1,1)=a(1,1)
       return
    end if

    call f_d_general_bt(a, n, lbws, lbwmax, numrotst, kst, cst, sst, tol, error)

    if (success(error)) then
       lbw=maxval(lbws)
       if (maxval(lbws) > lbwmax) then
          ! This should already have been detected in f_d_general_bt.
          call set_error(1, info, error); return
       else
          call d_extract_diagonals_br(a, n, b, lbw, ubw, lbwmax, ubwmax)
       end if
    end if

    call pop_id(error)
  end subroutine f_d_general_to_bt

  ! Errors:
  ! 0: no error
  ! 1: n < 1
  ! 2: bt%lbwmax < lbw
  ! 3: n is not the same for a and ub or bv.
  subroutine d_general_to_bt(a,bt,ubw,tol,error)
    real(kind=dp), target, dimension(:,:), intent(inout) :: a
    type(d_bt), intent(inout) :: bt
    type(error_info), intent(inout), optional :: error
    real(kind=dp), intent(in) :: tol
    integer(kind=int32), intent(in) :: ubw
    type(routine_info), parameter :: info=info_d_general_to_bt

    if (failure(error)) return
    call push_id(info, error)

    if (size(a,1) < 1) then
       call set_error(1, info, error); return
    end if
    if (get_ubwmax(bt) < ubw) then
       call set_error(2, info, error); return
    end if
    if (get_n(bt) /= size(a,1) .or. get_n(bt) /= size(a,2)) then
       call set_error(3, info, error); return
    end if
    call f_d_general_to_bt(a,get_n(bt),bt%br, bt%lbw, ubw, get_lbwmax(bt), get_ubwmax(bt), &
         bt%numrotst, bt%kst, bt%cst, bt%sst, tol, error)
    bt%ubw=ubw
    call pop_id(error)
  end subroutine d_general_to_bt

  function z_bt_of_general(a, ubw, lbwmax, ubwmax, tol, error) result(bt)
    type(z_bt), allocatable :: bt
    complex(kind=dp), target, dimension(:,:), intent(inout) :: a
    type(error_info), intent(inout), optional :: error
    real(kind=dp), intent(in) :: tol
    integer(kind=int32), intent(in) :: ubw, lbwmax, ubwmax
    type(routine_info), parameter :: info=info_z_bt_of_general
    integer(kind=int32) :: n

    if (failure(error)) return
    call push_id(info, error)

    n=size(a,1)
    bt=z_new_bt(n,lbwmax,ubwmax)

    call z_general_to_bt(a,bt,ubw,tol,error)

    call pop_id(error)

  end function z_bt_of_general

  subroutine f_z_general_bt(a, n, lbws, lbwmax, numrotst, kst, cst, sst, tol, error)
    complex(kind=dp), target, dimension(n,n), intent(inout) :: a
    integer(kind=int32), dimension(n,lbwmax), intent(out) :: kst
    real(kind=dp), dimension(n,lbwmax), intent(out) :: cst
    complex(kind=dp), dimension(n,lbwmax), intent(out) :: sst
    real(kind=dp), intent(in) :: tol
    integer(kind=int32), dimension(n), intent(out) :: numrotst
    integer(kind=int32), dimension(n), intent(out) :: lbws
    type(error_info), intent(inout), optional :: error
    integer(kind=int32), intent(in) :: n, lbwmax
    !
    integer(kind=int32), dimension(lbwmax,n) :: jsu
    real(kind=dp), dimension(lbwmax,n) :: csu
    complex(kind=dp), dimension(lbwmax,n) :: ssu
    type(routine_info), parameter :: info=info_f_z_general_bt

    if (failure(error)) return
    call push_id(info, error)

    call ip_transpose(a)
    call f_z_general_ub(a,n,lbws,lbwmax,numrotst,jsu,csu,ssu,tol,error)

    if (success(error)) then

       call ip_transpose(a)

       kst=transpose(jsu)
       cst=transpose(csu)
       sst=transpose(ssu)
    end if

    call pop_id(error)
  end subroutine f_z_general_bt

  ! Errors:
  ! 0: no error
  ! 1: insufficient lower bw in bt%bc
  subroutine f_z_general_to_bt(a, n, b, lbw, ubw, lbwmax, ubwmax, &
       numrotst, kst, cst, sst, tol, error)
    complex(kind=dp), target, dimension(n,n), intent(inout) :: a
    integer(kind=int32), dimension(n,lbwmax), intent(out) :: kst
    real(kind=dp), dimension(n,lbwmax), intent(out) :: cst
    complex(kind=dp), dimension(n,lbwmax), intent(out) :: sst
    complex(kind=dp), dimension(n,ubwmax+lbwmax+1), intent(out) :: b
    real(kind=dp), intent(in) :: tol
    integer(kind=int32), dimension(n), intent(out) :: numrotst
    integer(kind=int32), intent(out) :: lbw
    type(error_info), intent(inout), optional :: error
    integer(kind=int32), intent(in) :: n, ubw, ubwmax, lbwmax
    !
    integer(kind=int32), dimension(n) :: lbws
    type(routine_info), parameter :: info=info_f_z_general_to_bt

    if (failure(error)) return
    call push_id(info, error)

    if (n == 1) then
       numrotst=0;
       sst=(0.0_dp,0.0_dp); cst=0.0_dp; kst=0
       lbw=0
       b(1,1)=a(1,1)
       return
    end if

    call f_z_general_bt(a, n, lbws, lbwmax, numrotst, kst, cst, sst, tol, error)

    if (success(error)) then
       lbw=maxval(lbws)
       if (maxval(lbws) > lbwmax) then
          ! This should already have been detected in f_z_general_bt.
          call set_error(1, info, error); return
       else
          call z_extract_diagonals_br(a, n, b, lbw, ubw, lbwmax, ubwmax)
       end if
    end if
    call pop_id(error)
  end subroutine f_z_general_to_bt

  ! Errors:
  ! 0: no error
  ! 1: n < 1
  ! 2: ub%ubwmax < ubw
  ! 3: n is not the same for a and ub or bv.
  subroutine z_general_to_bt(a,bt,ubw,tol,error)
    complex(kind=dp), target, dimension(:,:), intent(inout) :: a
    type(z_bt), intent(inout) :: bt
    type(error_info), intent(inout), optional :: error
    real(kind=dp), intent(in) :: tol
    integer(kind=int32), intent(in) :: ubw
    type(routine_info), parameter :: info=info_z_general_to_bt

    if (failure(error)) return
    call push_id(info, error)

    if (size(a,1) < 1) then
       call set_error(1, info, error); return
    end if
    if (get_ubwmax(bt) < ubw) then
       call set_error(2, info, error); return
    end if
    if (get_n(bt) /= size(a,1) .or. get_n(bt) /= size(a,2)) then
       call set_error(3, info, error); return
    end if

    call f_z_general_to_bt(a,get_n(bt),bt%br, bt%lbw, ubw, get_lbwmax(bt), get_ubwmax(bt), &
         bt%numrotst, bt%kst, bt%cst, bt%sst, tol, error)
    bt%ubw=ubw
    call pop_id(error)

  end subroutine z_general_to_bt

end module mod_general_bt


Subroutine sor(aM,b,F,F0,a,Ic,Jc,Ib1,Ib2,scalar)
implicit none
integer maxl,i,j,k,Ic,Jc,Ib1,Ib2
real(8) err,omiga,a,rms
real(8) aM(5,Ic,Jc),b(Ic,Jc),F(Ic,Jc),F0(Ic,Jc)
real(8) Fo(Ic,Jc)
character(*) scalar
!$OMP PARALLEL PRIVATE(k,maxl,err,omiga)
maxl=1000
if(scalar=='dP') then
 err=1e-4
 omiga=1.9
else
 err=1e-6
 omiga=1
end if
DO k=1,maxl
  !$OMP WORKSHARE
  Fo=F
  !$OMP END WORKSHARE
  !$OMP DO
  DO j=1,Jc-1
    DO i=2,Ic-1
      if(j>1) then
        F(i,j)=omiga*(a*(aM(3,i,j)*F(i+1,j)+aM(2,i,j)*F(i-1,j)+aM(4,i,j)*F(i,j-1)+aM(5,i,j)*F(i,j+1)+b(i,j))/aM(1,i,j)+(1-a)*F0(i,j))+&
        (1-omiga)*F(i,j)
      else if(j==1.and.(i>Ib2.or.i<Ib1)) then
        F(i,j)=omiga*(a*(aM(3,i,j)*F(i+1,j)+aM(2,i,j)*F(i-1,j)+aM(4,i,j)*F(Ic+1-i,j)+aM(5,i,j)*F(i,j+1)+b(i,j))/aM(1,i,j)+(1-a)*F0(i,j))+&
        (1-omiga)*F(i,j)
      else
        if(scalar=='Te'.or.scalar=='Tw') then
          cycle
        else
          F(i,j)=omiga*(a*(aM(3,i,j)*F(i+1,j)+aM(2,i,j)*F(i-1,j)+aM(4,i,j)*F(i,j)+aM(5,i,j)*F(i,j+1)+b(i,j))/aM(1,i,j)+(1-a)*F0(i,j))+&
          (1-omiga)*F(i,j)
        end if
      end if
    end DO
  end DO
  !$OMP END DO
  !$OMP SINGLE
  rms=0
  !$OMP END SINGLE
  !$OMP DO REDUCTION(+:rms)
  DO j=1,Jc
   DO i=1,Ic
    if(abs(Fo(i,j))>0) then
     rms=rms+abs((F(i,j)-Fo(i,j))/Fo(i,j))
    else
     rms=rms+abs(F(i,j)-Fo(i,j))
    end if
   end DO
  end DO
  !$OMP END DO
  if(rms/(Ic*Jc)<err) exit
end DO
!$OMP END PARALLEL
!print *,rms/(Ic*Jc),k
end Subroutine sor

Subroutine CGSTAB(aM,b,F,F0,a,Ic,Jc,Ib1,Ib2,scalar)
implicit none
integer maxl,k,Ic,Jc,Ib1,Ib2
real(8) err,a
real(8) aM(5,Ic,Jc),b(Ic,Jc),F(Ic,Jc),F0(Ic,Jc)
real(8) alpha,beta,rho,omiga,rho0,sumrmsi,sumvrms,sumptz,sumpts
real(8) rmsi(Ic,Jc),rms(Ic,Jc),p(Ic,Jc),v(Ic,Jc),s(Ic,Jc),t(Ic,Jc),pt(Ic,Jc),y(Ic,Jc),z(Ic,Jc),aD(Ic,Jc)
character(*) scalar
character(4) pretype

!$OMP PARALLEL PRIVATE(alpha,beta,rho,omiga,rho0,k,maxl,err,pretype)
maxl=1000
if(scalar=='dP') then
 err=1e-8
else
 err=1e-10
end if
pretype='ILU'
Call Residual(aM,b,F,F0,rms,a,Ic,Jc,Ib1,Ib2,scalar)
!$OMP WORKSHARE
rmsi=rms
p=0
v=p
aD=aM(1,:,:)
!$OMP END WORKSHARE
if(pretype=='ILU') then
 Call DILU(aM,aD,Ic,Jc,Ib2)
end if
alpha=1
rho=1
omiga=1
DO k=1,maxl
 rho0=rho
 !$OMP WORKSHARE
 sumrmsi=sum(rmsi*rms)
 !$OMP END WORKSHARE
 rho=sumrmsi
 beta=(rho*alpha)/(rho0*omiga)
 !$OMP WORKSHARE
 p=rms+beta*(p-omiga*v)
 !$OMP END WORKSHARE
 if(pretype=='JAC') then
  !$OMP WORKSHARE
  y=a*p/aM(1,:,:)
  !$OMP END WORKSHARE
 else
  !$OMP WORKSHARE
  y=p
  !$OMP END WORKSHARE
 end if
 if(pretype=='ILU'.or.pretype=='SSOR') then
  Call Sorprecond(aM,aD,y,a,Ic,Jc,Ib1,Ib2,scalar,pretype)
 end if
 Call Multmatrixvector(aM,y,v,a,Ic,Jc,Ib1,Ib2,scalar)
 !$OMP WORKSHARE
 sumvrms=sum(v*rmsi)
 !$OMP END WORKSHARE
 alpha=rho/sumvrms
 !$OMP WORKSHARE
 s=rms-alpha*v
 !$OMP END WORKSHARE
 if(pretype=='JAC') then
  !$OMP WORKSHARE
  z=a*s/aM(1,:,:)
  !$OMP END WORKSHARE
 else
  !$OMP WORKSHARE
  z=s
  !$OMP END WORKSHARE
 end if
 if(pretype=='ILU'.or.pretype=='SSOR') then
  Call Sorprecond(aM,aD,z,a,Ic,Jc,Ib1,Ib2,scalar,pretype)
 end if
 Call Multmatrixvector(aM,z,t,a,Ic,Jc,Ib1,Ib2,scalar)
 if(pretype=='JAC') then
  !$OMP WORKSHARE
  pt=a*t/aM(1,:,:)
  !$OMP END WORKSHARE
 else
  !$OMP WORKSHARE
  pt=t
  !$OMP END WORKSHARE
 end if
 if(pretype=='ILU'.or.pretype=='SSOR') then
  Call Sorprecond(aM,aD,pt,a,Ic,Jc,Ib1,Ib2,scalar,pretype)
 end if
 !$OMP WORKSHARE
 sumptz=sum(pt*z)
 sumpts=sum(pt**2)
 !$OMP END WORKSHARE
 omiga=sumptz/sumpts
 !$OMP WORKSHARE
 F=F+alpha*y+omiga*z
 rms=s-omiga*t
 !$OMP END WORKSHARE
 if(sum(abs(rms))/(Ic*Jc)<err) exit
end DO
!$OMP END PARALLEL
!print *,sum(abs(rms))/(Ic*Jc),k
end Subroutine CGSTAB

Subroutine Residual(aM,b,F,F0,rms,a,Ic,Jc,Ib1,Ib2,scalar)
implicit none
integer i,j,Ic,Jc,Ib1,Ib2
real(8) a
real(8) aM(5,Ic,Jc),b(Ic,Jc),F(Ic,Jc),F0(Ic,Jc),rms(Ic,Jc)
character(*) scalar

!$OMP WORKSHARE
rms=0
!$OMP END WORKSHARE
!$OMP DO
DO j=1,Jc-1
 DO i=2,Ic-1
  if(j>1) then
   rms(i,j)=aM(3,i,j)*F(i+1,j)+aM(2,i,j)*F(i-1,j)+aM(4,i,j)*F(i,j-1)+aM(5,i,j)*F(i,j+1)+b(i,j)+(1-a)*aM(1,i,j)*F0(i,j)/a-aM(1,i,j)*F(i,j)/a
  else if(j==1.and.(i>Ib2.or.i<Ib1)) then
   rms(i,j)=aM(3,i,j)*F(i+1,j)+aM(2,i,j)*F(i-1,j)+aM(4,i,j)*F(Ic+1-i,j)+aM(5,i,j)*F(i,j+1)+b(i,j)+(1-a)*aM(1,i,j)*F0(i,j)/a-aM(1,i,j)*F(i,j)/a
  else if(scalar/='Te'.and.scalar/='Tw') then
   rms(i,j)=aM(3,i,j)*F(i+1,j)+aM(2,i,j)*F(i-1,j)+aM(4,i,j)*F(i,j)+aM(5,i,j)*F(i,j+1)+b(i,j)+(1-a)*aM(1,i,j)*F0(i,j)/a-aM(1,i,j)*F(i,j)/a
  end if
 end DO
end DO
!$OMP END DO
end Subroutine Residual

Subroutine DILU(aM,aD,Ic,Jc,Ib2)
implicit none
integer i,j,Ic,Jc,Ib2
real(8) aM(5,Ic,Jc),aD(Ic,Jc)

!$OMP DO
DO j=1,Jc-1
 DO i=2,Ic-1
  if(j==1) then
   if(i>Ib2) then
    aD(i,j)=aD(i,j)-(aM(2,i,j)*aM(3,i-1,j)/aD(i-1,j)+aM(4,i,j)*aM(4,Ic+1-i,j)/aD(Ic+1-i,j))
   else
    aD(i,j)=aD(i,j)-aM(2,i,j)*aM(3,i-1,j)/aD(i-1,j)
   end if
  else
   aD(i,j)=aD(i,j)-(aM(2,i,j)*aM(3,i-1,j)/aD(i-1,j)+aM(4,i,j)*aM(5,i,j-1)/aD(i,j-1))
  end if
 end DO
end DO
!$OMP END DO
end Subroutine DILU

Subroutine Multmatrixvector(aM,u,v,a,Ic,Jc,Ib1,Ib2,scalar)
implicit none
integer i,j,Ic,Jc,Ib1,Ib2
real(8) a
real(8) aM(5,Ic,Jc),u(Ic,Jc),v(Ic,Jc)
character(*) scalar

!$OMP WORKSHARE
v=u
!$OMP END WORKSHARE
!$OMP DO
DO j=1,Jc-1
  DO i=2,Ic-1
   if(j>1) then
    v(i,j)=aM(1,i,j)*u(i,j)/a-aM(3,i,j)*u(i+1,j)-aM(2,i,j)*u(i-1,j)-aM(4,i,j)*u(i,j-1)-aM(5,i,j)*u(i,j+1)
   else if(j==1.and.(i>Ib2.or.i<Ib1)) then
    v(i,j)=aM(1,i,j)*u(i,j)/a-aM(3,i,j)*u(i+1,j)-aM(2,i,j)*u(i-1,j)-aM(4,i,j)*u(Ic+1-i,j)-aM(5,i,j)*u(i,j+1)
   else if(scalar/='Te'.and.scalar/='Tw') then
    v(i,j)=aM(1,i,j)*u(i,j)/a-aM(3,i,j)*u(i+1,j)-aM(2,i,j)*u(i-1,j)-aM(4,i,j)*u(i,j)-aM(5,i,j)*u(i,j+1)
   end if
  end DO
end DO
!$OMP END DO
end Subroutine Multmatrixvector

Subroutine Sorprecond(aM,aD,b,a,Ic,Jc,Ib1,Ib2,scalar,pretype)
implicit none
integer i,j,Ic,Jc,Ib1,Ib2
character(*) scalar,pretype
real(8) aM(5,Ic,Jc),aD(Ic,Jc),b(Ic,Jc)
real(8) a,omiga

if(pretype=='SSOR'.and.scalar=='dP') then
 omiga=1.5
else
 omiga=1.0
end if

!$OMP WORKSHARE
b(1,:)=omiga*b(1,:)
b(Ic,:)=omiga*b(Ic,:)
b(2:Ic-1,Jc)=omiga*b(2:Ic-1,Jc)
!$OMP END WORKSHARE

!$OMP DO
DO j=1,Jc-1
 DO i=2,Ic-1
  if(j>1) then
   b(i,j)=a*omiga*(b(i,j)+aM(2,i,j)*b(i-1,j)+aM(4,i,j)*b(i,j-1))/aD(i,j)
  else if(j==1.and.i>Ib2) then
   b(i,j)=a*omiga*(b(i,j)+aM(2,i,j)*b(i-1,j)+aM(4,i,j)*b(Ic+1-i,j))/aD(i,j)
  else if(i>=Ib1.and.(scalar=='Te'.or.scalar=='Tw')) then
   b(i,j)=omiga*b(i,j)
  else
   b(i,j)=a*omiga*(b(i,j)+aM(2,i,j)*b(i-1,j))/aD(i,j)
  end if
 end DO
end DO
!$OMP END DO

!$OMP WORKSHARE
b=(2-omiga)*b/omiga
!$OMP END WORKSHARE

!$OMP DO
DO j=1,Jc-1
 DO i=2,Ic-1
  if(.not.(j==1.and.i>=Ib1.and.i<=Ib2.and.(scalar=='Te'.or.scalar=='Tw'))) then
   b(i,j)=aD(i,j)*b(i,j)/a
  end if
 end DO
end DO
!$OMP END DO

!$OMP WORKSHARE
b(1,:)=omiga*b(1,:)
b(Ic,:)=omiga*b(Ic,:)
b(2:Ic-1,Jc)=omiga*b(2:Ic-1,Jc)
!$OMP END WORKSHARE

!$OMP DO
DO j=Jc-1,1,-1
 DO i=Ic-1,2,-1
  if(j==1.and.i<Ib1) then
   b(i,j)=a*omiga*(b(i,j)+aM(3,i,j)*b(i+1,j)+aM(5,i,j)*b(i,j+1)+aM(4,i,j)*b(Ic+1-i,j))/aD(i,j)
  else if(j==1.and.i>=Ib1.and.i<=Ib2.and.(scalar=='Te'.or.scalar=='Tw')) then
   b(i,j)=omiga*b(i,j)
  else
   b(i,j)=a*omiga*(b(i,j)+aM(3,i,j)*b(i+1,j)+aM(5,i,j)*b(i,j+1))/aD(i,j)
  end if
 end DO
end DO
!$OMP END DO
end Subroutine Sorprecond


      SUBROUTINE CLAED0( QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, RWORK,
     $                   IWORK, INFO )
*
*  -- LAPACK routine (instrumented to count operations, version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDQ, LDQS, N, QSIZ
*     ..
*     .. Array Arguments ..
      INTEGER            IWORK( * )
      REAL               D( * ), E( * ), RWORK( * )
      COMPLEX            Q( LDQ, * ), QSTORE( LDQS, * )
*     ..
*     Common block to return operation count and iteration count
*     ITCNT is unchanged, OPS is only incremented
*     .. Common blocks ..
      COMMON             / LATIME / OPS, ITCNT
*     ..
*     .. Scalars in Common ..
      REAL               ITCNT, OPS
*     ..
*
*  Purpose
*  =======
*
*  Using the divide and conquer method, CLAED0 computes all eigenvalues
*  of a symmetric tridiagonal matrix which is one diagonal block of
*  those from reducing a dense or band Hermitian matrix and
*  corresponding eigenvectors of the dense or band matrix.
*
*  Arguments
*  =========
*
*  QSIZ   (input) INTEGER
*         The dimension of the unitary matrix used to reduce
*         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.
*
*  N      (input) INTEGER
*         The dimension of the symmetric tridiagonal matrix.  N >= 0.
*
*  D      (input/output) REAL array, dimension (N)
*         On entry, the diagonal elements of the tridiagonal matrix.
*         On exit, the eigenvalues in ascending order.
*
*  E      (input/output) REAL array, dimension (N-1)
*         On entry, the off-diagonal elements of the tridiagonal matrix.
*         On exit, E has been destroyed.
*
*  Q      (input/output) COMPLEX array, dimension (LDQ,N)
*         On entry, Q must contain an QSIZ x N matrix whose columns
*         unitarily orthonormal. It is a part of the unitary matrix
*         that reduces the full dense Hermitian matrix to a
*         (reducible) symmetric tridiagonal matrix.
*
*  LDQ    (input) INTEGER
*         The leading dimension of the array Q.  LDQ >= max(1,N).
*
*  IWORK  (workspace) INTEGER array,
*         the dimension of IWORK must be at least
*                      6 + 6*N + 5*N*lg N
*                      ( lg( N ) = smallest integer k
*                                  such that 2^k >= N )
*
*  RWORK  (workspace) REAL array,
*                               dimension (1 + 3*N + 2*N*lg N + 3*N**2)
*                        ( lg( N ) = smallest integer k
*                                    such that 2^k >= N )
*
*  QSTORE (workspace) COMPLEX array, dimension (LDQS, N)
*         Used to store parts of
*         the eigenvector matrix when the updating matrix multiplies
*         take place.
*
*  LDQS   (input) INTEGER
*         The leading dimension of the array QSTORE.
*         LDQS >= max(1,N).
*
*  INFO   (output) INTEGER
*          = 0:  successful exit.
*          < 0:  if INFO = -i, the i-th argument had an illegal value.
*          > 0:  The algorithm failed to compute an eigenvalue while
*                working on the submatrix lying in rows and columns
*                INFO/(N+1) through mod(INFO,N+1).
*
*  =====================================================================
*
*  Warning:      N could be as big as QSIZ!
*
*     .. Parameters ..
      REAL               TWO
      PARAMETER          ( TWO = 2.E0 )
*     ..
*     .. Local Scalars ..
      INTEGER            CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM,
     $                   IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM,
     $                   J, K, LGN, LL, MATSIZ, MSD2, SMLSIZ, SMM1,
     $                   SPM1, SPM2, SUBMAT, SUBPBS, TLVLS
      REAL               TEMP
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
*     ..
*     .. External Subroutines ..
      EXTERNAL           CCOPY, CLACRM, CLAED7, SCOPY, SSTEQR, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, INT, LOG, MAX, REAL
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
*
*     IF( ICOMPQ .LT. 0 .OR. ICOMPQ .GT. 2 ) THEN
*        INFO = -1
*     ELSE IF( ( ICOMPQ .EQ. 1 ) .AND. ( QSIZ .LT. MAX( 0, N ) ) )
*    $        THEN
      IF( QSIZ.LT.MAX( 0, N ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDQS.LT.MAX( 1, N ) ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CLAED0', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
      SMLSIZ = ILAENV( 9, 'CLAED0', ' ', 0, 0, 0, 0 )
*
*     Determine the size and placement of the submatrices, and save in
*     the leading elements of IWORK.
*
      IWORK( 1 ) = N
      SUBPBS = 1
      TLVLS = 0
   10 CONTINUE
      IF( IWORK( SUBPBS ).GT.SMLSIZ ) THEN
         DO 20 J = SUBPBS, 1, -1
            IWORK( 2*J ) = ( IWORK( J )+1 ) / 2
            IWORK( 2*J-1 ) = IWORK( J ) / 2
   20    CONTINUE
         TLVLS = TLVLS + 1
         SUBPBS = 2*SUBPBS
         GO TO 10
      END IF
      DO 30 J = 2, SUBPBS
         IWORK( J ) = IWORK( J ) + IWORK( J-1 )
   30 CONTINUE
*
*     Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1
*     using rank-1 modifications (cuts).
*
      SPM1 = SUBPBS - 1
      OPS = OPS + 2*SPM1
      DO 40 I = 1, SPM1
         SUBMAT = IWORK( I ) + 1
         SMM1 = SUBMAT - 1
         D( SMM1 ) = D( SMM1 ) - ABS( E( SMM1 ) )
         D( SUBMAT ) = D( SUBMAT ) - ABS( E( SMM1 ) )
   40 CONTINUE
*
      INDXQ = 4*N + 3
*
*     Set up workspaces for eigenvalues only/accumulate new vectors
*     routine
*
      OPS = OPS + 3
      TEMP = LOG( REAL( N ) ) / LOG( TWO )
      LGN = INT( TEMP )
      IF( 2**LGN.LT.N )
     $   LGN = LGN + 1
      IF( 2**LGN.LT.N )
     $   LGN = LGN + 1
      IPRMPT = INDXQ + N + 1
      IPERM = IPRMPT + N*LGN
      IQPTR = IPERM + N*LGN
      IGIVPT = IQPTR + N + 2
      IGIVCL = IGIVPT + N*LGN
*
      IGIVNM = 1
      IQ = IGIVNM + 2*N*LGN
      IWREM = IQ + N**2 + 1
*     Initialize pointers
      DO 50 I = 0, SUBPBS
         IWORK( IPRMPT+I ) = 1
         IWORK( IGIVPT+I ) = 1
   50 CONTINUE
      IWORK( IQPTR ) = 1
*
*     Solve each submatrix eigenproblem at the bottom of the divide and
*     conquer tree.
*
      CURR = 0
      DO 70 I = 0, SPM1
         IF( I.EQ.0 ) THEN
            SUBMAT = 1
            MATSIZ = IWORK( 1 )
         ELSE
            SUBMAT = IWORK( I ) + 1
            MATSIZ = IWORK( I+1 ) - IWORK( I )
         END IF
         LL = IQ - 1 + IWORK( IQPTR+CURR )
         CALL SSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),
     $                RWORK( LL ), MATSIZ, RWORK, INFO )
         OPS = OPS + 4*REAL( QSIZ )*MATSIZ*MATSIZ
         CALL CLACRM( QSIZ, MATSIZ, Q( 1, SUBMAT ), LDQ, RWORK( LL ),
     $                MATSIZ, QSTORE( 1, SUBMAT ), LDQS,
     $                RWORK( IWREM ) )
         IWORK( IQPTR+CURR+1 ) = IWORK( IQPTR+CURR ) + MATSIZ**2
         CURR = CURR + 1
         IF( INFO.GT.0 ) THEN
            INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1
            RETURN
         END IF
         K = 1
         DO 60 J = SUBMAT, IWORK( I+1 )
            IWORK( INDXQ+J ) = K
            K = K + 1
   60    CONTINUE
   70 CONTINUE
*
*     Successively merge eigensystems of adjacent submatrices
*     into eigensystem for the corresponding larger matrix.
*
*     while ( SUBPBS > 1 )
*
      CURLVL = 1
   80 CONTINUE
      IF( SUBPBS.GT.1 ) THEN
         SPM2 = SUBPBS - 2
         DO 90 I = 0, SPM2, 2
            IF( I.EQ.0 ) THEN
               SUBMAT = 1
               MATSIZ = IWORK( 2 )
               MSD2 = IWORK( 1 )
               CURPRB = 0
            ELSE
               SUBMAT = IWORK( I ) + 1
               MATSIZ = IWORK( I+2 ) - IWORK( I )
               MSD2 = MATSIZ / 2
               CURPRB = CURPRB + 1
            END IF
*
*     Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2)
*     into an eigensystem of size MATSIZ.  CLAED7 handles the case
*     when the eigenvectors of a full or band Hermitian matrix (which
*     was reduced to tridiagonal form) are desired.
*
*     I am free to use Q as a valuable working space until Loop 150.
*
            CALL CLAED7( MATSIZ, MSD2, QSIZ, TLVLS, CURLVL, CURPRB,
     $                   D( SUBMAT ), QSTORE( 1, SUBMAT ), LDQS,
     $                   E( SUBMAT+MSD2-1 ), IWORK( INDXQ+SUBMAT ),
     $                   RWORK( IQ ), IWORK( IQPTR ), IWORK( IPRMPT ),
     $                   IWORK( IPERM ), IWORK( IGIVPT ),
     $                   IWORK( IGIVCL ), RWORK( IGIVNM ),
     $                   Q( 1, SUBMAT ), RWORK( IWREM ),
     $                   IWORK( SUBPBS+1 ), INFO )
            IF( INFO.GT.0 ) THEN
               INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1
               RETURN
            END IF
            IWORK( I / 2+1 ) = IWORK( I+2 )
   90    CONTINUE
         SUBPBS = SUBPBS / 2
         CURLVL = CURLVL + 1
         GO TO 80
      END IF
*
*     end while
*
*     Re-merge the eigenvalues/vectors which were deflated at the final
*     merge step.
*
      DO 100 I = 1, N
         J = IWORK( INDXQ+I )
         RWORK( I ) = D( J )
         CALL CCOPY( QSIZ, QSTORE( 1, J ), 1, Q( 1, I ), 1 )
  100 CONTINUE
      CALL SCOPY( N, RWORK, 1, D, 1 )
*
      RETURN
*
*     End of CLAED0
*
      END


!c	cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!	Based on Huge's book take solid acceleration as the primary variable
!       solve it and then get the displacement for dynamic problems
!	Only linear elastic, I use \alpha - method
!       Visco-linear elastic, I use Newmark method
!c       cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	subroutine blockgmres_solid(xloc,dloc,p, ien,nsd,nen,ne,nn,nquad,wq,sq,&
				x_pre1,solid_prevel,solid_preacc,ien_sbc,ne_sbc,solid_stress,mtype)
!	use fluid_variables, only: nsd,nen,ne,nn,nquad,wq,sq
	use global_constants
	use run_variables, only: dt
	use r_common, only: group_young, Poisson, density_solid
	use fluid_variables, only: den_liq
	use solid_variables, only: damp_solid
	implicit none
!-----------------------------------------------
! xloc --- the initial configuration
! dloc --- solid acceleration at n+1 to be solved
! solid_preacc --- solid acceleration at n
! solid_vel --- solid velocity at n+1
! solid_prevel --- solid velocity at n
! alpha, beta, gamma --- constant parameters definition seen Huge 532

	integer ien(ne,nen)
	real* 8 xloc(nsd,nn), dloc(nsd,nn)
	real* 8 x(nsd,nen), d(nsd,nen), e(nsd,nen)
	real* 8 p(nsd,nn)
	real(8) x_pre1(nsd,nn)
	real(8) solid_prevel(nsd,nn)
	real(8) solid_preacc(nsd,nn)
	integer mtype(ne)
!        real(8) x_pre2(nsd,nn)
	real(8) acc(nsd,nen), acc_pre(nsd,nen)
	real(8) d1(nsd,nen), d2(nsd,nen)
	real(8) vel(nsd,nen), vel_pre(nsd,nen)

!----------------------------------------
	integer nsd
	integer nen
	integer ne
	integer nn
	integer nquad
	real(8) wq(8)
	real(8) sq(0:3,8,8)
!----------------------------------------
	real* 8 eft0,det,eft1
	real* 8 sh(0:nsd,nen),ph(0:nsd,nen)
	real* 8 xr(nsd,nsd), cf(nsd,nsd),sx(nsd,nsd)

	real* 8 drx(nsd),dry(nsd),drz(nsd)
	real* 8 ttt,txx,txy,txz,tyx,tyy,tyz,tzx,tzy,tzz

	real* 8 mu,la
	real* 8 erx,ery,erz,ers

!c....   stiffness matrix
	integer inl, ie, isd, iq, node, jsd
	real(8) ax, ay, az
!-----------------------------------
	real(8) rho_solid	! solid density should be passed from input file
				! same as blockgmres_solid.f90
	real(8) alpha
	real(8) beta
	real(8) gama
!-----------------------------------
	real(8) solid_bcforce(nsd,nn) ! external force acting at the solid boundary
	real(8) solid_stress(nsd*2,nn) ! fluid stress acting on the solid boundary including pressure and viscous stress
	integer ne_sbc			! solid elements on the boundary
	integer ien_sbc(ne_sbc,nen+2)
!------------------------------------
! For viscoelastic model
        real(8) dsdt(nsd,nsd) ! time derivative of strain and then times damping
!------------------------------------

p(:,:) = 0.0d0

!---------------------------------
! define the numerical parameters
alpha = -0.05 ! -1/3 < alpha < 0 and alpha == 0 is Newmark method
gama = (1.0 - 2.0 * alpha) * 0.5
beta = ( (1.0 - alpha)**2 ) * 0.25
!beta = ( 1.0 - alpha**2 ) * 0.25
!----------------------------------

! set solid densitiy
	rho_solid = density_solid + den_liq

!	rho_solid = 0.0
        do ie=1,ne
! change E, \nv to \lammda and \mu (Lame parameters)
        mu = group_young(mtype(ie))/((1+Poisson)*(1-2*Poisson))
        la = group_young(mtype(ie))/(2*(1+Poisson))

	   do inl=1,nen
	      do isd=1,nsd
		 x(isd,inl) = xloc(isd,ien(ie,inl)) ! local initial configuration
		 acc(isd,inl) = dloc(isd,ien(ie,inl)) ! local acc to be solved at n+1
		 acc_pre(isd,inl) = solid_preacc(isd,ien(ie,inl)) ! local acc at n passed in
		 vel_pre(isd,inl) = solid_prevel(isd,ien(ie,inl)) ! local vel at n
		 d1(isd,inl) = x_pre1(isd,ien(ie,inl)) - x(isd,inl) ! displacement at n

!                vel(isd,inl) = solid_vel(isd,ien(ie,inl))        ! local vel at n+1
!                d2(isd,inl) = x_pre2(isd,ien(ie,inl)) - x(isd,inl) ! displacement at n-1

	      enddo
	   enddo
!-------------------------------------------------
! solid displacement at n+1 to be solved
!	d(:,:) = d1(:,:) + dt*vel_pre(:,:) + (dt**2)*0.5*( (1.0-2.0*beta)*acc_pre(:,:) + 2.0*beta*acc(:,:) )
	d(:,:) = (dt**2) * beta * acc(:,:)
! solid velocity at n+1 to be solved
!	vel(:,:) = vel_pre(:,:) + dt*( (1-gama)*acc_pre(:,:) + gama*acc(:,:) )
	vel(:,:) = dt * gama * acc(:,:)
! do weighted average using alpha
!        d(:,:) = (1 + alpha)*d(:,:) - alpha*d1(:,:)
!        vel(:,:) = (1 + alpha)*vel(:,:) - alpha*vel_pre(:,:)
        d(:,:) = (1 + alpha)*d(:,:)
        vel(:,:) = (1 + alpha)*vel(:,:)
! adding damping term to displacement
!        d(:,:) = d(:,:) + damp_solid * vel(:,:)

!-------------------------------------------------
	   do iq=1,nquad
	if (nsd == 3) then ! 3-D case
	      if (nen.eq.4) then
		 include "sh3d4n.h"
	      else if (nen.eq.8) then
		 include "sh3d8n.h"
	      end if
	end if
	if (nsd == 2) then ! 2-D case
	      if (nen.eq.3) then !calculate shape function at quad point
                 include "sh2d3n.h"
              elseif (nen.eq.4) then
                 include "sh2d4n.h"
              endif
	end if
	      eft0 = abs(det) * wq(iq)

!=============================================
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!c        CALCULATE kd-f
!c                  in this problem f=0
!c        ONLY CALCULATE  kd in local coordinates
!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!c.........  initialize variables
	      erx = 0.0
	      ery = 0.0
	      erz = 0.0

	      do isd = 1,nsd
		 drx(isd) = 0.0
		 dry(isd) = 0.0
	if (nsd == 3) then ! To be justified for both  2, 3 - D cases
		 drz(isd) = 0.0
	end if
	      enddo

! Accerlearation at G point
		ax = 0.0
		ay = 0.0
		az = 0.0

	      do inl=1,nen
		 ax = ax + sh(0,inl)*acc(1,inl)*rho_solid
		 ay = ay + sh(0,inl)*acc(2,inl)*rho_solid
	if (nsd == 3) then
		 az = az + sh(0,inl)*acc(3,inl)*rho_solid
	end if
!c............... calculate the first derivative
		 do isd=1,nsd
		    drx(isd)=drx(isd)+sh(1,inl)*d(isd,inl)
		    dry(isd)=dry(isd)+sh(2,inl)*d(isd,inl)
        if (nsd == 3) then ! To be justified for both  2, 3 - D cases
		    drz(isd)=drz(isd)+sh(3,inl)*d(isd,inl)
	end if
		 enddo
	      end do

!--------------------------------------
! calculate damping term for viscoelastic material
                dsdt(:,:) = 0.0
                do inl=1,nen
                        do isd=1,nsd
                                do jsd=1,nsd
                                dsdt(isd,jsd) = dsdt(isd,jsd) + &
                                ( sh(isd,inl)*vel(jsd,inl) + sh(jsd,inl)*vel(isd,inl) ) * 0.5 * damp_solid
                                end do
                        end do
                end do

!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	      do inl=1,nen
		 ph(:,inl) = sh(:,inl)*eft0
!		 ph(1,inl) = sh(1,inl)*eft0
!		 ph(2,inl) = sh(2,inl)*eft0
!		 ph(3,inl) = sh(3,inl)*eft0
	      enddo

!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!c.....Galerkin Terms (Look at notes)
!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	if (nsd == 3) then ! 3-D case
	      ttt = la*(drx(xsd)+dry(ysd)+drz(zsd))
	      txx = mu*(drx(xsd)+drx(xsd))
	      tyx = mu*(dry(xsd)+drx(ysd))
	      tzx = mu*(drz(xsd)+drx(zsd))
	      txy = mu*(drx(ysd)+dry(xsd))
	      tyy = mu*(dry(ysd)+dry(ysd))
	      tzy = mu*(drz(ysd)+dry(zsd))
	      txz = mu*(drx(zsd)+drz(xsd))
	      tyz = mu*(dry(zsd)+drz(ysd))
	      tzz = mu*(drz(zsd)+drz(zsd))
	      do inl=1,nen
		 node=ien(ie,inl)
!c.....Elastic Equation (calculate residual: r=kd=p)
		 p(xsd,node) = p(xsd,node) - &
		      ph(xsd,inl) * ttt - &
		      ph(xsd,inl) * txx - &
		      ph(ysd,inl) * tyx - &
		      ph(zsd,inl) * tzx   &
		     -ph(0,inl) * ax
		 p(ysd,node) = p(ysd,node) - &
		      ph(ysd,inl) * ttt - &
		      ph(xsd,inl) * txy - &
		      ph(ysd,inl) * tyy - &
		      ph(zsd,inl) * tzy   &
		     -ph(0,inl) * ay
		 p(zsd,node) = p(zsd,node) - &
		      ph(zsd,inl) * ttt - &
		      ph(xsd,inl) * txz - &
		      ph(ysd,inl) * tyz - &
		      ph(zsd,inl) * tzz   &
		     -ph(0,inl) * az

	      enddo
	end if

	if (nsd == 2) then ! 2-D case, plain strain model
	   do inl=1,nen
		node=ien(ie,inl)
		p(xsd,node)=p(xsd,node) - &
			ph(xsd,inl)*(la+2*mu)*drx(xsd) - &
			ph(ysd,inl)*mu*dry(xsd) - &
			ph(xsd,inl)*la*dry(ysd) - &
			ph(ysd,inl)*mu*drx(ysd)   &
			-ph(0,inl) * ax

		p(ysd,node)=p(ysd,node) - &
			ph(ysd,inl)*la*drx(xsd) - &
			ph(xsd,inl)*mu*dry(xsd) - &
			ph(ysd,inl)*(la+2*mu)*dry(ysd) - &
			ph(xsd,inl)*mu*drx(ysd)   &
                        -ph(0,inl) * ay

	  end do
	end if

!---------------------------------
! Adding damping term for viscoelastic model
        do inl=1,nen
        node = ien(ie,inl)
        do isd = 1, nsd
                do jsd = 1,nsd
                p(isd,node) = p(isd,node) - ph(jsd,inl) * dsdt(isd,jsd)
                end do
        end do
        end do
!----------------------------------

	   enddo ! Gausian point loop
	enddo ! element loop

!======================================
! Apply 2nd type boundary
!	if (nsd ==  2) then
!	call apply_2ndbc_solid2d(x_pre1,nsd,nn,ien_sbc,ne_sbc,nen,ien,ne,solid_bcforce,solid_stress)
!	p(:,:) = p(:,:) - solid_bcforce(:,:)
!	else
!	call apply_2ndbc_solid(x_pre1,nsd,nn,ien_sbc,ne_sbc,nen,ien,ne,solid_bcforce,solid_stress)
!	p(:,:) = p(:,:) - solid_bcforce(:,:)
!	end if

      return
      end


      SUBROUTINE slPRNU (EPOCH, DATE, RMATPN)
*+
*     - - - - - - -
*      P R N U
*     - - - - - - -
*
*  Form the matrix of precession and nutation (SF2001)
*  (double precision)
*
*  Given:
*     EPOCH   dp         Julian Epoch for mean coordinates
*     DATE    dp         Modified Julian Date (JD-2400000.5)
*                        for true coordinates
*
*  Returned:
*     RMATPN  dp(3,3)    combined precession/nutation matrix
*
*  Called:  slPREC, slEPJ, slNUT, slDMXM
*
*  Notes:
*
*  1)  The epoch and date are TDB (loosely ET).  TT will do, or even
*      UTC.
*
*  2)  The matrix is in the sense   V(true) = RMATPN * V(mean)
*
*  Last revision:   3 December 2005
*
*  Copyright P.T.Wallace.  All rights reserved.
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION EPOCH,DATE,RMATPN(3,3)

      DOUBLE PRECISION RMATP(3,3),RMATN(3,3),slEPJ

*  Precession
      CALL slPREC(EPOCH,slEPJ(DATE),RMATP)

*  Nutation
      CALL slNUT(DATE,RMATN)

*  Combine the matrices:  PN = N x P
      CALL slDMXM(RMATN,RMATP,RMATPN)

      END


      DOUBLE PRECISION FUNCTION ERREV(NN,QR,QI,MS,MP,ARE,MRE)           ERRE3610
C BOUNDS THE ERROR IN EVALUATING THE POLYNOMIAL BY THE HORNER
C RECURRENCE.
C QR,QI - THE PARTIAL SUMS
C MS    -MODULUS OF THE POINT
C MP    -MODULUS OF POLYNOMIAL VALUE
C ARE, MRE -ERROR BOUNDS ON COMPLEX ADDITION AND MULTIPLICATION
      DOUBLE PRECISION QR(NN),QI(NN),MS,MP,ARE,MRE,E,CMOD
      E = CMOD(QR(1),QI(1))*MRE/(ARE+MRE)
      DO 10 I = 1,NN
          E = E*MS+CMOD(QR(I),QI(I))
   10 CONTINUE
      ERREV = E*(ARE+MRE)-MP*MRE
      RETURN
      END


! t1 is a test example based on
!
!   http://www.radford.edu/~thompson/vodef90web/vodef90source/Double/Prologue_Examples/example1.f90
!
! Some notes from example1.f90:
!
!   The problem is from chemical kinetics, and consists of the following
!   three rate equations:
!
!     dy1/dt = -.04d0*y1 + 1.d4*y2*y3
!     dy2/dt = .04d0*y1 - 1.d4*y2*y3 - 3.d7*y2**2
!     dy3/dt = 3.d7*y2**2
!
!   on the interval from t = 0.0d0 to t = 4.d10, with initial
!   conditions y1 = 1.0d0, y2 = y3 = 0.0d0. The problem is stiff.
!
! The original version of this test distributed with BDF solved the same
! problem, except:
!   * we'll evolve two solutions / initial conditions at the same time
!   * the Jacobian will be computed using the first solution only
!
! This version has been adapted for developing and testing OpenACC acceleration
! of VBDF for use in Maestro's nuclear reaction integration.  We solve the
! problem as in example1.f90 but do so for a vector of hydro cell data.  This
! mimics what we would do in Maestro, where loops over hydro cells are common.

!module feval
!  !use bdf
!  use bl_types
!  implicit none
!  integer, parameter :: neq = 3
!  integer, parameter :: npt = 1
!contains
!  subroutine f_rhs_vec(neq, npt, y, t, ydot, upar)
!    !$acc routine seq
!    integer,  intent(in   ) :: neq, npt
!    real(dp_t), intent(in   ) :: y(neq,npt), t
!    real(dp_t), intent(  out) :: ydot(neq,npt)
!    real(dp_t), intent(inout), optional :: upar(:,:)
!
!    !For the purposes of t1, npt=1
!    ydot(1,1) = -.04d0*y(1,1) + 1.d4*y(2,1)*y(3,1)
!    ydot(3,1) = 3.e7*y(2,1)*y(2,1)
!    ydot(2,1) = -ydot(1,1) - ydot(3,1)
!  end subroutine f
!
!  subroutine jac_vec(neq, npt, y, t, pd, upar)
!    !$acc routine seq
!    integer,  intent(in   ) :: neq, npt
!    real(dp_t), intent(in   ) :: y(neq,npt), t
!    real(dp_t), intent(  out) :: pd(neq,neq,npt)
!    real(dp_t), intent(inout), optional :: upar(:,:)
!
!    !For the purposes of t1, npt=1
!    pd(1,1,1) = -.04d0
!    pd(1,2,1) = 1.d4*y(3,1)
!    pd(1,3,1) = 1.d4*y(2,1)
!    pd(2,1,1) = .04d0
!    pd(2,3,1) = -pd(1,3,1)
!    pd(3,2,1) = 6.e7*y(2,1)
!    pd(2,2,1) = -pd(1,2,1) - pd(3,2,1)
!  end subroutine J
!end module feval

program test
   use bdf
   use bl_types
   implicit none

   integer, parameter :: NEQ = 3
   integer, parameter :: NPT = 1
   integer, parameter :: NCELLS = 64 !32**3 = 32768 is a common grid size in
                                     !Maestro problems
   integer, parameter :: MAX_ORDER = 3
   type(bdf_ts)  :: ts(NCELLS)
   real(dp_t) :: rtol(NEQ), atol(NEQ), dt
   real(dp_t) :: y0(NEQ,NPT), t0, y1(NEQ,NPT), t1, state(NCELLS,NEQ)
   real(dp_t), allocatable :: upar(:,:)

   integer :: i, ierr, navg

   !Build ncells of state data and timestepper objects,
   !create a device version of the ts array
   allocate(upar(1, NPT))
   !$acc enter data create(ts)
   do i = 1, NCELLS
      state(i,:) = [ 1.d0, 0.d0, 0.d0 ]
      rtol = 1.d-4
      atol = [ 1.d-8, 1.d-14, 1.d-6 ]
      call bdf_ts_build(ts(i), NEQ, NPT, rtol, atol, MAX_ORDER, upar)
      ts(i)%temp_data = ts(i)%A(0,0)

      !Now that we've built the ts(i) object on the host, we need to update the
      !device.  For now, this means updating each member that is not allocatable
      !or a pointer.  Were we to do something like
      !   acc update device(ts(i))
      !my understanding is that this would overwrite the device's pointer
      !address with the host's.  By updating each individual member, we instead
      !copy host data into the corresponding device memory.
      !$acc update device(       &
      !$acc    ts(i)%neq,        &
      !$acc    ts(i)%npt,        &
      !$acc    ts(i)%max_order,  &
      !$acc    ts(i)%max_steps,  &
      !$acc    ts(i)%max_iters,  &
      !$acc    ts(i)%verbose,    &
      !$acc    ts(i)%dt_min,     &
      !$acc    ts(i)%eta_min,    &
      !$acc    ts(i)%eta_max,    &
      !$acc    ts(i)%eta_thresh, &
      !$acc    ts(i)%max_j_age,  &
      !$acc    ts(i)%max_p_age,  &
      !$acc    ts(i)%debug,      &
      !$acc    ts(i)%dump_unit,  &
      !$acc    ts(i)%t,          &
      !$acc    ts(i)%t1,         &
      !$acc    ts(i)%dt,         &
      !$acc    ts(i)%dt_nwt,     &
      !$acc    ts(i)%k,          &
      !$acc    ts(i)%n,          &
      !$acc    ts(i)%j_age,      &
      !$acc    ts(i)%p_age,      &
      !$acc    ts(i)%k_age,      &
      !$acc    ts(i)%tq,         &
      !$acc    ts(i)%tq2save,    &
      !$acc    ts(i)%temp_data,  &
      !$acc    ts(i)%refactor,   &
      !$acc    ts(i)%nfe,        &
      !$acc    ts(i)%nje,        &
      !$acc    ts(i)%nlu,        &
      !$acc    ts(i)%nit,        &
      !$acc    ts(i)%nse,        &
      !$acc    ts(i)%ncse,       &
      !$acc    ts(i)%ncit,       &
      !$acc    ts(i)%ncdtmin)

      !For the dynamic data, we have to copy it in.  This will create each of
      !these allocatables on the device, attach them to the appropriate user
      !type, and copy the host data onto the device.
      !$acc enter data copyin(   &
      !$acc    ts(i)%rtol,       &
      !$acc    ts(i)%atol,       &
      !$acc    ts(i)%J,          &
      !$acc    ts(i)%P,          &
      !$acc    ts(i)%z(:,:,0:),  &
      !$acc    ts(i)%z0(:,:,0:), &
      !$acc    ts(i)%h(0:),      &
      !$acc    ts(i)%l(0:),      &
      !$acc    ts(i)%shift(0:),  &
      !$acc    ts(i)%upar,       &
      !$acc    ts(i)%y,          &
      !$acc    ts(i)%yd,         &
      !$acc    ts(i)%rhs,        &
      !$acc    ts(i)%e,          &
      !$acc    ts(i)%e1,         &
      !$acc    ts(i)%ewt,        &
      !$acc    ts(i)%b,          &
      !$acc    ts(i)%ipvt,       &
      !$acc    ts(i)%A(0:,0:))
   enddo
   !$acc enter data copyin(state(:,:))

   t0 = 0.d0
   t1 = 0.4d0
   dt = 1.d-8
   navg=0
   print *, 'state in: ', state(1,:)
   print *, 'A in:     ', ts(1)%A(0,0)

   !Have the GPU loop over state data, with the intention of having each
   !CUDA core execute the acc seq routine bdf_advance on a cell of hydro data

   !$acc parallel loop gang vector reduction(+:navg) private(y0,y1,ierr) &
   !$acc    present(ts, state)
   do i = 1, NCELLS
      !print *, 't, y1(1), y1(2), y1(3), ierr, message'
      !print *, t1, y1(:,1), ierr, errors(ierr)

      !ts(i)%temp_data = ts(i)%rtol(1)
      ts(i)%temp_data = -3.5
      y0(:,NPT) = state(i,:)

      call bdf_advance(ts(i), NEQ, NPT, y0, t0, y1, t1, dt, &
         .true., .false., ierr, .true.)

      state(i,:) = y1(:,NPT)

      navg = navg + ts(i)%n
      !print *, 'td: ', ts%temp_data
      !if (ierr /= BDF_ERR_SUCCESS) exit
   end do

   !Clean up ncells of state data and timestepper objects
   !$acc exit data copyout(state(:,:))
   !TODO: You will have to explicitly update all data members you want on host
   !$acc update host(ts(1)%temp_data)
   print *, 'state out 1: ', state(1,:)
   print *, 'state out 2: ', state(2,:)
   print *, 'temp data 1: ', ts(1)%temp_data
   print *, 'temp data 2: ', ts(2)%temp_data
   do i=1, NCELLS
      !$acc exit data delete(     &
      !$acc    ts(i)%rtol(:),     &
      !$acc    ts(i)%atol(:),     &
      !$acc    ts(i)%J(:,:,:),    &
      !$acc    ts(i)%P(:,:,:),    &
      !$acc    ts(i)%z(:,:,:),    &
      !$acc    ts(i)%z0(:,:,:),   &
      !$acc    ts(i)%h(:),        &
      !$acc    ts(i)%l(:),        &
      !$acc    ts(i)%shift(:),    &
      !$acc    ts(i)%upar(:,:),   &
      !$acc    ts(i)%y(:,:),      &
      !$acc    ts(i)%yd(:,:),     &
      !$acc    ts(i)%rhs(:,:),    &
      !$acc    ts(i)%e(:,:),      &
      !$acc    ts(i)%e1(:,:),     &
      !$acc    ts(i)%ewt(:,:),    &
      !$acc    ts(i)%b(:,:),      &
      !$acc    ts(i)%ipvt(:,:),   &
      !$acc    ts(i)%A(:,:))
      call bdf_ts_destroy(ts(i))
   end do
   deallocate(upar)

   !WARNING! Do *not* do copyout on ts(:), it'll break
   !$acc exit data delete(ts(:))

   !TODO: Either rewrite to get this info for each cell, or delete
   !print *, ''
   !print *, 'max stats for last interval'
   !navg = navg / NCELLS
   print *, 'total number of steps taken, NCELLS: ', navg, NCELLS
   !print *, 'number of function evals   ', ts%nfe
   !print *, 'number of jacobian evals   ', ts%nje
   !print *, 'number of lu decomps       ', ts%nlu
   !print *, 'number of solver iterations', ts%nit
   !print *, 'number of solver errors    ', ts%nse

end program test


!bloss#include <misc.h>
!bloss#include <params.h>
subroutine trcplk(lchnk   ,ncol    ,                            &
                  tint    ,tlayr   ,tplnke  ,emplnk  ,abplnk1 , &
                  abplnk2 )
!-----------------------------------------------------------------------
!
! Purpose:
!   Calculate Planck factors for absorptivity and emissivity of
!   CH4, N2O, CFC11 and CFC12
!
! Method:
!   Planck function and derivative evaluated at the band center.
!
! Author: J. Kiehl
!
!-----------------------------------------------------------------------
   use shr_kind_mod, only: r4 => shr_kind_r4
   use ppgrid

   implicit none
!------------------------------Arguments--------------------------------
!bloss#include <crdcon.h>
!
! Input arguments
!
   integer, intent(in) :: lchnk                ! chunk identifier
   integer, intent(in) :: ncol                 ! number of atmospheric columns

   real(r4), intent(in) :: tint(pcols,pverp)   ! interface temperatures
   real(r4), intent(in) :: tlayr(pcols,pverp)  ! k-1 level temperatures
   real(r4), intent(in) :: tplnke(pcols)       ! Top Layer temperature
!
! output arguments
!
   real(r4), intent(out) :: emplnk(14,pcols)         ! emissivity Planck factor
   real(r4), intent(out) :: abplnk1(14,pcols,pverp)  ! non-nearest layer Plack factor
   real(r4), intent(out) :: abplnk2(14,pcols,pverp)  ! nearest layer factor

!
!--------------------------Local Variables------------------------------
!
   integer wvl                   ! wavelength index
   integer i,k                   ! loop counters
!
   real(r4) f1(14)                   ! Planck function factor
   real(r4) f2(14)                   !        "
   real(r4) f3(14)                   !        "
!
!--------------------------Data Statements------------------------------
!
   data f1 /5.85713e8,7.94950e8,1.47009e9,1.40031e9,1.34853e8, &
            1.05158e9,3.35370e8,3.99601e8,5.35994e8,8.42955e8, &
            4.63682e8,5.18944e8,8.83202e8,1.03279e9/
   data f2 /2.02493e11,3.04286e11,6.90698e11,6.47333e11, &
            2.85744e10,4.41862e11,9.62780e10,1.21618e11, &
            1.79905e11,3.29029e11,1.48294e11,1.72315e11, &
            3.50140e11,4.31364e11/
   data f3 /1383.0,1531.0,1879.0,1849.0,848.0,1681.0, &
            1148.0,1217.0,1343.0,1561.0,1279.0,1328.0, &
            1586.0,1671.0/
!
!-----------------------------------------------------------------------
!
! Calculate emissivity Planck factor
!
   do wvl = 1,14
      do i = 1,ncol
         emplnk(wvl,i) = f1(wvl)/(tplnke(i)**4.0*(exp(f3(wvl)/tplnke(i))-1.0))
      end do
   end do
!
! Calculate absorptivity Planck factor for tint and tlayr temperatures
!
   do wvl = 1,14
      do k = ntoplw, pverp
         do i = 1, ncol
!
! non-nearlest layer function
!
            abplnk1(wvl,i,k) = (f2(wvl)*exp(f3(wvl)/tint(i,k)))  &
                               /(tint(i,k)**5.0*(exp(f3(wvl)/tint(i,k))-1.0)**2.0)
!
! nearest layer function
!
            abplnk2(wvl,i,k) = (f2(wvl)*exp(f3(wvl)/tlayr(i,k))) &
                               /(tlayr(i,k)**5.0*(exp(f3(wvl)/tlayr(i,k))-1.0)**2.0)
         end do
      end do
   end do
!
   return
end subroutine trcplk


C     LAST UPDATE 29/03/96
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE RECTOFF(RD,ZSIG,U,V,NP)
      IMPLICIT NONE
C
C Purpose: Transforms from (D,SIGMA) or (R,Z) space to (U,V) film space.
C
C Calls   0:
C Called by: ARRFIL
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C
C Common scalars:
C
      REAL DIST,XC,YC,ROTX,ROTY,ROTZ,TILT,WAVE,XYRAT
      LOGICAL DODSIG,NSTDEV,OTINP,INTERP
C
C Array Arguments:
C
      REAL U(4),V(4)
C
C Scalar Arguments:
C
      REAL RD,ZSIG
      INTEGER NP
C
C Local Scalars:
C
      REAL TEMP,SCHI,CCHI,CMU,RMU,D,Z,CTILT,STILT,SRX,CRX,SRY,CRY,DMU,
     &     CDMU,SDMU,D1,D2,D3
      INTEGER I,J
C
C Intrinsic Functions:
C
      INTRINSIC SIN,COS,ACOS,SQRT
C
C Common blocks:
C
      COMMON /TRANSF/ DIST,XC,YC,ROTX,ROTY,ROTZ,TILT,WAVE,XYRAT
      COMMON /LOGICS/ DODSIG,NSTDEV,OTINP,INTERP
C
C-----------------------------------------------------------------------
C
C========Need D and Z to calculate RMU and CHI
C
      IF(DODSIG)THEN
         D = RD
         Z = RD*COS(ZSIG)
      ELSE
         D = SQRT(RD*RD+ZSIG*ZSIG)
         Z = ZSIG
      ENDIF
C
C========Initialize U,V, 1-cos(2theta) and sines and cosines
C
      DO 5 I=1,4
         U(I) = 0.0
         V(I) = 0.0
 5    CONTINUE
      TEMP = WAVE*WAVE*D*D/2.0
      STILT = SIN(TILT)
      CTILT = COS(TILT)
      SRX = SIN(ROTX)
      CRX = COS(ROTX)
      SRY = SIN(ROTY)
      CRY = COS(ROTY)
      NP = 0
C
C========Look above and below equator
C
      DO 20 I=1,2
         SCHI = (WAVE*Z-STILT*TEMP)/CTILT
         IF(ABS(SCHI).LT.1.0)THEN
            CCHI = SQRT(1.0-SCHI*SCHI)
            CMU = (1.0-TEMP)/CCHI
            IF(ABS(CMU).LT.1.0)THEN
               RMU = ACOS(CMU)
C
C========Look Left and right of meridian
C
               DO 10 J=1,2
                  NP = NP + 1
C
C========Modify RMU angle of diffracted beam for Z rotation of detector
C
                  DMU = RMU - ROTZ
                  CDMU = COS(DMU)
                  SDMU = SIN(DMU)
C
C========Calculate unit vector from sample to detector in detector
C========coordinate system by rotation of unit vector along X axis
C========in laboratory coordinate system
C
                  D1 =  CRY*CDMU*CCHI + SRY*SCHI
                  D2 = -CRX*SDMU*CCHI + SRX*SRY*CDMU*CCHI - SRX*CRY*SCHI
                  D3 = -SRX*SDMU*CCHI - CRX*SRY*CDMU*CCHI + CRX*CRY*SCHI
C
C========Scale up Y and Z components to give detector U and V
C
                  U(2*(I-1)+J) = DIST*D2/D1
                  V(2*(I-1)+J) = DIST*D3/D1
                  RMU = -RMU
 10            CONTINUE
            ENDIF
         ENDIF
         Z = -Z
 20   CONTINUE
C
      RETURN
      END


      COMPLEX*16 FUNCTION javsubT0(Qs,Ts,mbt2,mtp2,mv2)
*------------------------------------------------------
      IMPLICIT NONE!
      REAL*8 Qs,Ts
      REAL*8 rmtp2,rmbt2,rmv2,zet2,eps,P,slamb2,x12,x22
      COMPLEX*16 mtp2,mbt2,mv2,C0,C02
      COMPLEX*16 YR,YP,YM,ieps,XSPENZ
      PARAMETER (zet2=1.6449340668482264364724151666460251D0)
      PARAMETER (eps=1D-30)
*
      rmtp2=DREAL(mtp2)
      rmbt2=DREAL(mbt2)
      rmv2 =DREAL(mv2)
      P=Qs+rmv2
      ieps=DCMPLX(0d0,eps)
      YR= (Qs+rmv2)/(Qs+rmtp2)
      YP= SQRT(ieps)
      YM=-SQRT(ieps)
*
      javsubT0=
     & -1d0/Ts*(
     & +DLOG(rmtp2*(-Qs)/(rmtp2+Qs)**2)*CDLOG((rmtp2-mv2)/(-Qs-mv2))
     &-CDLOG(rmtp2/(Ts-ieps)*(Ts/(rmtp2-rmv2)+1))*CDLOG(rmtp2/(Ts-ieps))
     & +CDLOG(rmtp2*(-P/rmtp2/(Ts-eps)-ieps))*CDLOG(rmtp2/(Ts-ieps))
     & -DLOG((rmtp2-rmv2)/rmtp2)*CDLOG(rmtp2/(Ts-ieps))
     & -1d0/2*CDLOG(-(Ts-ieps)/rmtp2)**2
     & +1d0/2*CDLOG(-(Ts-ieps)/rmtp2/(Ts/(rmtp2-rmv2)+1))**2
     & -(CDLOG(ieps/Ts-1d0-ieps/(rmtp2-rmv2))
     &  +CDLOG(ieps/Ts-rmv2/rmtp2+ieps/(rmtp2-rmv2))
     &  -CDLOG(P/rmtp2-ieps))*CDLOG((-Qs)/(Ts-ieps))
     & +CDLOG((P-ieps)/rmv2)*CDLOG((Qs-ieps)/(-Qs))
     & -1d0/2*CDLOG(rmv2/(Qs+rmv2-ieps))**2
     & -XSPENZ(rmv2/(Qs+rmv2-ieps))
     & +XSPENZ(1d0/(Ts-ieps)/(1/(rmtp2-rmv2)+1/Ts))
     & -XSPENZ(1d0/(rmv2/rmtp2-ieps/(rmtp2-rmv2)+ieps/Ts))
     & -XSPENZ(1d0/((rmtp2-rmv2)/rmtp2-ieps*(1/Ts-1/(rmtp2-rmv2))))
     &         )
*
     & +1d0/(rmtp2+Qs)*(
     &(-1d0/2*CDLOG(-1d0/((P-ieps)/(rmtp2-rmv2)))
     & -DLOG((-Qs)/(rmtp2+Qs)) )*CDLOG((-rmtp2+rmv2)/(P-ieps))
     & -CDLOG(-(1+Qs/rmtp2+ieps/(rmtp2-rmv2)))
     &               *DLOG(DABS((1+Qs/rmtp2)/(Qs/rmtp2)))
     & -CDLOG(-((rmv2+Qs)/rmtp2-ieps/(rmtp2-rmv2)))
     &               *DLOG(DABS((1+Qs/rmtp2)/(Qs/rmtp2)))
     & +CDLOG((P-ieps)/rmtp2*(1+Qs/rmtp2)-ieps)
     &               *DLOG(DABS((1+Qs/rmtp2)/(Qs/rmtp2)))
     & +XSPENZ((1+Qs/rmtp2)/(1+Qs/rmtp2+ieps/(rmtp2-rmv2)))
     & -XSPENZ((Qs/rmtp2)/(1+Qs/rmtp2+ieps/(rmtp2-rmv2)))
     & +XSPENZ((1+Qs/rmtp2)/((rmv2+Qs)/rmtp2-ieps/(rmtp2-rmv2)))
     & -XSPENZ((Qs/rmtp2)/((rmv2+Qs)/rmtp2-ieps/(rmtp2-rmv2)))
     & +XSPENZ(Qs/rmtp2/((1+Qs/rmtp2)-ieps))
     & -XSPENZ(DCMPLX(-1d0/((rmtp2+Qs)/(rmtp2-rmv2)-1),0d0))
     & +XSPENZ(1d0/((rmtp2-rmv2)/rmtp2+ieps/(rmtp2-rmv2)))
     &                 )
*
     & -(1d0/(rmtp2+Qs)+1d0/Ts)*(
     &+1d0/2*CDLOG((-rmtp2+mv2)/rmv2)
     &  *( CDLOG((-Qs-mv2)/rmv2)+2d0*CDLOG(-rmtp2/Qs*((Qs+mv2)/rmv2)**2)
     &    -CDLOG(-(-rmtp2+mv2)**2/rmv2**2))
     &-1d0/2*CDLOG((Qs+mv2)/rmv2)
     &     *(-CDLOG(-(Qs+mv2)*rmv2*rmv2/(Qs+rmv2)**3)
     &       +DLOG((+rmtp2-rmv2)/rmv2))
     &   -XSPENZ((Qs+mv2)/rmv2)
     &   +2d0*zet2
     &   +XSPENZ((-rmtp2+mv2)/rmv2)
     &   -XSPENZ((rmv2-rmtp2)/(Qs+rmtp2)/(YR-YP))
     &   -XSPENZ((rmv2-rmtp2)/(Qs+rmtp2)/(YR-YM))
     &                          )
*
      RETURN
      END


module params

use grid, only: nzm

implicit none

!   Constants:

real, parameter :: cp = 1004.             ! Specific heat of air, J/kg/K
real, parameter :: ggr = 9.81             ! Gravity acceleration, m/s2
real, parameter :: lcond = 2.5104e+06     ! Latent heat of condensation, J/kg
real, parameter :: lfus = 0.3336e+06      ! Latent heat of fusion, J/kg
real, parameter :: lsub = 2.8440e+06      ! Latent heat of sublimation, J/kg
real, parameter :: rv = 461.              ! Gas constant for water vapor, J/kg/K
real, parameter :: rgas = 287.            ! Gas constant for dry air, J/kg/K
real, parameter :: diffelq = 2.21e-05     ! Diffusivity of water vapor, m2/s
real, parameter :: therco = 2.40e-02      ! Thermal conductivity of air, J/m/s/K
real, parameter :: muelq = 1.717e-05      ! Dynamic viscosity of air

real, parameter :: fac_cond = lcond/cp
real, parameter :: fac_fus = lfus/cp
real, parameter :: fac_sub = lsub/cp

real, parameter ::  pi = 3.141592653589793

!
! internally set parameters:

real   epsv     ! = (1-eps)/eps, where eps= Rv/Ra, or =0. if dosmoke=.true.
logical:: dosubsidence = .false.
real fcorz      ! Vertical Coriolis parameter
real coszrs
real salt_factor ! correction factor for water vapor saturation over sea-water

!bloss: options to allow a larger number of substeps and to keep a margin of safety away from the CFL limit
integer:: ncycle_max = 4  ! maximum number of subcycling within dt
integer:: ncycle_min = 1  ! minimum number of subcycling within dt
integer:: ncycle0 = 1     ! number of subcycles for first timestep of simulation.
real :: cfl_safety_factor = 1.5  ! ensure that CFL < CFL_stability_limit / cfl_safety_factor

!----------------------------------------------
! Parameters set by PARAMETERS namelist:
! Initialized to default values.
!----------------------------------------------

real:: ug = 0.        ! Velocity of the Domain's drift in x direction
real:: vg	= 0.        ! Velocity of the Domain's drift in y direction
real:: fcor = -999.   ! Coriolis parameter
real:: longitude0 = 0.    ! latitude of the domain's center
real:: latitude0  = 0.    ! longitude of the domain's center
real:: nxco2 = 1.         ! factor to modify co2 concentration
logical:: doradlat = .false.
logical:: doradlon = .false.

real(8):: tabs_s =0.	! surface temperature,K
real:: delta_sst = 0.   ! amplitude of sin-pattern of sst about tabs_s (ocean_type=1)
real:: depth_slab_ocean = 2. ! thickness of the slab-ocean (m)
real:: Szero = 0.  ! mean ocean transport (W/m2)
real:: deltaS = 0. ! amplitude of linear variation of ocean transport (W/m2)
real:: timesimpleocean = 0. ! time to start simple ocean

real::   fluxt0 =0.  ! surface sensible flux, Km/s
real::   fluxq0 =0.  ! surface latent flux, m/s
real::   tau0   =0.  ! surface stress, m2/s2
real::   z0     =0.035	! roughness length
real::   soil_wetness =1.! wetness coeff for soil (from 0 to 1.)
integer:: ocean_type =0 ! type of SST forcing
logical:: cem =.false.    ! flag for Cloud Ensemble Model
logical:: les =.false.    ! flag for Large-Eddy Simulation
logical:: ocean =.false.  ! flag indicating that surface is water
real :: min_anisotropy = 16.0
logical:: land =.false.   ! flag indicating that surface is land
logical:: sfc_flx_fxd =.false. ! surface sensible flux is fixed
logical:: sfc_tau_fxd =.false.! surface drag is fixed

real:: timelargescale =0. ! time to start large-scale forcing

! nudging boundaries (between z1 and z2, where z2 > z1):
real:: nudging_uv_z1 =-1., nudging_uv_z2 = 1000000.
real:: nudging_t_z1 =-1., nudging_t_z2 = 1000000.
real:: nudging_q_z1 =-1., nudging_q_z2 = 1000000.
real:: tauls = 99999999.    ! nudging-to-large-scaler-profile time-scale
real:: tautqls = 99999999.! nudging-to-large-scaler-profile time-scale for scalars

logical:: dodamping = .false.
logical:: doupperbound = .false.
logical:: docloud = .false.
logical:: doprecip = .false.
logical:: dolongwave = .false.
logical:: doshortwave = .false.
logical:: doheldsuarez = .false.
logical:: dosgs = .false.
logical:: docoriolis = .false.
logical:: docoriolisz = .false.
logical:: dofplane = .true.
logical:: dosurface = .false.
logical:: dolargescale = .false.
logical:: doradforcing = .false.
logical:: dosfcforcing = .false.
logical:: doradsimple = .false.
logical:: donudging_uv = .false.
logical:: donudging_tq = .false.
logical:: donudging_t = .false.
logical:: donudging_q = .false.
logical:: doensemble = .false.
logical:: dowallx = .false.
logical:: dowally = .false.
logical:: docolumn = .false.
logical:: docup = .false.
logical:: doperpetual = .false.
logical:: doseasons = .false.
logical:: doequinox = .false.  ! Noah added
logical:: dopython = .false. ! added by NDB
logical:: usepython = .false. ! added by NDB
! Controls whether to use the SGS scheme for the thermodynamic variables
! turn off if using explicit parametrizations of surface processes
logical:: dosgsthermo = .true. ! NDB
integer:: npython = 1 ! added by NDB
logical:: doradhomo = .false.
logical:: dosfchomo = .false.
logical:: dossthomo = .false.
logical:: dodynamicocean = .false.
logical:: dosolarconstant = .false.
logical:: dotracers = .false.
logical:: dosmoke = .false.
logical:: notracegases = .false.
logical:: doseawater = .true. !bloss(Set UW default to true!!) .false.
real :: khyp = 1.0e16 ! noah: hyper diffusion coefficient for coarse resolution

! Specify solar constant and zenith angle for perpetual insolation.
! Based onn Tompkins and Graig (1998)
! Note that if doperpetual=.true. and dosolarconstant=.false.
! the insolation will be set to the daily-averaged value on day0.
real:: solar_constant = 685. ! solar constant (in W/m2)
real:: zenith_angle = 51.7   ! zenith angle (in degrees)

integer:: nensemble =0   ! the number of subensemble set of perturbations
integer:: perturb_type  = 0 ! type of initial noise in setperturb()

! Initial bubble parameters. Activated when perturb_type = 2
  real:: bubble_x0 = 0.
  real:: bubble_y0 = 0.
  real:: bubble_z0 = 0.
  real:: bubble_radius_hor = 0.
  real:: bubble_radius_ver = 0.
  real:: bubble_dtemp = 0.
  real:: bubble_dq = 0.

! Option for simple treatment of aerosol radiative effect in RRTMG by Tak Yamaguchi
logical:: doradaerosimple = .false.

! Option for writing restart file only at end of simulation
logical:: dorestart_last_only = .false.

end module params


      double complex function na2q3g_mmmpp(j2,j3,j4,j5,j1,zb,za)
c--- Caclculation of the amplitudes using results of S. Badger
c--- as adapted from routines written by F. Caola
C Arguments in call are strange because this
C has been created from A0Hqbqggg_mp_ppm
      include 'constants.f'
      include 'zprods_decl.f'
      include 'sprods_com.f'
      integer j1,j2,j3,j4,j5
      double precision qsq,s3,s4,
     & sH1,sH3,sH4,s345,s234,s123,s125,s145
      double complex zab_2_pH1_5,zab_2_pH5_1,zab_2_15_4,zab_4_pH5_1,
     & zab_4_23_1,zab_5_pH_1,zab_5_pH_4,zab_5_12_3,
     & zbb_1_pH_45_3,zbb_1_pH_23_1,zbb_1_45_pH_3,
     & zbb_1_23_pH_4,zbb_3_pH_45_1,zbb_3_pH_15_4,zbb_3_pH12_pH_1,
     & zab2,zab3

c--- begin statement functions
      zab2(j1,j2,j3,j4)=za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4)
      zab3(j1,j2,j3,j4,j5)=
     & za(j1,j2)*zb(j2,j5)+za(j1,j3)*zb(j3,j5)+za(j1,j4)*zb(j4,j5)

      s3(j1,j2,j3)=s(j1,j2)+s(j1,j3)+s(j2,j3)
      s4(j1,j2,j3,j4)=s(j1,j2)+s(j1,j3)+s(j1,j4)
     &               +s(j2,j3)+s(j2,j4)+s(j3,j4)
c--- end statement functions

      qsq=
     & +s(j1,j2)+s(j1,j3)+s(j1,j4)+s(j1,j5)
     &          +s(j2,j3)+s(j2,j4)+s(j2,j5)
     &                   +s(j3,j4)+s(j3,j5)
     &                            +s(j4,j5)

      sH1 = s4(j2,j3,j4,j5)
      sH3 = s4(j1,j2,j4,j5)
      sH4 = s4(j1,j2,j3,j5)
      s345 = s3(j3,j4,j5)
      s234 = s3(j2,j3,j4)
      s123 = s3(j1,j2,j3)
      s125 = s3(j1,j2,j5)
      s145 = s3(j1,j4,j5)

      zab_2_pH1_5 = -zab2(j2,j3,j4,j5)
      zab_2_pH5_1 = -zab2(j2,j3,j4,j1)
      zab_4_pH5_1 = -zab2(j4,j2,j3,j1)
      zab_2_15_4 = zab2(j2,j1,j5,j4)
      zab_5_pH_1 = -zab3(j5,j2,j3,j4,j1)
      zab_5_pH_4 = -zab3(j5,j1,j2,j3,j4)
      zab_4_23_1 = zab2(j4,j2,j3,j1)
      zab_5_12_3 = zab2(j5,j1,j2,j3)

      zbb_1_pH_45_3=-zb(j1,j3)*s345-zb(j1,j2)*zab2(j2,j4,j5,j3)
      zbb_1_pH_23_1=
     & zb(j4,j1)*zab2(j4,j2,j3,j1)+zb(j5,j1)*zab2(j5,j2,j3,j1)
      zbb_1_45_pH_3=-zb(j1,j3)*s145-zb(j2,j3)*zab2(j2,j4,j5,j1)
      zbb_1_23_pH_4=-zb(j1,j4)*s123-zb(j5,j4)*zab2(j5,j2,j3,j1)
      zbb_3_pH_45_1=-zbb_1_45_pH_3
      zbb_3_pH_15_4=-zb(j3,j4)*s145-zb(j3,j2)*zab2(j2,j1,j5,j4)
      zbb_3_pH12_pH_1=zbb_1_pH_45_3

      na2q3g_mmmpp=
     & -za(j1,j5)**2*za(j2,j5)/(za(j1,j2)*za(j2,j3)*za(j3,j4)*za(j4,j5))
     & -za(j1,j5)**2*za(j2,j5)*zb(j4,j3)**3
     & /(s125*za(j1,j2)*zab_2_15_4*zab_5_12_3)
     & -s234**2*zab_2_pH5_1
     & /(za(j2,j3)*za(j3,j4)*zab_2_pH1_5*zab_4_pH5_1*zb(j5,j1))
     & +zab_5_pH_1**3*zb(j3,j1)*zb(j3,j2)**2
     & /(za(j4,j5)*zab_4_23_1*zb(j2,j1)*zbb_1_pH_45_3*zbb_1_pH_23_1)
     & -zab_5_pH_4**3*zb(j3,j1)*zb(j3,j2)**2
     & /(sH4*s123*zab_5_12_3*zb(j2,j1)*zbb_1_23_pH_4)
     & -qsq**2*zb(j3,j1)*zb(j3,j2)**2*zb(j4,j1)**4
     & /(zb(j2,j1)*zb(j5,j1)*zb(j5,j4)*zbb_1_pH_23_1*zbb_1_45_pH_3
     & *zbb_1_23_pH_4)
     & +zb(j4,j1)*zbb_3_pH_15_4**3
     & /(sH3*s145*zab_2_15_4*zb(j5,j1)*zb(j5,j4)*zbb_3_pH_45_1)
     & +sH1**2*zb(j4,j3)**3
     & /(s345*zab_2_pH1_5*zb(j5,j4)*zbb_3_pH12_pH_1)

      return
      end


module constants

use parameters

implicit none

!Universal constants
real(kind=dp), parameter :: Newton_g = 6.67408d-11
real(kind=dp), parameter :: Msolar = 1.989d30
real(kind=dp), parameter :: mu = Newton_g*MBH*Msolar
real(kind=dp), parameter :: light_c = 3.0d8
real(kind=dp), parameter :: convert_m = light_c**2/(Newton_g*MBH*Msolar) !Multiply by this to go TO Natural units
real(kind=dp), parameter :: convert_s = light_c**3/(Newton_g*MBH*Msolar) !Multiply by this to go TO Natural units
real(kind=dp), parameter :: convert_spin= light_c/(Newton_g*(MBH*Msolar)**2.0_dp) !Multiply by this to go TO Natural units
real(kind=dp), parameter :: Rhor = 1.0_dp+sqrt(1.0_dp-a**2) + 1.0d-2 !Horizon + eps
real(kind=dp), PARAMETER :: electron_charge = 4.80320425D-10 !CGS
real(kind=dp), PARAMETER :: electron_mass = 9.10938356D-28 !CGS
real(kind=dp), PARAMETER :: pc = 3.0860e16_dp !meters

!MPD
real(kind=dp), parameter :: KeplerianPeriodSeconds = KeplerianPeriod*365.0_dp*24.0_dp*3600.0_dp
real(kind=dp), parameter :: SM3 =(mu*KeplerianPeriodSeconds**2.0_dp)/(4.0_dp * PI**2.0_dp)
real(kind=dp), parameter :: semi_major = convert_m*SM3**(1.0_dp/3.0_dp)
real(kind=dp), parameter :: semi_latus = semi_major * (1.0_dp - eccentricity**2.0_dp)
real(kind=dp), parameter :: ra = semi_latus/(1.0_dp - eccentricity)
real(kind=dp), parameter :: rp = semi_latus/(1.0_dp + eccentricity)
real(kind=dp), parameter :: theta_min = (90.0_dp - iota) * PI/180.0_dp !Minimum latitude reached in radians
real(kind=dp), parameter :: zMinus = cos(theta_min)**2.0_dp
real(kind=dp), parameter :: m0 = MPSR/MBH
real(kind=dp), parameter :: inertia = 0.40_dp*(MPSR*Msolar)*(RPSR*1.0d3)**2.0_dp !SI units
real(kind=dp), parameter :: s0 = convert_spin*2.0_dp*PI*inertia/p0 !magnitude of spin spatial vector in natural units
integer(kind=dp), parameter :: entries = 13 !Number of differetnai eqns 4x(position,spin,momentum + proper time)
real(kind=dp), parameter :: hs_natural = hs * convert_s
real(kind=dp), parameter :: SpinPeriod = p0 * convert_s

real(kind=dp), parameter :: RObs = 1e4_dp !RO*1e3*pc * convert_m

!MPD I/O
integer(kind=dp), parameter :: nrows = 1d4
character(len=200) :: path, MPDBinaryData, MPDFormatData, RTPath
integer(kind=dp) :: OrbitNrows, OrbitNcols

!Ray tracing

!Dark matter
real(kind=dp) :: r0 = r0_SI*1e3*pc * convert_m
real(kind=dp) :: kDM = r0_SI**3 * rho0  !Check units
integer(kind=dp) :: DM !turn DM halo on /off

!Numerical integration
!Cash-Karp parameters and integration constants
real(kind = dp) :: B21=1.0_dp/5.0_dp
real(kind = dp) :: B31 = 3.0_dp/40.0_dp , B32 = 9.0_dp/40.0_dp
real(kind = dp) :: B41 = 3.0_dp/10.0_dp, B42 = -9.0_dp/10.0_dp, B43 = 6.0_dp/5.0_dp
real(kind = dp) :: B51 = -11.0_dp/54.0_dp, B52 = 5.0_dp/2.0_dp, B53 = -70.0_dp/27.0_dp
real(kind = dp) :: B54 = 35.0_dp/27.0_dp
real(kind = dp) :: B61 = 1631.0_dp/55296.0_dp, B62 = 175.0_dp/512.0_dp, B63 = 575.0_dp/13824.0_dp
real(kind = dp) :: B64 = 44275.0_dp/110592.0_dp, B65 = 253.0_dp/4096.0_dp

real(kind = dp) :: c1 = 37.0_dp/378.0_dp, c3 = 250.0_dp/621.0_dp, c4 = 125.0_dp/594.0_dp
real(kind = dp) :: c6=512.0_dp/1771.0_dp
real(kind = dp) :: cbar1 = 2825.0_dp/27648.0_dp, cbar3 = 18575.0_dp/48384.0_dp
real(kind = dp) :: cbar4=13525.0_dp/55296.0_dp, cbar5 = 277.0_dp/14336.0_dp, cbar6 = 1.0_dp/4.0_dp

real(kind = dp) :: escal = 1.0d19 !SHOULD WE CHANGE THIS? SPEED VS ACCURACY....
real(kind = dp) :: PSHRINK = -0.25_dp,PGROW=-0.20_dp, S=0.90_dp
real(kind=dp), parameter :: dx_eps = 1.0e-22_dp !How small do we push this param?

!Some globally defined MPD variables
real(kind=dp) :: m_sq, s_sq ! mass sqaures and s squared from initial condiitons module
real(kind=dp) :: tau !Proper time. Related to the stepsize

!Christoffel sybols
real(kind=dp) ::    G0_00, G0_01, G0_02, G0_03, G0_11, G0_12, G0_13, G0_22, G0_23, G0_33,       &
                    G1_00, G1_01, G1_02, G1_03, G1_11, G1_12, G1_13, G1_22, G1_23, G1_33,       &
                    G2_00, G2_01, G2_02, G2_03, G2_11, G2_12, G2_13, G2_22, G2_23, G2_33,       &
                    G3_00, G3_01, G3_02, G3_03, G3_11, G3_12, G3_13, G3_22, G3_23, G3_33

!Riemann
REAL(KIND=dp) ::                                                                &
    R_0101, R_0102, R_0103, R_0112, R_0113, R_0123,                             &
    R_0201, R_0202, R_0203, R_0212, R_0213, R_0223,                             &
    R_0301, R_0302, R_0303, R_0312, R_0313, R_0323,                             &
    R_1201, R_1202, R_1203, R_1212, R_1213, R_1223,                             &
    R_1301, R_1302, R_1303, R_1312, R_1313, R_1323,                             &
    R_2301, R_2302, R_2303, R_2312, R_2313, R_2323,                             &
!
    R0_001, R0_002, R0_003, R0_012, R0_013, R0_023,                             &
    R0_101, R0_102, R0_103, R0_112, R0_113, R0_123,                             &
    R0_201, R0_202, R0_203, R0_212, R0_213, R0_223,                             &
    R0_301, R0_302, R0_303, R0_312, R0_313, R0_323,                             &
!
    R1_001, R1_002, R1_003, R1_012, R1_013, R1_023,                             &
    R1_101, R1_102, R1_103, R1_112, R1_113, R1_123,                             &
    R1_201, R1_202, R1_203, R1_212, R1_213, R1_223,                             &
    R1_301, R1_302, R1_303, R1_312, R1_313, R1_323,                             &
!
    R2_001, R2_002, R2_003, R2_012, R2_013, R2_023,                             &
    R2_101, R2_102, R2_103, R2_112, R2_113, R2_123,                             &
    R2_201, R2_202, R2_203, R2_212, R2_213, R2_223,                             &
    R2_301, R2_302, R2_303, R2_312, R2_313, R2_323,                             &
!
    R3_001, R3_002, R3_003, R3_012, R3_013, R3_023,                             &
    R3_101, R3_102, R3_103, R3_112, R3_113, R3_123,                             &
    R3_201, R3_202, R3_203, R3_212, R3_213, R3_223,                             &
    R3_301, R3_302, R3_303, R3_312, R3_313, R3_323

!Spin tensor

real(kind=dp) :: S_01, S_02, S_03, S_12, S_13, S_23

end module constants