program integrator
  use cvode_parameters, only: cv_data, cv_pars, net_initial_abundances
  use network
  use net_rates, only: init_reaclib, net_screening_init
  use table_rates, only: init_tabular
  use data_wrangler, only: store_solution, write_solution
  use parameters, only: init_parameters

  implicit none

  integer KOUNTER
  integer jk, i
  double precision, dimension(:), allocatable :: YPREV
  logical :: move_along = .false.

  ! Initialization
  call init_parameters()
  call init_network()
  call init_reaclib()
  call init_tabular()
  call net_screening_init()

  ! Allocate data storage
  allocate( cv_data%net_history(cv_data%NEQ+1, cv_pars%NDT_SAVE) )
  allocate( cv_data%Y0(cv_data%NEQ) )
  allocate( cv_data%Y(cv_data%NEQ) )
  allocate( YPREV(cv_data%NEQ) )

  ! Print Physical Parameters
  write(*,*) 'Integrating starting with:'
  write(*,'(A,ES25.14)') 'T = ', cv_pars%temp
  write(*,'(A,ES25.14)') 'Density = ', cv_pars%dens

  ! Initialize the Integration
  cv_data%Y0(jhe4)   = net_initial_abundances%yhe4
  cv_data%Y0(jc12)   = net_initial_abundances%yc12
  cv_data%Y0(net_ienuc)   = net_initial_abundances%yenuc

  write(*,*) 'Initialization at time 0: '
  do jk = 1, cv_data%NEQ
     write(*,*) 'index: ', jk, ' : ', cv_data%Y0(jk)
  end do

  ! Integration target T_TARGET = NDT_SAVE*DT_SAVE
  cv_data%T_TARGET = DBLE(cv_pars%NDT_SAVE)*cv_pars%DT_SAVE

  ! Setup CVODE
  call FNVINITS(cv_data%KEY, cv_data%NEQ, cv_data%IER)
  call FCVMALLOC(cv_data%T0, cv_data%Y0, cv_data%METH, cv_data%ITMETH, &
       cv_data%IA_TOL, cv_pars%R_TOL, cv_pars%A_TOL, &
       cv_data%IOUT, cv_data%ROUT, cv_data%IPAR, cv_data%RPAR, cv_data%IER)
  if (cv_data%IER /= 0) then
     write(*,*) 'ERROR: occurred in FCVMALLOC!'
     stop
  end if
  call FCVROOTINIT(cv_data%NRTFN, cv_data%IER)
  call FCVSETIIN('MAX_NSTEPS', cv_pars%MAX_NSTEPS, cv_data%IER)
  if (cv_data%IER /= 0) then
     write(*,*) 'ERROR: occurred in FCVSETIN!'
     stop
  end if
  call FCVLAPACKDENSE(cv_data%NEQ, cv_data%IER)
  if (cv_data%IER /= 0) then
     write(*,*) 'ERROR: occurred in FCVLAPACKDENSE!'
     stop
  end if
  call FCVLAPACKDENSESETJAC(cv_pars%SET_JAC_FLAG, cv_data%IER)
  if (cv_data%IER /= 0) then
     write(*,*) 'ERROR: occurred in FCVLAPACKDENSESETJAC!'
     stop
  end if

  call store_solution(cv_data%Y0, cv_data%net_history, 1, 0.0d0)
  YPREV = cv_data%Y0
  ! Do the integration
  do KOUNTER = 1, cv_pars%NDT_SAVE
     cv_data%TK = min(cv_data%T0 + DBLE(KOUNTER)*cv_pars%DT_SAVE, cv_data%T_TARGET)
     write(*,*) 'Attempting integration to: ', cv_data%TK
     call FCVODE(cv_data%TK, cv_data%T, cv_data%Y, cv_pars%ITASK, cv_data%IER)

     if (cv_data%IER == 2) then
        ! The root was found
        ! Y = Y(TK) not Y(T) so we have to find Y(T)
        call FCVODE(cv_data%T, cv_data%T, cv_data%Y, cv_pars%ITASK, cv_data%IER)
        if (cv_data%IER == 0) then
           call store_solution(cv_data%Y, cv_data%net_history, KOUNTER, cv_data%T)
           cv_data%KFIN = KOUNTER
           write(*,*) 'Root Found! Integration halting.'
        else
           write(*,*) 'Error: Root find was unsuccessful!'
        end if
        exit
     else
        ! Store solution values if this was a successful integration
        call store_solution(cv_data%Y, cv_data%net_history, KOUNTER, cv_data%T)
        cv_data%KFIN = KOUNTER
     end if

     write(*,*) '______________________________'
     do i = 1, nspec+1
        write(*,*) 'Y(',i,'): ',cv_data%Y(i)
     end do
     write(*,*) '______________________________'

     !! Stop integration if none of the nuclide abundances are changing by
     !! at least A_TOL, the absolute tolerance of the ODE solver.
     !! It turns out that incorporating A_TOL into the root-solver stopping
     !! condition is better because you can integrate to the exact time the condition
     !! is satisfied instead of checking the stopping condition at each output interval.
     ! move_along = .false.
     ! do i = 1, nspec
     !    if ( cv_data%Y(i) == 0.0d0 ) then
     !       cycle
     !    else if ( abs(cv_data%Y(i)-YPREV(i)) > cv_pars%A_TOL ) then
     !       move_along = .true.
     !    end if
     ! end do

     ! if ( .not. move_along ) then
     !    ! None of the species are changing by more than the absolute tolerance.
     !    ! Stop the integration
     !    exit
     ! end if
     ! YPREV = cv_data%Y

  end do

  if (cv_data%KFIN == cv_pars%NDT_SAVE) then
     write(*,*) 'Desired integration time was reached!'
  end if

  ! Deallocate CVODE Memory
  call FCVROOTFREE
  call FCVFREE

  ! Write profile to output file
  call write_solution(cv_data%net_history, cv_data%KFIN)

  ! Print output to console
  write(*,'(A,ES25.14)') 'Integrated to time: ', cv_data%T
  write(*,'(A,ES25.14)') 'Final enuc: ', cv_data%Y(net_ienuc)
  write(*,'(A,ES25.14)') 'Average enuc_dot: ', cv_data%Y(net_ienuc)/cv_data%T

  write(*,*) "MASS FRACTIONS:"
  write(*,'(A,ES25.14)') 'he4: ', cv_data%Y(jhe4)*aion(jhe4)
  write(*,'(A,ES25.14)') 'c12: ', cv_data%Y(jc12)*aion(jc12)

  deallocate( cv_data%net_history )
  deallocate( cv_data%Y0 )
  deallocate( cv_data%Y )
  deallocate( YPREV )

end program integrator


c	Copyright (c) 2015 James A. Grogan
c
c       Permission is hereby granted, free of charge, to any person obtaining a copy
c       of this software and associated documentation files (the "Software"), to deal
c       in the Software without restriction, including without limitation the rights
c       to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
c       copies of the Software, and to permit persons to whom the Software is
c       furnished to do so, subject to the following conditions:
c
c       The above copyright notice and this permission notice shall be included in
c       call copies or substantial portions of the Software.
c
c       THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
c       IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
c       FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
c       AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
c       LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
c       OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
c       THE SOFTWARE.
c
c       Author: J. Grogan
c       Initial Version: 2013

      subroutine vuanisohyper_inv(nblock,nFiber,nInv,jElem,kIntPt,
     *	kLayer,kSecPt,cmname,nstatev, nfieldv, nprops,props,tempOld,
     *	tempNew,fieldOld,fieldNew,stateOld,sInvariant,zeta,uDev,duDi,
     *	d2uDiDi,stateNew)
c
      include 'vaba_param.inc'
c
      dimension  props(nprops),tempOld(nblock),
     *	fieldOld(nblock,nfieldv),stateOld(nblock,nstatev),
     *	tempNew(nblock), fieldNew(nblock,nfieldv),
     *	stateNew(nblock,nstatev),sInvariant(nblock,nInv),
     *	zeta(nblock,nFiber*(nFiber-1)/2),uDev(nblock),
     *	duDi(nblock,nInv),d2uDiDi(nblock,nInv*(nInv+1)/2)
c
		parameter(zero = 0.d0, one = 1.d0, two = 2.d0, three = 3.d0)
c		Material Properties
		u = props(1)
		rkap = props(2)
		rk1 = props(3)
		rk2 = props(4)
		rp = props(5)
c
c		Loop Over Each Element
		do k = 1,nblock
c			Index Each Invariant according to Abaqus Convention
			i1 = 1
			i1i1 = 1
			i3 = 3
			i3i3 = 6
			i4 = 4
			i1i4 = 7
			i4i4 = 10
			i6 = 8
			i1i6 = 29
			i6i6 = 36
c			Get Values of each Invariant
			ri1 = sinvariant(k,i1)
			ri4 = sinvariant(k,i4)
			ri6 = sinvariant(k,i6)
c			Get Fibre Contributions to UDEV
			t = (one - rp) * (ri1 - three) * (ri1 - three)
			if(ri4>1.)then
				t1 = rk2 * (t + rp * (ri4 - one) * (ri4 - one))
			else
				t1=0.
			endif
			if(ri6>1.)then
				t2 = rk2 * (t + rp * (ri6 - one) * (ri6 - one))
			else
				t2=0.
			endif
			et1 = exp(t1)
			et2 = exp(t2)
			term1 = rk1 / (two * rk2)
			ufibres = term1 * (et1 + et2 - two)
c			Get UDEV
			udev(k) = u * (ri1 - three) + ufibres
c			Get dUdI1
			dt1di1 = rk2 * two * (one - rp) * (ri1 - three)
			dudi(k,i1) = term1 * dt1di1 * (et1 + et2) + u
c			Get dUdI4 and dUdI6
			if(ri4>1.)then
				dt1di4 = rk2 * two * rp * (ri4 - one)
			else
				dt1di4 = 0.
			endif
			if(ri6>1.)then
				dt2di6 = rk2 * two * rp * (ri6 - one)
			else
				dt2di6 = 0.
			endif
			dudi(k,i4) = term1 * dt1di4 * et1
			dudi(k,i6) = term1 * dt2di6 * et2
c			Get d2UdI1dI1
			d2t1di1di1 = rk2 * two * (one - rp)
			d2udidi(k,i1i1) = term1 * (d2t1di1di1 + dt1di1 * dt1di1)
			d2udidi(k,i1i1) = d2udidi(k,i1i1) * (et1 + et2)
c			Get d2UdI1dI4 and d2UdI4dI4
			d2udidi(k,i1i4) = term1 * dt1di4 * dt1di1 * et1
			d2t1di4di4 =  rk2 * two * rp
			d2udidi(k,i4i4) = term1 * (dt1di4 * dt1di4 + d2t1di4di4)
			d2udidi(k,i4i4) = d2udidi(k,i4i4) * et1
c			Get d2UdI1dI6 and d2UdI6dI6
			d2udidi(k,i1i6) = term1 * dt2di6 * dt1di1 * et2
			d2t2di6di6 =  rk2 * two * rp
			d2udidi(k,i6i6) = term1 * (dt2di6 * dt2di6 + d2t2di6di6)
			d2udidi(k,i6i6) = d2udidi(k,i6i6) * et2
		end do
c     	For the compressible case
		if(rkap > zero) then
			do k = 1,nblock
				rj = sInvariant(k,i3)
				dudi(k,i3) = rkap * (rj-one)
c				duDi(k,i3) = (rkap/two) * (rj - one/rj)
				d2udidi(k,i3i3) = rkap
c				d2uDiDi(k,i3i3)= (rkap/two) * (one + one/ rj / rj)
			end do
		end if
      return
      end


      subroutine wwpow(n,vr,vi,iv,powr,powi,ierr)
c!but
c     eleve les elements d'un vecteur complexe a une puissance complexe
c!liste d'appel
c     subroutine wwpow(n,vr,vi,iv,powr,powi,ierr)
c     integer n,iv,ierr
c     double precision vr(n*iv),vi(n*iw),powr,powi
c
c     n : nombre d'element du vecteur
c     vr : tableau contenant les parties reelles des elements du vecteur
c     vi : tableau contenant les parties imaginaires des elements du vecteur
c     iv : increment entre deux element consecutif du vecteur dans le
c          tableau v
c     powr : partie reelle de la puissance a la quelle doivent etre
c            eleves les elements du vecteur
c     powi : partie imaginaire de la puissance a la quelle doivent etre
c            eleves les elements du vecteur
c     ierr : indicateur d'erreur
c            ierr=0 si ok
c            ierr=1 si 0**0
c            ierr=2 si 0**k avec k<0
c!origine
c Serge Steer INRIA 1989
c!
c     Copyright INRIA
      integer n,iv,ierr
      double precision vr(*),vi(*),powr,powi,sr,si
c
      ierr=0
c
      if(powi.ne.0.0d+0) goto 01
c puissance reelle
      call wdpow(n,vr,vi,iv,powr,ierr)
      return
c
   01 continue
c puissance complexes
      ii=1
      do 20 i=1,n
        if(abs(vr(ii))+abs(vi(ii)).ne.0.0d+0) then
                 call wlog(vr(ii),vi(ii),sr,si)
                 call wmul(sr,si,powr,powi,sr,si)
                 sr=exp(sr)
                 vr(ii)=sr*cos(si)
                 vi(ii)=sr*sin(si)
                 ii=ii+iv
                                             else
                 ierr=0
                 return
        endif
   20 continue
c
      return
      end


      subroutine rsp(s,n,p,u,ev,icon,wrk,cov)

c    subroutine returns estimate of response space of dimension p
c    s is input SDM (n x n); resposne space is spanned by columns
c    of u; eigenvalues are returned in ev; icon is an integer variable
c    which is =0 for isotrpic errors; =1 for diagonal covariance
c    =2 for general covariance;  parameters for error covariance are
c    stored in cov

c           this version does not return orthogonal response space vectors
ccc    ALSO:  not normalized any more (evecs are in physical units of E and H)
      integer p,icon,n,i,j,nj1,ierr
      complex s(*),u(n,p)
      real cov(*),ev(n),wrk(n,n,6)

      if( icon .le. 1) then
         call mkarai(s,n,wrk(1,1,1),wrk(1,1,2))

         if(icon .eq.1) then
            do 3 i = 1,n
3           wrk(i,1,5) = sqrt(cov(i))

            do 5 i = 1,n
            do 5 j = 1,n
            wrk(i,j,1) = wrk(i,j,1)/(wrk(i,1,5)*wrk(j,1,5))
5           wrk(i,j,2) = wrk(i,j,2)/(wrk(i,1,5)*wrk(j,1,5))
         end if
      else
c       compute transformation matrix w1 = (cov)**-.5
         call cchdeci(cov,n,ierr)
         if(ierr.eq.0) then
c             transform s to s' = w1 s w1^
            call mkicf(wrk,n)
            call cltslv(cov,n,wrk,n)
            call usuc1(s,wrk,n,n,wrk(1,1,3),wrk(1,1,5))
            call mkarai(wrk(1,1,5),n,wrk(1,1,1),wrk(1,1,2))
         else
            write(*,*) 'error in cholesky decomposition',
     &             'error covariance is numerically singular'
            call mkarai(s,n,wrk(1,1,1),wrk(1,1,2))
         end if
      end if

      call cheig(n,wrk(1,1,1),wrk(1,1,2),wrk(1,2,5),wrk(1,3,5),
     &     wrk(1,1,3),wrk(1,1,4),ev,ierr)
      if(ierr.ne.0) print*,'error in svd'
c      write(*,*) 'ev',ev

      do i = 1,n/2
         temp = ev(i)
         ev(i) = ev(n-i+1)
         ev(n-i+1) = temp
      enddo

      if(icon .le. 1) then
         do 10 i = 1,n
         do 10 j = 1,p
         nj1 = n-j+1
         u(i,j) = cmplx(wrk(i,nj1,3),wrk(i,nj1,4))
10       continue

         if(icon.eq.1) then
            do 15 i = 1,n
            do 15  j = 1,p
15          u(i,j) = u(i,j)*wrk(i,1,5)
         end if
      else
         call pwrsptrn(wrk(1,1,3),wrk(1,1,4),n,p,cov,u)
      end if

ccc   output vectors are not normalized any more

      return
      end
c_______________________________________________________________
c
        subroutine pwrsptrn(zr,zi,n,neig,t1,pwrsp)

        real zr(n,n),zi(n,n)
        complex pwrsp(n,neig),t1(*),temp

c       gets neig dominant eigenvectors out of arrays zr,zi and pre-
c       multiplies by t1; puts result in pwrsp

        kk = 0
        do 20 j = 1,neig
        jj = n-j+1
        ii = 0
           do 20 i = 1,n
           temp = (0.,0.)
              do 10 k =1,i
              ii = ii + 1
10            temp = temp + t1(ii) * cmplx(zr(k,jj),zi(k,jj))
           pwrsp(i,j) = temp
20      continue
        return
        end
c______________________________________________________________________
c
        subroutine mkicf(s,n)

c       makes an n x n complex identity matrix in full storage mode

        complex s(n,n)

        do 5 i = 1,n
        do 5 j = 1,n
5       s(i,j) = (0.,0.)

        do 10 i = 1,n
10      s(i,i) = (1.,0.)

        return
        end


\ -----------------------------------------------------------------------------
\  Lichens
\  Cellular Automata
\  Michel Jean 2019
\ -----------------------------------------------------------------------------

S" Rand.f" INCLUDED
S" pixel.f" INCLUDED

320 constant largeur-monde \
200 constant hauteur-monde
largeur-monde hauteur-monde * constant dim-monde

variable pos-X
variable pos-Y

0 pos-X !
0 pos-Y !

\ ============================================

create  monde dim-monde allot
create  monde-buf dim-monde allot

variable *monde
variable *monde-buf
variable tampon

variable total \ nbr voisins
variable etat \ etat de la cellule

' monde *monde !
' monde-buf *monde-buf !

: centre ( n -- )
*monde @ + c@
;
\ 9 voisins possibles
: est ( n -- )
	1 + dim-monde mod *monde @ + c@ ;

: ouest ( n -- )
	1 - dim-monde mod *monde @ + c@ ;

: nord ( n -- )
	largeur-monde - dim-monde mod *monde @ + c@ ;

: sud ( n -- )
	largeur-monde + dim-monde mod *monde @ + c@ ;

: nord-est ( n -- )
	largeur-monde - 1 + dim-monde mod *monde @ + c@ ;

: nord-ouest ( n -- )
	largeur-monde - 1 - dim-monde mod *monde @ + c@ ;

: sud-est ( n -- )
	largeur-monde + 1 + dim-monde mod *monde @ + c@ ;

: sud-ouest ( n -- )
	largeur-monde + 1 - dim-monde mod *monde @ + c@ ;

\ voisinage de moore

: moore ( n -- ) \ returne le nombre de voisins

	dup nord-ouest
	swap dup nord
	swap dup nord-est
	swap dup est
	swap dup sud-est
	swap dup sud
	swap dup sud-ouest
	swap ouest
;

: somme-moore
	moore
	+ + + + + + +
;

\ regles lichens
: lichens
	dup
	centre etat c!
	somme-moore total c!

	total @ 3 = if 1 etat c! ELSE
	total @ 4 = if 0 etat c! ELSE
	total @ 7 = if 1 etat c! ELSE
	total @ 8 = if 1 etat c!
	then then then then
	etat c@
;

\ =========================================

: initialisation ( -- ) \ monde aléatoire
	*monde @ dim-monde 0 fill
	dim-monde 0 do 100 random
	1 = if 1 *monde @ i + c! then loop
;

: regenere-monde
	dim-monde 0 do i lichens *monde-buf @ i + c! loop
	*monde tampon 1 cells move
	*monde-buf *monde 1 cells move
	tampon *monde-buf 1 cells move
;

: dessine-monde ( -- )
	largeur-monde 0 do
	hauteur-monde 0 do
		largeur-monde i * j + *monde @ + c@ 1 = if
			j i green pixel else
				j i black pixel

	then
	loop loop

;

: run
	initialisation
	set-screen
	dessine-monde
	do
		dessine-monde
		regenere-monde
		view
		10 pause
	loop
;

run


module test_eos_module

  use amrex_constants_module
  use network
  use eos_module
  use eos_type_module
  use meth_params_module, only: nscal, spec_comp, rho_comp, rhoh_comp, temp_comp
  use probin_module, only: dens_min, dens_max, temp_min, temp_max, metalicity_max

  implicit none

  private

contains

  subroutine do_tests(lo, hi, &
      scal, s_lo, s_hi, &
      error, e_lo, e_hi, nc_e, &
      dom_lo, dom_hi) bind(C, name="do_tests")

    integer, intent(in) :: lo(3), hi(3)
    integer, intent(in) :: s_lo(3), s_hi(3)
    integer, intent(in) :: e_lo(3), e_hi(3), nc_e
    integer, intent(in) :: dom_lo(3), dom_hi(3)
    double precision, intent(inout) :: scal(s_lo(1):s_hi(1),s_lo(2):s_hi(2),s_lo(3):s_hi(3),1:nscal)
    double precision, intent(inout) :: error(e_lo(1):e_hi(1),e_lo(2):e_hi(2),e_lo(3):e_hi(3),0:nc_e-1)

    integer :: i, j, k
    integer :: ih1, ihe4
    double precision :: temp_zone, dens_zone, metalicity
    double precision :: dlogrho, dlogT, dmetal
    double precision :: xn_zone(nspec)

    double precision :: h, p, e, s
    double precision :: tfromrh, rfromtp, tfromrp, tfromre, tfromps

    type (eos_t) :: eos_state

    dlogrho   = (log10(dens_max) - log10(dens_min))/(dom_hi(1) - dom_lo(1))
    dlogT     = (log10(temp_max) - log10(temp_min))/(dom_hi(2) - dom_lo(2))
    dmetal    = (metalicity_max  - ZERO           )/(dom_hi(3) - dom_lo(3))

    ! initialize the thermodynamic cube and do the initial EOS call
    ih1 = network_species_index('hydrogen-1')
    ihe4 = network_species_index('helium-4')

    do k = lo(3), hi(3)

       ! set the composition -- approximately solar
       metalicity = ZERO + dble(k)*dmetal
       xn_zone(:) = metalicity/(nspec - 2)   ! all but H, He
       xn_zone(ih1)  = 0.75d0 - HALF*metalicity
       xn_zone(ihe4) = 0.25d0 - HALF*metalicity

       do j = lo(2), hi(2)

          ! set the temperature
          temp_zone = 10.0d0**(log10(temp_min) + dble(j)*dlogT)

          do i = lo(1), hi(1)

             ! set the density
             dens_zone = 10.0d0**(log10(dens_min) + dble(i)*dlogrho)

             !------------------------------------------------------------
             ! call the EOS -- rho, T, X directly
             ! input: eos_input_rt
             !------------------------------------------------------------
             eos_state%T     = temp_zone
             eos_state%rho   = dens_zone
             eos_state%xn(:) = xn_zone(:)

             call eos(eos_input_rt, eos_state)

             ! store the thermodynamic state
             scal(i,j,k,rho_comp) = dens_zone
             scal(i,j,k,rhoh_comp) = dens_zone*eos_state%h
             scal(i,j,k,temp_comp) = temp_zone
             scal(i,j,k,spec_comp:spec_comp-1+nspec) = xn_zone(:)

             h = eos_state%h
             p = eos_state%p
             e = eos_state%e
             s = eos_state%s

             !------------------------------------------------------------
             ! call the EOS with rho, h
             ! input: eos_input_rh
             !------------------------------------------------------------

             ! change initial T guess to make the root find do some work
             eos_state%T     = HALF*temp_zone
             eos_state%rho   = dens_zone
             eos_state%h     = h
             eos_state%xn(:) = xn_zone(:)

             call eos(eos_input_rh, eos_state)

             ! store the thermodynamic state
             tfromrh = eos_state%T
             error(i,j,k,0) = error(i,j,k,0) + (eos_state%T - temp_zone)/temp_zone

             !------------------------------------------------------------
             ! call the EOS with T, p
             ! input: eos_input_tp
             !------------------------------------------------------------

             ! change initial rho guess to make the root find do some work
             eos_state%T     = temp_zone
             eos_state%rho   = THIRD*dens_zone
             eos_state%p     = p
             eos_state%xn(:) = xn_zone(:)

             call eos(eos_input_tp, eos_state)

             ! store the thermodynamic state
             rfromtp = eos_state%rho
             error(i,j,k,1) = error(i,j,k,1) + (eos_state%rho - dens_zone)/dens_zone

             !------------------------------------------------------------
             ! call the EOS with rho, p
             ! input: eos_input_rp
             !------------------------------------------------------------

             ! change initial T guess to make the root find do some work
             eos_state%T     = HALF*temp_zone
             eos_state%rho   = dens_zone
             eos_state%p     = p
             eos_state%xn(:) = xn_zone(:)

             call eos(eos_input_rp, eos_state)

             ! store the thermodynamic state
             tfromrp = eos_state%T
             error(i,j,k,2) = error(i,j,k,2) + (eos_state%T - temp_zone)/temp_zone

             !------------------------------------------------------------
             ! call the EOS with rho, e
             ! input: eos_input_re
             !------------------------------------------------------------

             ! change initial T guess to make the root find do some work
             eos_state%T     = HALF*temp_zone
             eos_state%rho   = dens_zone
             eos_state%e     = e
             eos_state%xn(:) = xn_zone(:)

             call eos(eos_input_re, eos_state)

             ! store the thermodynamic state
             tfromre = eos_state%T
             error(i,j,k,3) = error(i,j,k,3) + (eos_state%T - temp_zone)/temp_zone

             !------------------------------------------------------------
             ! call the EOS with p, s
             ! input: eos_input_ps
             !------------------------------------------------------------

             ! change initial T and rho guess to make the root find do
             ! some work
             eos_state%T     = HALF*temp_zone
             eos_state%rho   = HALF*dens_zone
             eos_state%p     = p
             eos_state%s     = s
             eos_state%xn(:) = xn_zone(:)

             ! some EOSes don't have physically valid treatments
             ! of entropy throughout the entire rho-T plane
             if (eos_state%s > ZERO) then

                call eos(eos_input_ps, eos_state)

                ! store the thermodynamic state
                tfromps = eos_state%T
                error(i,j,k,4) = error(i,j,k,4) + (eos_state%T - temp_zone)/temp_zone

             else
                ! do nothing

             endif

          enddo
       enddo
    enddo

  end subroutine do_tests

end module test_eos_module


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

      subroutine compute_rhs

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

      use bt_data
      implicit none

      integer c, i, j, k, m
      double precision rho_inv, uijk, up1, um1, vijk, vp1, vm1,  &
     &     wijk, wp1, wm1

      if (timeron) call timer_start(t_rhs)
!---------------------------------------------------------------------
!     loop over all cells owned by this node
!---------------------------------------------------------------------
      do c = 1, ncells

!---------------------------------------------------------------------
!     compute the reciprocal of density, and the kinetic energy,
!     and the speed of sound.
!---------------------------------------------------------------------
         do k = -1, cell_size(3,c)
            do j = -1, cell_size(2,c)
               do i = -1, cell_size(1,c)
                  rho_inv = 1.0d0/u(1,i,j,k,c)
                  rho_i(i,j,k,c) = rho_inv
                  us(i,j,k,c) = u(2,i,j,k,c) * rho_inv
                  vs(i,j,k,c) = u(3,i,j,k,c) * rho_inv
                  ws(i,j,k,c) = u(4,i,j,k,c) * rho_inv
                  square(i,j,k,c)     = 0.5d0* (  &
     &                 u(2,i,j,k,c)*u(2,i,j,k,c) +  &
     &                 u(3,i,j,k,c)*u(3,i,j,k,c) +  &
     &                 u(4,i,j,k,c)*u(4,i,j,k,c) ) * rho_inv
                  qs(i,j,k,c) = square(i,j,k,c) * rho_inv
               enddo
            enddo
         enddo

!---------------------------------------------------------------------
! copy the exact forcing term to the right hand side;  because
! this forcing term is known, we can store it on the whole of every
! cell,  including the boundary
!---------------------------------------------------------------------

         do k = 0, cell_size(3,c)-1
            do j = 0, cell_size(2,c)-1
               do i = 0, cell_size(1,c)-1
                  do m = 1, 5
                     rhs(m,i,j,k,c) = forcing(m,i,j,k,c)
                  enddo
               enddo
            enddo
         enddo

!---------------------------------------------------------------------
!     compute xi-direction fluxes
!---------------------------------------------------------------------
         do k = start(3,c), cell_size(3,c)-end(3,c)-1
            do j = start(2,c), cell_size(2,c)-end(2,c)-1
               do i = start(1,c), cell_size(1,c)-end(1,c)-1
                  uijk = us(i,j,k,c)
                  up1  = us(i+1,j,k,c)
                  um1  = us(i-1,j,k,c)

                  rhs(1,i,j,k,c) = rhs(1,i,j,k,c) + dx1tx1 *  &
     &                 (u(1,i+1,j,k,c) - 2.0d0*u(1,i,j,k,c) +  &
     &                 u(1,i-1,j,k,c)) -  &
     &                 tx2 * (u(2,i+1,j,k,c) - u(2,i-1,j,k,c))

                  rhs(2,i,j,k,c) = rhs(2,i,j,k,c) + dx2tx1 *  &
     &                 (u(2,i+1,j,k,c) - 2.0d0*u(2,i,j,k,c) +  &
     &                 u(2,i-1,j,k,c)) +  &
     &                 xxcon2*con43 * (up1 - 2.0d0*uijk + um1) -  &
     &                 tx2 * (u(2,i+1,j,k,c)*up1 -  &
     &                 u(2,i-1,j,k,c)*um1 +  &
     &                 (u(5,i+1,j,k,c)- square(i+1,j,k,c)-  &
     &                 u(5,i-1,j,k,c)+ square(i-1,j,k,c))*  &
     &                 c2)

                  rhs(3,i,j,k,c) = rhs(3,i,j,k,c) + dx3tx1 *  &
     &                 (u(3,i+1,j,k,c) - 2.0d0*u(3,i,j,k,c) +  &
     &                 u(3,i-1,j,k,c)) +  &
     &                 xxcon2 * (vs(i+1,j,k,c) - 2.0d0*vs(i,j,k,c) +  &
     &                 vs(i-1,j,k,c)) -  &
     &                 tx2 * (u(3,i+1,j,k,c)*up1 -  &
     &                 u(3,i-1,j,k,c)*um1)

                  rhs(4,i,j,k,c) = rhs(4,i,j,k,c) + dx4tx1 *  &
     &                 (u(4,i+1,j,k,c) - 2.0d0*u(4,i,j,k,c) +  &
     &                 u(4,i-1,j,k,c)) +  &
     &                 xxcon2 * (ws(i+1,j,k,c) - 2.0d0*ws(i,j,k,c) +  &
     &                 ws(i-1,j,k,c)) -  &
     &                 tx2 * (u(4,i+1,j,k,c)*up1 -  &
     &                 u(4,i-1,j,k,c)*um1)

                  rhs(5,i,j,k,c) = rhs(5,i,j,k,c) + dx5tx1 *  &
     &                 (u(5,i+1,j,k,c) - 2.0d0*u(5,i,j,k,c) +  &
     &                 u(5,i-1,j,k,c)) +  &
     &                 xxcon3 * (qs(i+1,j,k,c) - 2.0d0*qs(i,j,k,c) +  &
     &                 qs(i-1,j,k,c)) +  &
     &                 xxcon4 * (up1*up1 -       2.0d0*uijk*uijk +  &
     &                 um1*um1) +  &
     &                 xxcon5 * (u(5,i+1,j,k,c)*rho_i(i+1,j,k,c) -  &
     &                 2.0d0*u(5,i,j,k,c)*rho_i(i,j,k,c) +  &
     &                 u(5,i-1,j,k,c)*rho_i(i-1,j,k,c)) -  &
     &                 tx2 * ( (c1*u(5,i+1,j,k,c) -  &
     &                 c2*square(i+1,j,k,c))*up1 -  &
     &                 (c1*u(5,i-1,j,k,c) -  &
     &                 c2*square(i-1,j,k,c))*um1 )
               enddo
            enddo
         enddo

!---------------------------------------------------------------------
!     add fourth order xi-direction dissipation
!---------------------------------------------------------------------
         if (start(1,c) .gt. 0) then
            do k = start(3,c), cell_size(3,c)-end(3,c)-1
               do j = start(2,c), cell_size(2,c)-end(2,c)-1
                  i = 1
                  do m = 1, 5
                     rhs(m,i,j,k,c) = rhs(m,i,j,k,c)- dssp *  &
     &                    ( 5.0d0*u(m,i,j,k,c) - 4.0d0*u(m,i+1,j,k,c) +  &
     &                    u(m,i+2,j,k,c))
                  enddo

                  i = 2
                  do m = 1, 5
                     rhs(m,i,j,k,c) = rhs(m,i,j,k,c) - dssp *  &
     &                    (-4.0d0*u(m,i-1,j,k,c) + 6.0d0*u(m,i,j,k,c) -  &
     &                    4.0d0*u(m,i+1,j,k,c) + u(m,i+2,j,k,c))
                  enddo
               enddo
            enddo
         endif

         do k = start(3,c), cell_size(3,c)-end(3,c)-1
            do j = start(2,c), cell_size(2,c)-end(2,c)-1
               do i = 3*start(1,c),cell_size(1,c)-3*end(1,c)-1
                  do m = 1, 5
                     rhs(m,i,j,k,c) = rhs(m,i,j,k,c) - dssp *  &
     &                    (  u(m,i-2,j,k,c) - 4.0d0*u(m,i-1,j,k,c) +  &
     &                    6.0*u(m,i,j,k,c) - 4.0d0*u(m,i+1,j,k,c) +  &
     &                    u(m,i+2,j,k,c) )
                  enddo
               enddo
            enddo
         enddo

         if (end(1,c) .gt. 0) then
            do k = start(3,c), cell_size(3,c)-end(3,c)-1
               do j = start(2,c), cell_size(2,c)-end(2,c)-1
                  i = cell_size(1,c)-3
                  do m = 1, 5
                     rhs(m,i,j,k,c) = rhs(m,i,j,k,c) - dssp *  &
     &                    ( u(m,i-2,j,k,c) - 4.0d0*u(m,i-1,j,k,c) +  &
     &                    6.0d0*u(m,i,j,k,c) - 4.0d0*u(m,i+1,j,k,c) )
                  enddo

                  i = cell_size(1,c)-2
                  do m = 1, 5
                     rhs(m,i,j,k,c) = rhs(m,i,j,k,c) - dssp *  &
     &                    ( u(m,i-2,j,k,c) - 4.d0*u(m,i-1,j,k,c) +  &
     &                    5.d0*u(m,i,j,k,c) )
                  enddo
               enddo
            enddo
         endif

!---------------------------------------------------------------------
!     compute eta-direction fluxes
!---------------------------------------------------------------------
         do k = start(3,c), cell_size(3,c)-end(3,c)-1
            do j = start(2,c), cell_size(2,c)-end(2,c)-1
               do i = start(1,c), cell_size(1,c)-end(1,c)-1
                  vijk = vs(i,j,k,c)
                  vp1  = vs(i,j+1,k,c)
                  vm1  = vs(i,j-1,k,c)
                  rhs(1,i,j,k,c) = rhs(1,i,j,k,c) + dy1ty1 *  &
     &                 (u(1,i,j+1,k,c) - 2.0d0*u(1,i,j,k,c) +  &
     &                 u(1,i,j-1,k,c)) -  &
     &                 ty2 * (u(3,i,j+1,k,c) - u(3,i,j-1,k,c))
                  rhs(2,i,j,k,c) = rhs(2,i,j,k,c) + dy2ty1 *  &
     &                 (u(2,i,j+1,k,c) - 2.0d0*u(2,i,j,k,c) +  &
     &                 u(2,i,j-1,k,c)) +  &
     &                 yycon2 * (us(i,j+1,k,c) - 2.0d0*us(i,j,k,c) +  &
     &                 us(i,j-1,k,c)) -  &
     &                 ty2 * (u(2,i,j+1,k,c)*vp1 -  &
     &                 u(2,i,j-1,k,c)*vm1)
                  rhs(3,i,j,k,c) = rhs(3,i,j,k,c) + dy3ty1 *  &
     &                 (u(3,i,j+1,k,c) - 2.0d0*u(3,i,j,k,c) +  &
     &                 u(3,i,j-1,k,c)) +  &
     &                 yycon2*con43 * (vp1 - 2.0d0*vijk + vm1) -  &
     &                 ty2 * (u(3,i,j+1,k,c)*vp1 -  &
     &                 u(3,i,j-1,k,c)*vm1 +  &
     &                 (u(5,i,j+1,k,c) - square(i,j+1,k,c) -  &
     &                 u(5,i,j-1,k,c) + square(i,j-1,k,c))  &
     &                 *c2)
                  rhs(4,i,j,k,c) = rhs(4,i,j,k,c) + dy4ty1 *  &
     &                 (u(4,i,j+1,k,c) - 2.0d0*u(4,i,j,k,c) +  &
     &                 u(4,i,j-1,k,c)) +  &
     &                 yycon2 * (ws(i,j+1,k,c) - 2.0d0*ws(i,j,k,c) +  &
     &                 ws(i,j-1,k,c)) -  &
     &                 ty2 * (u(4,i,j+1,k,c)*vp1 -  &
     &                 u(4,i,j-1,k,c)*vm1)
                  rhs(5,i,j,k,c) = rhs(5,i,j,k,c) + dy5ty1 *  &
     &                 (u(5,i,j+1,k,c) - 2.0d0*u(5,i,j,k,c) +  &
     &                 u(5,i,j-1,k,c)) +  &
     &                 yycon3 * (qs(i,j+1,k,c) - 2.0d0*qs(i,j,k,c) +  &
     &                 qs(i,j-1,k,c)) +  &
     &                 yycon4 * (vp1*vp1       - 2.0d0*vijk*vijk +  &
     &                 vm1*vm1) +  &
     &                 yycon5 * (u(5,i,j+1,k,c)*rho_i(i,j+1,k,c) -  &
     &                 2.0d0*u(5,i,j,k,c)*rho_i(i,j,k,c) +  &
     &                 u(5,i,j-1,k,c)*rho_i(i,j-1,k,c)) -  &
     &                 ty2 * ((c1*u(5,i,j+1,k,c) -  &
     &                 c2*square(i,j+1,k,c)) * vp1 -  &
     &                 (c1*u(5,i,j-1,k,c) -  &
     &                 c2*square(i,j-1,k,c)) * vm1)
               enddo
            enddo
         enddo

!---------------------------------------------------------------------
!     add fourth order eta-direction dissipation
!---------------------------------------------------------------------
         if (start(2,c) .gt. 0) then
            do k = start(3,c), cell_size(3,c)-end(3,c)-1
               j = 1
               do i = start(1,c), cell_size(1,c)-end(1,c)-1
                  do m = 1, 5
                     rhs(m,i,j,k,c) = rhs(m,i,j,k,c)- dssp *  &
     &                    ( 5.0d0*u(m,i,j,k,c) - 4.0d0*u(m,i,j+1,k,c) +  &
     &                    u(m,i,j+2,k,c))
                  enddo
               enddo

               j = 2
               do i = start(1,c), cell_size(1,c)-end(1,c)-1
                  do m = 1, 5
                     rhs(m,i,j,k,c) = rhs(m,i,j,k,c) - dssp *  &
     &                    (-4.0d0*u(m,i,j-1,k,c) + 6.0d0*u(m,i,j,k,c) -  &
     &                    4.0d0*u(m,i,j+1,k,c) + u(m,i,j+2,k,c))
                  enddo
               enddo
            enddo
         endif

         do k = start(3,c), cell_size(3,c)-end(3,c)-1
            do j = 3*start(2,c), cell_size(2,c)-3*end(2,c)-1
               do i = start(1,c),cell_size(1,c)-end(1,c)-1
                  do m = 1, 5
                     rhs(m,i,j,k,c) = rhs(m,i,j,k,c) - dssp *  &
     &                    (  u(m,i,j-2,k,c) - 4.0d0*u(m,i,j-1,k,c) +  &
     &                    6.0*u(m,i,j,k,c) - 4.0d0*u(m,i,j+1,k,c) +  &
     &                    u(m,i,j+2,k,c) )
                  enddo
               enddo
            enddo
         enddo

         if (end(2,c) .gt. 0) then
            do k = start(3,c), cell_size(3,c)-end(3,c)-1
               j = cell_size(2,c)-3
               do i = start(1,c), cell_size(1,c)-end(1,c)-1
                  do m = 1, 5
                     rhs(m,i,j,k,c) = rhs(m,i,j,k,c) - dssp *  &
     &                    ( u(m,i,j-2,k,c) - 4.0d0*u(m,i,j-1,k,c) +  &
     &                    6.0d0*u(m,i,j,k,c) - 4.0d0*u(m,i,j+1,k,c) )
                  enddo
               enddo

               j = cell_size(2,c)-2
               do i = start(1,c), cell_size(1,c)-end(1,c)-1
                  do m = 1, 5
                     rhs(m,i,j,k,c) = rhs(m,i,j,k,c) - dssp *  &
     &                    ( u(m,i,j-2,k,c) - 4.d0*u(m,i,j-1,k,c) +  &
     &                    5.d0*u(m,i,j,k,c) )
                  enddo
               enddo
            enddo
         endif

!---------------------------------------------------------------------
!     compute zeta-direction fluxes
!---------------------------------------------------------------------
         do k = start(3,c), cell_size(3,c)-end(3,c)-1
            do j = start(2,c), cell_size(2,c)-end(2,c)-1
               do i = start(1,c), cell_size(1,c)-end(1,c)-1
                  wijk = ws(i,j,k,c)
                  wp1  = ws(i,j,k+1,c)
                  wm1  = ws(i,j,k-1,c)

                  rhs(1,i,j,k,c) = rhs(1,i,j,k,c) + dz1tz1 *  &
     &                 (u(1,i,j,k+1,c) - 2.0d0*u(1,i,j,k,c) +  &
     &                 u(1,i,j,k-1,c)) -  &
     &                 tz2 * (u(4,i,j,k+1,c) - u(4,i,j,k-1,c))
                  rhs(2,i,j,k,c) = rhs(2,i,j,k,c) + dz2tz1 *  &
     &                 (u(2,i,j,k+1,c) - 2.0d0*u(2,i,j,k,c) +  &
     &                 u(2,i,j,k-1,c)) +  &
     &                 zzcon2 * (us(i,j,k+1,c) - 2.0d0*us(i,j,k,c) +  &
     &                 us(i,j,k-1,c)) -  &
     &                 tz2 * (u(2,i,j,k+1,c)*wp1 -  &
     &                 u(2,i,j,k-1,c)*wm1)
                  rhs(3,i,j,k,c) = rhs(3,i,j,k,c) + dz3tz1 *  &
     &                 (u(3,i,j,k+1,c) - 2.0d0*u(3,i,j,k,c) +  &
     &                 u(3,i,j,k-1,c)) +  &
     &                 zzcon2 * (vs(i,j,k+1,c) - 2.0d0*vs(i,j,k,c) +  &
     &                 vs(i,j,k-1,c)) -  &
     &                 tz2 * (u(3,i,j,k+1,c)*wp1 -  &
     &                 u(3,i,j,k-1,c)*wm1)
                  rhs(4,i,j,k,c) = rhs(4,i,j,k,c) + dz4tz1 *  &
     &                 (u(4,i,j,k+1,c) - 2.0d0*u(4,i,j,k,c) +  &
     &                 u(4,i,j,k-1,c)) +  &
     &                 zzcon2*con43 * (wp1 - 2.0d0*wijk + wm1) -  &
     &                 tz2 * (u(4,i,j,k+1,c)*wp1 -  &
     &                 u(4,i,j,k-1,c)*wm1 +  &
     &                 (u(5,i,j,k+1,c) - square(i,j,k+1,c) -  &
     &                 u(5,i,j,k-1,c) + square(i,j,k-1,c))  &
     &                 *c2)
                  rhs(5,i,j,k,c) = rhs(5,i,j,k,c) + dz5tz1 *  &
     &                 (u(5,i,j,k+1,c) - 2.0d0*u(5,i,j,k,c) +  &
     &                 u(5,i,j,k-1,c)) +  &
     &                 zzcon3 * (qs(i,j,k+1,c) - 2.0d0*qs(i,j,k,c) +  &
     &                 qs(i,j,k-1,c)) +  &
     &                 zzcon4 * (wp1*wp1 - 2.0d0*wijk*wijk +  &
     &                 wm1*wm1) +  &
     &                 zzcon5 * (u(5,i,j,k+1,c)*rho_i(i,j,k+1,c) -  &
     &                 2.0d0*u(5,i,j,k,c)*rho_i(i,j,k,c) +  &
     &                 u(5,i,j,k-1,c)*rho_i(i,j,k-1,c)) -  &
     &                 tz2 * ( (c1*u(5,i,j,k+1,c) -  &
     &                 c2*square(i,j,k+1,c))*wp1 -  &
     &                 (c1*u(5,i,j,k-1,c) -  &
     &                 c2*square(i,j,k-1,c))*wm1)
               enddo
            enddo
         enddo

!---------------------------------------------------------------------
!     add fourth order zeta-direction dissipation
!---------------------------------------------------------------------
         if (start(3,c) .gt. 0) then
            k = 1
            do j = start(2,c), cell_size(2,c)-end(2,c)-1
               do i = start(1,c), cell_size(1,c)-end(1,c)-1
                  do m = 1, 5
                     rhs(m,i,j,k,c) = rhs(m,i,j,k,c)- dssp *  &
     &                    ( 5.0d0*u(m,i,j,k,c) - 4.0d0*u(m,i,j,k+1,c) +  &
     &                    u(m,i,j,k+2,c))
                  enddo
               enddo
            enddo

            k = 2
            do j = start(2,c), cell_size(2,c)-end(2,c)-1
               do i = start(1,c), cell_size(1,c)-end(1,c)-1
                  do m = 1, 5
                     rhs(m,i,j,k,c) = rhs(m,i,j,k,c) - dssp *  &
     &                    (-4.0d0*u(m,i,j,k-1,c) + 6.0d0*u(m,i,j,k,c) -  &
     &                    4.0d0*u(m,i,j,k+1,c) + u(m,i,j,k+2,c))
                  enddo
               enddo
            enddo
         endif

         do k = 3*start(3,c), cell_size(3,c)-3*end(3,c)-1
            do j = start(2,c), cell_size(2,c)-end(2,c)-1
               do i = start(1,c),cell_size(1,c)-end(1,c)-1
                  do m = 1, 5
                     rhs(m,i,j,k,c) = rhs(m,i,j,k,c) - dssp *  &
     &                    (  u(m,i,j,k-2,c) - 4.0d0*u(m,i,j,k-1,c) +  &
     &                    6.0*u(m,i,j,k,c) - 4.0d0*u(m,i,j,k+1,c) +  &
     &                    u(m,i,j,k+2,c) )
                  enddo
               enddo
            enddo
         enddo

         if (end(3,c) .gt. 0) then
            k = cell_size(3,c)-3
            do j = start(2,c), cell_size(2,c)-end(2,c)-1
               do i = start(1,c), cell_size(1,c)-end(1,c)-1
                  do m = 1, 5
                     rhs(m,i,j,k,c) = rhs(m,i,j,k,c) - dssp *  &
     &                    ( u(m,i,j,k-2,c) - 4.0d0*u(m,i,j,k-1,c) +  &
     &                    6.0d0*u(m,i,j,k,c) - 4.0d0*u(m,i,j,k+1,c) )
                  enddo
               enddo
            enddo

            k = cell_size(3,c)-2
            do j = start(2,c), cell_size(2,c)-end(2,c)-1
               do i = start(1,c), cell_size(1,c)-end(1,c)-1
                  do m = 1, 5
                     rhs(m,i,j,k,c) = rhs(m,i,j,k,c) - dssp *  &
     &                    ( u(m,i,j,k-2,c) - 4.d0*u(m,i,j,k-1,c) +  &
     &                    5.d0*u(m,i,j,k,c) )
                  enddo
               enddo
            enddo
         endif

         do k = start(3,c), cell_size(3,c)-end(3,c)-1
            do j = start(2,c), cell_size(2,c)-end(2,c)-1
               do i = start(1,c), cell_size(1,c)-end(1,c)-1
                  do m = 1, 5
                     rhs(m,i,j,k,c) = rhs(m,i,j,k,c) * dt
                  enddo
               enddo
            enddo
         enddo

      enddo

      if (timeron) call timer_stop(t_rhs)

      return
      end


!---------------------------------------------------!
! Copyright (c) 2016 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine preparation
  use global_variables
  implicit none
  integer :: ix,ik,aion,bion, icopy
  real(8) :: x
  real(8) :: lambda
  real(8) :: sigma_t,xp1,xp2,xp3,xp4,xm1,xm2,xm3,xm4
  real(8) :: Za,Zb,xshift

  H=lattice_a/dble(Nx)
  dKx=2d0*pi/(dble(Nk)*lattice_a)

! Laplacian coefficients
  L_coef(0)=-30d0/12d0/(H**2)
  L_coef(1)=16d0/12d0/(H**2)
  L_coef(2)=-1d0/12d0/(H**2)
  L_coef(-1)=16d0/12d0/(H**2)
  L_coef(-2)=-1d0/12d0/(H**2)
! Gradient coefficients
  G_coef(0)=0d0
  G_coef(1)=8d0/12d0/H
  G_coef(2)=-1d0/12d0/H
  G_coef(-1)=-8d0/12d0/H
  G_coef(-2)=1d0/12d0/H

  allocate(Lx(Nx),Kx(NK))

  allocate(ztpsi(Nx),zhtpsi(Nx))
  allocate(Veff(Nx),spe(NB,NK))
  allocate(zpsi_GS(Nx,NB,NK))
  allocate(zpsi_Ct(NB*NK,NK),zpsi_Ct_t(NB*NK,NK),zhpsi_Ct_t(NB*NK,NK))
  allocate( zpsi_Ct_t_Lan(NB*NK,NK,0:Nlanczos)); zpsi_Ct_t_Lan = 0d0

  do ix=1,Nx
    Lx(ix)=dble(ix-1)*H
  end do

  do ik=1,NK
    kx(ik)=dKx*dble(ik-1-NK/2)
!    kx(ik)=dKx*dble(ik-1)
  end do

  Veff = 0d0
  do icopy = -10,10
    do aion = 1,Nion
      do ix=1,Nx
        x = Lx(ix) - Rion(aion) + dble(icopy)*lattice_a
        Veff(ix) = Veff(ix) -Zion(aion)*int_pot_ei(x)
      end do
    end do
  end do

! ion
  allocate(Phi_FC(NK,Nion,NK,Nion), Fion(NK,Nion), Uion(NK,Nion))
  allocate(Dph_mat(NK*Nion,NK*Nion))
  allocate(w2_ph(Nion,NK),w_ph(Nion,NK))

  E_ii = 0d0
  do aion = 1,Nion
    do bion = 1,Nion
      do icopy = -10,10
        if(aion == bion .and. icopy == 0)cycle
        E_ii = E_ii &
          + Zion(aion)*Zion(bion)*int_pot_ii(Rion(aion)-Rion(bion)+lattice_a*icopy)
      end do
    end do
  end do
  E_ii = 0.5d0*E_ii

  return
end subroutine preparation
!-------10--------20--------30--------40--------50--------60--------70--------80--------90


MODULE bezier_math
  !
  ! Bezier-Splines utilities. These tools provide accurate Bezier Interpolants
  ! that minimize overshooting of the interpolated function. Additional tools
  ! to integrate a functions analytically, assuming a Bezier interpolant are
  ! also included (these are used to obtain tau_nu)
  !
  ! CONTAINS:
  ! cent_deriv     -> This subroutine computes centered derivatives
  ! bezier         -> Performs interpolation assuming a cuadratic bezier interpolant
  ! bezier3        -> Performs interpolation assuming a cubic Bezier interpolant
  ! bezier_cqintep -> Cumulative integral of a function, starting at element 1. Quadratic Bezier
  ! bezier_qintep  -> Total integral of a function. Quadratic Bezier.
  ! bezier_ccintep -> Cumulative integral of a function, starting at element 1. Cubic Bezier
  ! bezier_cintep  -> Total integral of a function. Cubic Bezier.
  !
  ! USAGE:
  ! call     cent_deriv(npoints_in, x_in, y_in, yprime)
  ! call         bezier(npoints_in, x_in, y_in, npoints_new, x_new, y_out)
  ! call        bezier3(npoints_in, x_in, y_in, npoints_new, x_new, y_out)
  ! call  bezier_qintep(npoints_in, x_in, y_in, result)
  ! call  bezier_cintep(npoints_in, x_in, y_in, result)
  ! call bezier_ccintep(npoints_in, x_in, y_in, cresult)
  ! call bezier_cqintep(npoints_in, x_in, y_in, cresult)
  !
  ! NOTE:
  !  The formal solvers alter the input arrays tau and abs matrix
  ! WHERE:
  ! npoints_in (int) is the number of elements of x_in, y_in, yprime, cresult (floats).
  ! npoints_new (int) is the number of elements of x_new, y_out (floats).
  ! result is a float. Notice that cresult is an array and result is not.
  !
  ! REFERENCES:
  ! Auer 2003 (Interpolants).
  ! Fritsch and Butland 1984 (Derivatives).
  !
  ! The analytical integral of the Bezier interpolants used in the integration and
  ! cumulative integrated was computed by the author.
  !
  ! Jaime de la Cruz Rodriguez (IFA-Uppsala University 2012)
  !
  ! MODIFICATIONS:
  ! 2012-10-04, JdlCR: Created!
  !
  ! -
  Implicit None
CONTAINS
  subroutine ctrapez(n,x,y,inte)
    Implicit none
    Integer :: n, np, k, k1
    real :: x(n), y(n), inte(n)
    real(8) :: tmp

    tmp = inte(1)
    do k = 2, n
       tmp = tmp + 0.5d0*(y(k) + y(k-1)) * (x(k) - x(k-1))
       inte(k) = tmp
    end do

    return
  end subroutine ctrapez
  subroutine trapez(n,x,y,inte)
    Implicit none
    Integer :: n, np, k, k1
    real :: x(n), y(n), inte(n)

    do k = 2, n
       inte(k) = 0.5d0*(y(k) + y(k-1)) * (x(k) - x(k-1))
    end do

    return
  end subroutine trapez
  subroutine cent_deriv(n,x,y,yp)
    Implicit None
    integer :: n, k
    Real :: x(n), y(n)
    real(8) :: der, der1, lambda, yp(n), dx , dx1

    do k = 2, n - 1
       dx = x(k) - x(k-1)
       der = (y(k) - y(k-1)) / dx

       dx1 = x(k+1) - x(k)
       der1 = (y(k+1) - y(k)) / dx1

       if(der*der1 .gt. 0.0d0) then
          lambda = (1.d0 + dx1 / (dx1 + dx)) / 3.d0
          yp(k) = (der / (lambda * der1 + (1.d0 - lambda) * der)) * der1
       Else
          yp(k) = 0.0d0
       end if
    enddo

    yp(1) =  (y(1) - y(2)) / (x(1) - x(2))
    yp(n) = (y(n-1) - y(n)) / (x(n-1) - x(n))

    return
  end subroutine cent_deriv
  subroutine cent_deriv_d(n,x,y,yp)
    Implicit None
    integer :: n, k
    Real :: x(n), y(n)
    real(8) :: der, der1, lambda, yp(n), dx , dx1

    do k = 2, n - 1
       dx = x(k) ! x(k) - x(k-1)
       der = (y(k) - y(k-1)) / dx

       dx1 = x(k+1) ! x(k+1) - x(k)
       der1 = (y(k+1) - y(k)) / dx1

       if(der*der1 .gt. 0.0d0) then
          lambda = (1.d0 + dx1 / (dx1 + dx)) / 3.d0
          yp(k) = (der / (lambda * der1 + (1.d0 - lambda) * der)) * der1
       Else
          yp(k) = 0.0d0
       end if
    enddo

    yp(1) =  (y(2) - y(1)) / (x(2)) ! (x(1) - x(2))
    yp(n) = (y(n) - y(n-1)) / (x(n)) ! (x(n-1) - x(n))

    return
  end subroutine cent_deriv_d

  subroutine bezier(n, x, y, np, xp, yp)
    Implicit None
    Integer :: n, np, k
    Real, dimension(n) :: x, y
    Real, dimension(np) :: xp, yp
    Real(8) :: cntrl, dx, yprime(n), lambda, u(np)

    !
    ! Compute derivatives
    !
    cntrl = 0
    yprime = 0
    call cent_deriv(n, x, y, yprime)

    do k = 2, n
       dx =  x(k) - x(k-1)

       cntrl = 0.5d0 * (y(k) - 0.5d0*dx * yprime(k) + y(k-1) + 0.5d0*dx * yprime(k-1))
       if(cntrl .GT. max(y(k),y(k-1)) .OR. cntrl .LT. min(y(k),y(k-1))) cntrl = y(k-1)

       where(xp .LT. x(k) .AND. xp .GE. x(k-1))
          u = (xp - x(k-1)) / dx
          yp = y(k-1) * (1.d0 - u)**2 + y(k) * u**2 + 2.d0 * cntrl * u * (1.d0 - u)
       End where
    end do

    !
    ! Points outside the domain
    !
    where(xp .GE. x(n))
       yp = y(n)
    end where
    where(xp .LE. x(1))
       yp = y(1)
    end where
  end subroutine bezier
  subroutine bezier3(n, x, y, np, xp, yp)
    Implicit None
    Integer :: n, np, k
    Real, dimension(n) :: x, y
    Real, dimension(np) :: xp, yp
    Real(8) :: c1, c2, yprime(n), dx, u(np), mmi, mma

    c1 = 0
    c2 = 0
    yprime = 0
    !
    ! Compute derivatives
    !
    call cent_deriv(n, x, y, yprime)
    !
    do k = 2, n
       dx =  x(k) - x(k-1)

       c1 = y(k-1) + dx * yprime(k-1) / 3.0d0
       c2 = y(k) - dx * yprime(k) / 3.0d0

       mmi = min(y(k),y(k-1))
       mma = max(y(k),y(k-1))
       if(c1 .LT. mmi .OR. c1 .GT. mma) c1 = y(k-1)
       if(c2 .LT. mmi .OR. c2 .GT. mma) c2 = y(k)

       where(xp .LT. x(k) .AND. xp .GE. x(k-1))
          u = (xp - x(k-1)) / dx
          yp = y(k-1) * (1.d0 - u)**3 + y(k) * u**3 + &
               3.d0 * c1 * u * (1.d0 - u)**2 + 3.0d0 * c2 * u**2 * (1.0d0 - u)
       End where

    end do

    !
    ! Points outside the domain
    !
    where(xp .GE. x(n))
       yp = y(n)
    end where
    where(xp .LE. x(1))
       yp = y(1)
    end where
  end subroutine bezier3

  subroutine bezier_cqintep(n, x, y, inte)
    Implicit none
    Integer :: n, np, k, k1
    real :: x(n), y(n), inte(n)
    real(8) :: dx, dx2, dI, I, yprime(n), c, mma, mmi

    call cent_deriv(n, x, y, yprime)

    Do k = 1, n - 1
       k1 = k+1
       dx = x(k+1) - x(k)

       dx2 = dx * 0.5d0

       c = (y(k) + dx2 * yprime(k) + y(k1) - dx2 * yprime(k1)) * 0.5d0
     !  mmi = min(y(k), y(k1))
     !  mma = max(y(k), y(k1))
     !  if(c .gt. mma)  c = mma
     !  if(c .lt. mmi)  c = mmi

       inte(k1) = inte(k) +  dx / 3.0d0 * (y(k) + y(k1) + c)
    end do
    inte(n)=y(n)*(x(n)-x(n-1))

    return
  End subroutine bezier_cqintep

  subroutine bezier_qintep(n, x, y, inte)
    Implicit none
    Integer :: n, np, k, k1
    real :: x(n), y(n), inte(n)
    real(8) :: dx, dx2, dI, I, yprime(n), mmi, mma, c, c1

    call cent_deriv(n, x, y, yprime)

    inte(1)=y(1)*(x(2)-x(1))
    do k = 1, n - 1
       k1 = k+1
       dx = x(k1) - x(k)

       dx2 = dx * 0.5d0

       c = (y(k) + dx2 * yprime(k) + y(k+1) - dx2 * yprime(k+1)) * 0.5d0
   !    mmi = min(y(k), y(k1))
   !    mma = max(y(k), y(k1))
   !    if(c .gt. mma)  c = mma
   !    if(c .lt. mmi)  c = mmi

       inte(k1) = dx * (y(k) + y(k+1) + c) / 3.0d0
    end do
    inte(n)=y(n)*(x(n)-x(n-1))

    return
  End subroutine bezier_qintep

  subroutine bezier_ccintep(n, x, y, inte)
    Implicit none
    Integer :: n, np, k, k1
    real :: x(n), y(n), inte(n)
    real(8) :: dx, dx3, dI, I, yprime(n), c, c1, mmi, mma

    call cent_deriv(n, x, y, yprime)

    Do k = 1, n - 1
       k1 = k + 1
       dx = x(k+1) - x(k)

       dx3 = dx / 3.0d0

       c = y(k) + dx3 * yprime(k)
       c1 =  y(k1) - dx3 * yprime(k1)

  !     mmi = min(y(k),y(k1))
  !     mma = max(y(k),y(k1))
  !     if(c  .LT. mmi .OR.  c .GT. mma) c = y(k)
  !     if(c1 .LT. mmi .OR. c1 .GT. mma) c1 = y(k1)

       inte(k1) = inte(k) + dx * (y(k) + y(k1) + c + c1) * 0.25d0
    end do

    return
  End subroutine bezier_ccintep

  subroutine bezier_cintep(n, x, y, inte)
    Implicit none
    Integer :: n, np, k, k1
    real :: x(n), y(n), inte(n), c, c1
    real(8) :: dx, dx3, dI, I, yprime(n), mmi, mma

    call cent_deriv(n, x, y, yprime)

    do k = 1, n - 1
       k1 = k+1
       dx = x(k+1) - x(k)
       dx3 = dx / 3.0d0

       c = y(k) + dx3 * yprime(k)
       c1 =  y(k1) - dx3 * yprime(k1)

      ! mmi = min(y(k),y(k1))
      ! mma = max(y(k),y(k1))
      ! if(c  .LT. mmi .OR.  c .GT. mma) c = y(k)
      ! if(c1 .LT. mmi .OR. c1 .GT. mma) c1 = y(k1)

       inte(k1) = dx * (y(k) + y(k1) + c + c1) * 0.25d0
    end do

    return
  End subroutine bezier_cintep
END MODULE bezier_math

MODULE Bezier_solvers
  Implicit None
  !
  ! Bezier Solvers. Integrates the RTE for polarized light, assuming
  ! Bezier-Splines interpolants.
  !
  ! CONTAINS: full_cent_der    -> Aux. routine that computes derivatives of a 4xndep array.
  !           full_cent_der4   -> Aux. routine that computes derivatives of a 4x4xndep array.
  !           matinx8          -> Inverts a matrix
  !           delobezier       -> Integrates the RTE assuming a quadratic Bezier-Interpolant
  !           delobezier3      -> Integrates the RTE assuming a cubic Bezier-Interpolant
  !
  ! USAGE: the interface of this routines is identical to the other solvers in NICOLE. Same
  !        input/output variables are expected.
  !
  ! REFERENCES: de la Cruz Rodriguez & Piskunov in prep.
  !
  !
  ! Jaime de la Cruz Rodriguez (IFA-Uppsala University 2012)
  !
  ! Modifications:
  !            2012-10-04, JdlCR: Created!
  !
CONTAINS
  subroutine full_cent_der_d(n, x, y, yp, ubound, ibound)
    Implicit None
    Integer :: n, k, k1, ibound, ubound, kinit, kend
    Real :: x(n), yp(4,n), y(4, n)
    real(8) :: lambda, dx, dx1, der(4), der1(4)

    kinit = max(2, ubound)
    kend = min(n-1, ibound)

    yp = 0
    do k = kinit, kend
       dx = x(k)
       dx1 = x(k+1)

       der  = (y(:,k) - y(:,k-1)) / dx
       der1 = (y(:,k+1) - y(:,k)) / dx1

       lambda =  (1.0d0 + dx1 / (dx + dx1)) / 3.0d0
       where(der * der1 > 0.0d0)
          yp(:,k) = (der / (lambda * der1 + (1.0d0 - lambda) * der)) * der1
       end where
    end do

    if(ubound == 1) yp(:,1) = (y(:,1) - y(:,2)) / (-x(2)) ! (x(1) - x(2))
    if(ibound == n) yp(:,n) = (y(:,n-1) - y(:,n)) / (-x(n)) ! (x(n-1) - x(n))

  end subroutine full_cent_der_d
  subroutine full_cent_der(n, x, y, yp, ubound, ibound)
    Implicit None
    Integer :: n, k, k1, ibound, ubound, kinit, kend
    Real :: x(n), yp(4,n), y(4, n)
    real(8) :: lambda, dx, dx1, der(4), der1(4)

    kinit = max(2, ubound)
    kend = min(n-1, ibound)

    yp = 0
    do k = kinit, kend
       dx = x(k) - x(k-1)
       dx1 = x(k+1) - x(k)

       der  = (y(:,k) - y(:,k-1)) / dx
       der1 = (y(:,k+1) - y(:,k)) / dx1

       lambda =  (1.0d0 + dx1 / (dx + dx1)) / 3.0d0
       where(der * der1 > 0.0d0)
          yp(:,k) = (der / (lambda * der1 + (1.0d0 - lambda) * der)) * der1
       end where
    end do

    if(ubound == 1) yp(:,1) = (y(:,1) - y(:,2)) / (x(1) - x(2))
    if(ibound == n) yp(:,n) = (y(:,n-1) - y(:,n)) / (x(n-1) - x(n))

  end subroutine full_cent_der
  subroutine full_cent_der4(n, x, y, yp, ubound, ibound)
    Implicit None
    Integer :: n, k, k1, ibound, ubound, kinit, kend, i, j
    Real ::  y(n,4,4), yp(n,4,4), x(n)
    real(8) ::  lambda(n), dx, dx1, der, der1

    kinit = max(2, ubound)
    kend = min(n-1, ibound)

    yp = 0

    dx = x(kinit) - x(kinit-1)
    do k = kinit, kend
       dx1 = x(k+1) - x(k)
       lambda(k) =  (1.0d0 + dx1 / (dx + dx1)) / 3.0d0
       dx = dx1
    end do

    do j = 1,4
       do i = 1,4
          do k = kinit, kend

             der  = (y(k,i,j) - y(k-1,i,j)) / (x(k) - x(k-1))
             der1 = (y(k+1,i,j) - y(k,i,j)) / (x(k+1) - x(k))

             if(der * der1 .gt. 0.0d0) then
                yp(k,i,j) = (der / (lambda(k) * der1 + (1.0d0 - lambda(k)) * der)) * der1
             end if
          end do
       end do
    end do

    if(ubound == 1) yp(1,:,:) = (y(1,:,:) - y(2,:,:)) / (x(1) - x(2))
    if(ibound == n) yp(n,:,:) = (y(n-1,:,:) - y(n,:,:)) / (x(n-1) - x(n))

  end subroutine full_cent_der4
  subroutine full_cent_der4_d(n, x, y, yp, ubound, ibound)
    Implicit None
    Integer :: n, k, k1, ibound, ubound, kinit, kend, i, j
    Real ::  y(n,4,4), yp(n,4,4), x(n)
    real(8) ::  lambda(n), dx, dx1, der, der1

    kinit = max(2, ubound)
    kend = min(n-1, ibound)

    yp = 0

    dx = x(kinit) ! x(kinit) - x(kinit-1)
    do k = kinit, kend
       dx1 = x(k+1) ! x(k+1) - x(k)
       lambda(k) =  (1.0d0 + dx1 / (dx + dx1)) / 3.0d0
       dx = dx1
    end do

    do j = 1,4
       do i = 1,4
          do k = kinit, kend

             der  = (y(k,i,j) - y(k-1,i,j)) / x(k) ! (x(k) - x(k-1))
             der1 = (y(k+1,i,j) - y(k,i,j)) / x(k+1) ! (x(k+1) - x(k))

             if(der * der1 .gt. 0.0d0) then
                yp(k,i,j) = (der / (lambda(k) * der1 + (1.0d0 - lambda(k)) * der)) * der1
             end if
          end do
       end do
    end do

    if(ubound == 1) yp(1,:,:) = (y(1,:,:) - y(2,:,:)) / (-x(2)) ! (x(1) - x(2))
    if(ibound == n) yp(n,:,:) = (y(n-1,:,:) - y(n,:,:)) / (-x(n)) ! (x(n-1) - x(n))

  end subroutine full_cent_der4_d

  !
  ! Solvers
  !
  Subroutine delobezier3(npoints, dtau_nu, Ab, S, stokes, boundary_switch)
    USE Bezier_math
    Implicit None
    Integer :: ipoint, npoints, ibound, ii, jj, k, k1, info, ubound, boundary_switch
    Integer :: ipiv(4), myunit
    Real, dimension(npoints) :: tau_500, tau_nu, iab, S, dtau_nu
    Real, dimension(npoints, 4, 4) :: Ab, abp
    Real, dimension(4,npoints) :: sv, sp
    Real, dimension(4) :: stokes
    Real(8), dimension(4,4) :: ident,  A, tmpa, tmpb
    Real(8) :: dtau, dtau2, idtau3, dtau03, dtau3, dtau4
    Real(8) :: alpha, beta, gamma, mu, eps, ostokes(4)
    Real, Parameter :: Optically_thick = 100., Optically_thin=1.e-4

    !
    ! 4x4 Identity matrix
    !
    Data ident(:,1)/1.0d0,0.0d0,0.0d0,0.0d0/
    Data ident(:,2)/0.0d0,1.0d0,0.0d0,0.0d0/
    Data ident(:,3)/0.0d0,0.0d0,1.0d0,0.0d0/
    Data ident(:,4)/0.0d0,0.0d0,0.0d0,1.0d0/

    tau_nu(1)=0.
    do k=2, npoints
       tau_nu(k)=tau_nu(k-1)+dtau_nu(k)
    end do

    iab = ab(:,1,1)

    !
    ! Find the point for the boundary condition
    !
    ubound = 1
    ibound = npoints
    do k = 2, npoints-1
       If (Tau_Nu(k) .gt. (Optically_Thin) .and. Tau_Nu(k-1) .lt. (Optically_Thin)) &
            ubound=k-1
       If (Tau_Nu(k) .gt. (Optically_Thick) .and. Tau_Nu(k-1) .lt. (Optically_Thick)) &
            ibound=k
    End do
    if(ibound .lt. npoints) ibound = ibound + 1
    if(ubound .gt. 1) ubound = ubound - 1

    !
    ! Modified source vector
    !
    do k = max(1, ubound-1), min(npoints, ibound+1)
       do ii = 1,4
          Sv(ii,k) = ab(k,ii,1) * S(k) / iab(k)
       end do
    enddo

    !
    ! Convert K to K' (subtract diagonal and normalize to K(1,1))
    !
    do jj = 1, 4
       do ii = 1, 4
          do k = max(1, ubound-1), min(npoints, ibound+1)
             ab(k,ii,jj) = ab(k,ii,jj) / iab(k)
          enddo
       enddo
       ab(:,jj,jj) = 0.0d0 !ab(ii,ii,:) - 1.d0
    enddo

    !
    ! Set boundary condition (I=S) at ibound
    !
    ostokes(2:4)=0.0d0
    if (boundary_switch .eq. 0) then
       ostokes(1) = S(ibound) ! Boundary cond.
    else
       ostokes(1) = 0.
    endif

    !
    ! Derivatives for Ab and Sv
    !
    call full_cent_der_d(npoints, dtau_nu, Sv, sp, ubound, ibound)
    call full_cent_der4_d(npoints, tau_nu, ab, abp, ubound, ibound)

    ibound = ibound - 1

    if(ubound .GE. ibound) then
       print *, 'Error, ibound LT ubound'
       stop
    endif

    do k = ibound, ubound, -1
       k1 = k + 1

       !
       ! Compute dtau(k), ...
       !
       dtau = dtau_nu(k1) ! tau_nu(k1) - tau_nu(k)
       dtau03 = dtau / 3.0d0
       dtau2 = dtau * dtau
       dtau3 = dtau2 * dtau
       dtau4 = dtau2 * dtau2

       !
       ! Integration coeffs.
       !
       if(dtau >= 1.d-2) then ! Accurate integration
          eps = exp(-dtau)

          idtau3 = 1.0d0 / dtau3

          alpha = (-6.0d0 + 6.0d0 * dtau - 3.0d0*dtau2 + dtau3 + 6.0d0 * eps) * idtau3
          beta  = (6.d0 + (-6.0d0 - dtau*(6.0d0 + dtau*(3.d0 + dtau))) * eps) * idtau3
          gamma = 3.0d0 * (6.0d0 + (-4.0d0 + dtau)*dtau - 2.0d0 * (3.0d0+dtau)*eps) * idtau3
          mu = 3.0d0 * ( eps * (6.0d0 + dtau2 + 4.d0 * dtau) + 2.d0 * dtau - 6.d0) * idtau3
       else ! Expansion
          eps = 1.d0 - dtau + 0.5d0 * dtau2 - dtau3/6.d0 + dtau4/24.d0

          alpha = 0.25d0 * dtau - 0.05d0 * dtau2 + dtau3 / 120.d0  - dtau4 / 840.d0
          beta  = 0.25d0 * dtau - 0.20d0 * dtau2 + dtau3 / 12.0d0  - dtau4 / 42.0d0
          gamma = 0.25d0 * dtau - 0.10d0 * dtau2 + dtau3 * 0.025d0 - dtau4 / 210.d0
          mu    = 0.25d0 * dtau - 0.15d0 * dtau2 + dtau3 * 0.05d0  - dtau4 / 84.d0
       end if

       !
       ! Interval integration
       !
       tmpa =    (dtau03 * (matmul(Ab(k1,:,:), Ab(k1,:,:)) + abp(k1,:,:)  + Ab(k1,:,:))  - Ab(k1,:,:))
       tmpb =  - (dtau03 * (matmul(Ab(k,:,:),  Ab(k,:,:))  + abp(k,:,:)   + Ab(k,:,:))   + Ab(k,:,:))

       A =                  ident + alpha * Ab(k,:,:)  - gamma * tmpb ! I_b
       ostokes = matmul((eps*ident -  beta * Ab(k1,:,:) + mu    * tmpa), ostokes) + &! I_a
            matmul((beta *ident +    mu * (ident - dtau03*ab(k1,:,:))), Sv(:,k1)) + &! S_a
            matmul((alpha*ident + gamma * (ident + dtau03*Ab(k,:,:))) , Sv(:,k)) + &! S_b
            dtau03 * (gamma*sp(:,k) - mu*Sp(:,k1))! Sp_a and Sp_b

       ! Solve system AX = B with LaPack's routine. This
       ! seems to be numerically more stable than inverting the Matrix
       ! when it has singular values.  "stokes" is an input/output
       ! array.
       !
      ! call dgesv(int(4), int(1), A, int(4), ipiv, ostokes, int(4), info)

       !
       ! Alternatively use matrix inversion
       !
       call matinx8(a)
       ostokes = matmul(a, ostokes)

    End Do

    stokes = ostokes

  End Subroutine delobezier3

  Subroutine delobezier(npoints, dtau_nu, Ab, S, stokes, boundary_switch)
    USE Bezier_math
    Implicit None
    Integer :: ipoint, npoints, ibound, ii, jj, k, k1, info, ubound, boundary_switch
    Integer :: ipiv(4)
    Real, dimension(npoints) :: dtau_nu, S, iab, tau_nu, tau_500
    Real, dimension(npoints,4, 4) :: Ab, abp
    Real, dimension(4,npoints) ::  sv, opac, sp
    Real, dimension(4) :: stokes
    Real(8), dimension(4,4) :: ident, A, tmpa, tmpb
    Real(8) :: dtau, dtau1, dtau2, idtau2, eps, dtau05
    Real(8) :: alpha, beta, gamma, lambda, ostokes(4)
    Real, Parameter :: Optically_thick = 100., Optically_thin=1.e-4

    !
    ! 4x4 Identity matrix
    !
    Data ident(:,1)/1.0d0,0.0d0,0.0d0,0.0d0/
    Data ident(:,2)/0.0d0,1.0d0,0.0d0,0.0d0/
    Data ident(:,3)/0.0d0,0.0d0,1.0d0,0.0d0/
    Data ident(:,4)/0.0d0,0.0d0,0.0d0,1.0d0/

    iab = ab(:,1,1)

    !
    ! Find the point for the boundary condition
    !
    ubound = 1
    ibound = npoints

    tau_nu(1)=0.
    do k=2, npoints
       tau_nu(k)=tau_nu(k-1)+dtau_nu(k)
    end do

    do k = 2, npoints-1
       If (Tau_Nu(k) .gt. (Optically_Thin) .and. Tau_Nu(k-1) .lt. (Optically_Thin)) &
            ubound=k-1
       If (Tau_Nu(k) .gt. (Optically_Thick) .and. Tau_Nu(k-1) .lt. (Optically_Thick)) &
            ibound=k
    End do
    if(ibound .lt. npoints) ibound = ibound + 1
    if(ubound .gt. 1) ubound = ubound - 1

    !
    ! Modified source vector
    !
    do k = max(1, ubound-1), min(npoints, ibound+1)
       do ii = 1,4
          Sv(ii,k) = ab(k,ii,1) * S(k) / iab(k)
       end do
    enddo

    !
    ! Convert K to K' (subtract diagonal and normalize to K(1,1))
    !
    do jj = 1, 4
       do ii = 1, 4
          do k = max(1, ubound-1), min(npoints, ibound+1)
             ab(k,ii,jj) = ab(k,ii,jj) / iab(k)
          enddo
       enddo
       ab(:,jj,jj) = 0.0d0 !ab(ii,ii,:) - 1.d0
    enddo

    !
    ! Set boundary condition (I=S) at ibound
    !
    ostokes(2:4)=0.0d0
    if (boundary_switch .eq. 0) then
       ostokes(1) = S(ibound) ! Boundary cond.
    else
       ostokes(1) = 0.
    endif

    !
    ! Derivatives of the source function and ab matrix
    !
    call full_cent_der_d(npoints, dtau_nu, Sv, sp, ubound, ibound)
    call full_cent_der4_d(npoints, dtau_nu, ab, abp, ubound, ibound)

    ibound = ibound - 1

    do k = ibound, ubound, -1
       !
       k1 = k + 1

       !
       ! Compute dtau(k), dtau(k-1) -> dtau, dtau1 in Nik's solver
       !
       dtau = dtau_nu(k1) ! tau_nu(k1) - tau_nu(k)
       dtau05 = dtau * 0.5d0
       dtau2 = dtau * dtau
       idtau2 = 1.0d0 / dtau2

       !
       ! Terms of the RT-Bezier integral
       !
       if(dtau < 1.e-2) then ! Analytical expansion
          eps = 1.d0 - dtau + 0.5d0 * dtau2 - dtau2*dtau/6.d0 + dtau2*dtau2/24.d0

          alpha = dtau/3.d0 - dtau2/12.d0   + dtau2*dtau/60.d0
          beta  = dtau/3.d0 - dtau2*0.25d0  + dtau2*dtau*0.1d0
          gamma = dtau/3.d0 - dtau2/6.0d0   + dtau2*dtau*0.05d0
       else                  ! Accurate calculation
          eps = exp(-dtau)
          alpha = (dtau2 - 2.0d0*dtau + 2.0d0 - 2.0d0*eps) * idtau2
          beta  = (2.0d0 - (2.0d0 + 2.0d0*dtau + dtau2)*eps) * idtau2
          gamma = (2.d0*dtau - 4.0d0 + (2.d0*dtau+4.0d0)*eps) * idtau2
       endif

       gamma = gamma * 0.5d0

       !
       ! RT Integration
       !
       tmpa =    (dtau05 * (matmul(Ab(k1,:,:), Ab(k1,:,:)) + abp(k1,:,:)  + Ab(k1,:,:))  - Ab(k1,:,:))
       tmpb =  - (dtau05 * (matmul(Ab(k,:,:),  Ab(k,:,:))  + abp(k,:,:)   + Ab(k,:,:))   + Ab(k,:,:))

       A =                   ident + alpha * Ab(k,:,:)  - gamma * tmpb ! I_b terms
       ostokes = matmul((eps*ident -  beta * Ab(k1,:,:) + gamma * tmpa), ostokes) + &! I_a terms
            matmul((beta *ident + gamma * (ident - dtau05*ab(k1,:,:))) , Sv(:,k1)) + &! S_a terms
            matmul((alpha*ident + gamma * (ident + dtau05*Ab(k,:,:)))  , Sv(:,k))  &! S_b terms
            +dtau05 * gamma * (Sp(:,k) - Sp(:,k1))! Sp_a and Sp_b terms

       !
       ! Solve system AX = B with LaPack's routine. This
       ! seems to be numerically more stable than inverting the Matrix
       ! when it has singular values.  "stokes" is an input/output
       ! array.
       !
      ! call dgesv(int(4), int(1), A, int(4), ipiv, ostokes, int(4), info)

       !
       ! Alternatively use a explicit matrix inversion (uncomment lines)
       !
       call matinx8(A)
       ostokes = matmul(A,ostokes)

    End Do
    stokes = ostokes

  END Subroutine delobezier

  SUBROUTINE delobezier_scal(npoints, dtau_nu, Ab, S, stokes, boundary_switch)
    Use bezier_math
    Implicit None
    Integer :: npoints, k, k1, ibound, ubound, boundary_switch
    Real, dimension(npoints) :: dtau_nu, tau_nu, tau_500, S, iab
    Real, dimension(npoints,4,4) :: Ab
    Real, dimension(4) :: stokes
    Real(8) :: dtau, dtau1, dtau2, idtau2, eps, dtau05, I
    Real(8) :: alpha, beta, gamma, cntrl, sp(npoints)
    Real, Parameter :: Optically_thick = 100., Optically_thin=1.e-3

    iab = ab(:,1,1)

    tau_nu(1)=0.
    do k=2, npoints
       tau_nu(k)=tau_nu(k-1)+dtau_nu(k)
    end do

    !
    ! Find the point for the boundary condition
    !
    ubound = 1
    ibound = npoints

    do k = 2, npoints-1
       If (Tau_Nu(k) .gt. (Optically_Thin) .and. Tau_Nu(k-1) .lt. (Optically_Thin)) &
            ubound=k-1
       If (Tau_Nu(k) .gt. (Optically_Thick) .and. Tau_Nu(k-1) .lt. (Optically_Thick)) &
            ibound=k
    End do
    if(ibound .lt. npoints) ibound = ibound + 1
    if(ubound .gt. 1) ubound = ubound - 1

    !
    ! Source function derivatives
    !
    call cent_deriv(npoints, tau_nu, S, Sp)

    !
    ! Boundary condition
    !
    if (boundary_switch .eq. 0) then
       I = S(ibound)
    else
       I = 0.
    endif

    ibound = ibound - 1

    do k = ibound, ubound, -1
       !
       k1 = k + 1

       !
       ! Compute dtau(k), dtau(k-1) -> dtau, dtau1 in Nik's solver
       !
       dtau = dtau_nu(k1) ! tau_nu(k1) - tau_nu(k)
       dtau05 = dtau * 0.5d0
       dtau2 = dtau * dtau
       idtau2 = 1.0d0 / dtau2

       !
       ! Terms of the RT-Bezier integral
       !
       if(dtau < 1.e-2) then ! Analytical expansion
          eps = 1.d0 - dtau + 0.5d0 * dtau2 - dtau2*dtau/6.d0 + dtau2*dtau2/24.d0
          alpha = dtau/3.d0 - dtau2/12.d0   + dtau2*dtau/60.d0
          beta  = dtau/3.d0 - dtau2*0.25d0  + dtau2*dtau*0.1d0
          gamma = dtau/3.d0 - dtau2/6.0d0   + dtau2*dtau*0.05d0
       else                  ! Accurate calculation
          eps = exp(-dtau)
          alpha = (dtau2 - 2.0d0*dtau + 2.0d0 - 2.0d0*eps) * idtau2
          beta  = (2.0d0 - (2.0d0 + 2.0d0*dtau + dtau2)*eps) * idtau2
          gamma = (2.d0*dtau - 4.0d0 + (2.d0*dtau+4.0d0)*eps) * idtau2
       endif

       !
       ! Integration
       !
       cntrl = 0.5d0 * (S(k)  + dtau05*Sp(k) + S(k1) - dtau05 * Sp(k1))
       if(cntrl .GT. max(s(k), s(k1)) .OR. cntrl .LT. min(s(k), s(k1))) cntrl = S(k)

       I = I * eps + alpha * S(k) + beta * S(k1) + gamma * cntrl
    end do

    stokes = 0
    stokes(1) = I
  end SUBROUTINE delobezier_scal
  Subroutine hermite2(npoints, dtau_nu, Ab, S, stokes, boundary_switch)
    USE Bezier_math
    Implicit None
    Integer :: ipoint, npoints, ibound, ii, jj, k, k1, info, ubound, boundary_switch
    Integer :: ipiv(4)
    Real, dimension(npoints) :: dtau_nu, S, iab, tau_nu, tau_500
    Real, dimension(npoints, 4, 4) :: Ab, abp
    Real, dimension(4,npoints) ::  sv, opac, sp
    Real, dimension(4) :: stokes, Jb(4), Ja(4), sJa(4), sJb(4),  sKa(4,4), sKb(4,4)
    Real(8), dimension(4,4) :: ident, A, tmpa, tmpb, k2, D
    Real(8) :: dtau, dtau1, dtau2, idtau2, eps, dtau05
    Real(8) :: alpha, beta, gamma, lambda, ostokes(4), E(4)
    Real, Parameter :: Optically_thick = 100., Optically_thin=1.e-4

    !
    ! 4x4 Identity matrix
    !
    Data ident(:,1)/1.0d0,0.0d0,0.0d0,0.0d0/
    Data ident(:,2)/0.0d0,1.0d0,0.0d0,0.0d0/
    Data ident(:,3)/0.0d0,0.0d0,1.0d0,0.0d0/
    Data ident(:,4)/0.0d0,0.0d0,0.0d0,1.0d0/

    tau_nu(1)=0.
    do k=2, npoints
       tau_nu(k)=tau_nu(k-1)+dtau_nu(k)
    end do

    iab = ab(:,1,1)

    !
    ! Find the point for the boundary condition
    !
    ubound = 1
    ibound = npoints

    do k = 2, npoints-1
       If (Tau_Nu(k) .gt. (Optically_Thin) .and. Tau_Nu(k-1) .lt. (Optically_Thin)) &
            ubound=k-1
       If (Tau_Nu(k) .gt. (Optically_Thick) .and. Tau_Nu(k-1) .lt. (Optically_Thick)) &
            ibound=k
    End do
    if(ibound .lt. npoints) ibound = ibound + 1
    if(ubound .gt. 1) ubound = ubound - 1

    !
    ! Source function
    !
    Sv(2:4,:) = 0
    Sv(1,:) = S

       do jj = 1,4
          do ii = 1, 4
             ab(:,ii,jj) = ab(:,ii,jj) / iab
          end do
       end do

    !
    ! Set boundary condition (I=S) at ibound
    !
    ostokes(2:4)=0.0d0
    if (boundary_switch .eq. 0) then
       ostokes(1) = S(ibound) ! Boundary cond.
    else
       ostokes(1) = 0.
    endif

    !
    ! Derivatives of the source function and ab matrix
    !
    call full_cent_der_d(npoints, dtau_nu, Sv, sp, ubound, ibound)
    call full_cent_der4_d(npoints, dtau_nu, ab, abp, ubound, ibound)

    ibound = ibound - 1

    do k = ibound, ubound, -1
       !
       k1 = k + 1
       !
       ! dtau(s)
       !
       dtau = dtau_nu(k1) ! (tau_nu(k1) - tau_nu(k))
       dtau2 = dtau * dtau
       dtau05 = dtau * 0.5d0

       !
       ! at points "a" (k+1)
       !
       sKa  = matmul(ab(k1,:,:),ab(k1,:,:)) - abp(k1,:,:)
       sJa = dtau2/12.0d0 * (matmul(ab(k1,:,:), sp(:,k1)) - matmul(ska,Sv(:,k1)))
       Ja = dtau05 * matmul(ab(k1,:,:), Sv(:,k1))

       !
       ! at points "b" (k)
       !
       sKb = matmul(ab(k,:,:),ab(k,:,:)) - abp(k,:,:)
       sJb = dtau2/12.0d0 * (matmul(ab(k,:,:), sp(:,k)) - matmul(sKb,Sv(:,k)))
       Jb = dtau05 * matmul(ab(k,:,:), Sv(:,k))

       !
       ! Compute intensity
       !
       D = ident + dtau05*ab(k,:,:) + dtau2/12.d0 * sKb
       call matinx8(D)

       E = matmul(D, (Jb + Ja + sJa - sJb))
       A = matmul(D, (ident - dtau05 * ab(k1,:,:) + dtau2/12.d0 * sKa))

       ostokes = matmul(A, ostokes) + E

    END do

    stokes = ostokes
  END Subroutine hermite2
  subroutine matinx8( a )
    implicit None
    real(8) :: absmax, a(4,4), b(4,4), det, fdeta, fabsmx
    integer i , j

    absmax = 0.0d0

    absmax = maxval(abs(a))

    if ( absmax .eq. 0. ) then
       print *,'singularity problem. Zero or NaN matrix D in Hermite'

       print *,'a='
       do i = 1,4
          print *, abs(a(:,i))
       end do
       do i=1, 4
          do j=1, 4
             a(i,j)=0.
          end do
          a(i,i)=1.
       end do
    end if

    fabsmx = 1.d00 / absmax

    do i = 1 , 4
       do j = 1 , 4
          a ( i , j ) = a ( i , j ) * fabsmx
       end do
    end do

    b(1,1) = a(2,2) * a(3,3) * a(4,4) + a(2,3) * a(3,4) * a(4,2) &
         + a(2,4) * a(3,2) * a(4,3) - a(2,2) * a(3,4) * a(4,3) &
         - a(2,3) * a(3,2) * a(4,4) - a(2,4) * a(3,3) * a(4,2)
    b(2,1) = a(2,3) * a(3,1) * a(4,4) + a(2,4) * a(3,3) * a(4,1) &
         + a(2,1) * a(3,4) * a(4,3) - a(2,3) * a(3,4) * a(4,1) &
         - a(2,4) * a(3,1) * a(4,3) - a(2,1) * a(3,3) * a(4,4)
    b(3,1) = a(2,4) * a(3,1) * a(4,2) + a(2,1) * a(3,2) * a(4,4) &
         + a(2,2) * a(3,4) * a(4,1) - a(2,4) * a(3,2) * a(4,1) &
         - a(2,1) * a(3,4) * a(4,2) - a(2,2) * a(3,1) * a(4,4)
    b(4,1) = a(2,1) * a(3,3) * a(4,2) + a(2,2) * a(3,1) * a(4,3) &
         + a(2,3) * a(3,2) * a(4,1) - a(2,1) * a(3,2) * a(4,3) &
         - a(2,2) * a(3,3) * a(4,1) - a(2,3) * a(3,1) * a(4,2)
    b(1,2) = a(3,2) * a(4,4) * a(1,3) + a(3,3) * a(4,2) * a(1,4) &
         + a(3,4) * a(4,3) * a(1,2) - a(3,2) * a(4,3) * a(1,4) &
         - a(3,3) * a(4,4) * a(1,2) - a(3,4) * a(4,2) * a(1,3)
    b(2,2) = a(3,3) * a(4,4) * a(1,1) + a(3,4) * a(4,1) * a(1,3) &
         + a(3,1) * a(4,3) * a(1,4) - a(3,3) * a(4,1) * a(1,4) &
         - a(3,4) * a(4,3) * a(1,1) - a(3,1) * a(4,4) * a(1,3)
    b(3,2) = a(3,4) * a(4,2) * a(1,1) + a(3,1) * a(4,4) * a(1,2) &
         + a(3,2) * a(4,1) * a(1,4) - a(3,4) * a(4,1) * a(1,2) &
         - a(3,1) * a(4,2) * a(1,4) - a(3,2) * a(4,4) * a(1,1)
    b(4,2) = a(3,1) * a(4,2) * a(1,3) + a(3,2) * a(4,3) * a(1,1) &
         + a(3,3) * a(4,1) * a(1,2) - a(3,1) * a(4,3) * a(1,2) &
         - a(3,2) * a(4,1) * a(1,3) - a(3,3) * a(4,2) * a(1,1)
    b(1,3) = a(4,2) * a(1,3) * a(2,4) + a(4,3) * a(1,4) * a(2,2) &
         + a(4,4) * a(1,2) * a(2,3) - a(4,2) * a(1,4) * a(2,3) &
         - a(4,3) * a(1,2) * a(2,4) - a(4,4) * a(1,3) * a(2,2)
    b(2,3) = a(4,3) * a(1,1) * a(2,4) + a(4,4) * a(1,3) * a(2,1) &
         + a(4,1) * a(1,4) * a(2,3) - a(4,3) * a(1,4) * a(2,1) &
         - a(4,4) * a(1,1) * a(2,3) - a(4,1) * a(1,3) * a(2,4)
    b(3,3) = a(4,4) * a(1,1) * a(2,2) + a(4,1) * a(1,2) * a(2,4) &
         + a(4,2) * a(1,4) * a(2,1) - a(4,4) * a(1,2) * a(2,1) &
         - a(4,1) * a(1,4) * a(2,2) - a(4,2) * a(1,1) * a(2,4)
    b(4,3) = a(4,1) * a(1,3) * a(2,2) + a(4,2) * a(1,1) * a(2,3) &
         + a(4,3) * a(1,2) * a(2,1) - a(4,1) * a(1,2) * a(2,3) &
         - a(4,2) * a(1,3) * a(2,1) - a(4,3) * a(1,1) * a(2,2)
    b(1,4) = a(1,2) * a(2,4) * a(3,3) + a(1,3) * a(2,2) * a(3,4) &
         + a(1,4) * a(2,3) * a(3,2) - a(1,2) * a(2,3) * a(3,4) &
         - a(1,3) * a(2,4) * a(3,2) - a(1,4) * a(2,2) * a(3,3)
    b(2,4) = a(1,3) * a(2,4) * a(3,1) + a(1,4) * a(2,1) * a(3,3) &
         + a(1,1) * a(2,3) * a(3,4) - a(1,3) * a(2,1) * a(3,4) &
         - a(1,4) * a(2,3) * a(3,1) - a(1,1) * a(2,4) * a(3,3)
    b(3,4) = a(1,4) * a(2,2) * a(3,1) + a(1,1) * a(2,4) * a(3,2) &
         + a(1,2) * a(2,1) * a(3,4) - a(1,4) * a(2,1) * a(3,2) &
         - a(1,1) * a(2,2) * a(3,4) - a(1,2) * a(2,4) * a(3,1)
    b(4,4) = a(1,1) * a(2,2) * a(3,3) + a(1,2) * a(2,3) * a(3,1) &
         + a(1,3) * a(2,1) * a(3,2) - a(1,1) * a(2,3) * a(3,2) &
         - a(1,2) * a(2,1) * a(3,3) - a(1,3) * a(2,2) * a(3,1)

    det = a ( 1 , 1 ) * b ( 1 , 1 ) + a ( 1 , 2 ) * b ( 2 , 1 ) &
         + a ( 1 , 3 ) * b ( 3 , 1 ) + a ( 1 , 4 ) * b ( 4 , 1 )

    fdeta = fabsmx / det

    do  i = 1 , 4
       do  j = 1 , 4
          a ( i , j ) = b ( i , j ) * fdeta
       enddo
    enddo
    return
  end subroutine matinx8

END MODULE Bezier_solvers


MODULE cloud_rad

!     Cloud Radiation and Microphysics Parameters

!     Backscattering efficiencies
      real, parameter :: bksct_eff_clwc    = .063
      real, parameter :: bksct_eff_cice    = .14
      real, parameter :: bksct_eff_rain    = .063
      real, parameter :: bksct_eff_snow    = .14
      real, parameter :: bksct_eff_graupel = .30

!     Scattering efficiencies
      real, parameter :: q_clwc    = 2.0
      real, parameter :: q_cice    = 2.0
      real, parameter :: q_rain    = 1.0
      real, parameter :: q_snow    = 1.0
      real, parameter :: q_graupel = 1.0

!     Densities
      real, parameter :: rholiq     =   1e3 ! kilograms per cubic meter
      real, parameter :: rhosnow    = .07e3 ! kilograms per cubic meter
      real, parameter :: rhograupel = .50e3 ! kilograms per cubic meter

!     Effective radii
      real, parameter :: reff_clwc    = .000007 ! m
      real, parameter :: reff_cice    = .000034 ! m
      real, parameter :: reff_rain    = .000750 ! m
      real, parameter :: reff_snow    = .004000 ! m
      real, parameter :: reff_graupel = .010000 ! m

!     GHI related
      real, parameter :: ghi_zen_toa = 1361.5 ! solar const, W/m**2 at 1AU
      real, parameter :: zen_kt = 0.815       ! zenithal attenuation of GHI

      PUBLIC albedo_to_clouds, albedo_to_clouds2

CONTAINS
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     subroutine albedo_to_clouds(albedo                                  & ! I
                                ,cloud_rad_trans,cloud_od,cloud_opacity)   ! O

        use mem_namelist, ONLY: r_missing_data

        clear_albedo = .2097063
        cloud_albedo = .4485300
!       cloud_albedo = .40

        if(albedo .eq. r_missing_data)then
            cloud_rad_trans = r_missing_data
            cloud_od = r_missing_data
            cloud_opacity = r_missing_data
            return
        endif

!       Uniform clouds are presently assumed in the grid box or cloud layer
        cloud_frac = 1.0

        arg = albedo

        call stretch2(clear_albedo,cloud_albedo,0.,1.,arg)

        cloud_albedo = min(arg,0.99999)      ! Back Scattered

        cloud_rad_trans = 1.0 - cloud_albedo ! Fwd Scattered + Direct Transmission

        bksc_eff_od = -log(cloud_rad_trans)  ! Tau * Back Scat Efficiency

        cloud_od = bksc_eff_od / 0.10        ! Tau

        cloud_opacity = 1.0 - exp(-cloud_od) ! 1 - Direct Transmission

        return

     END subroutine albedo_to_clouds

     subroutine albedo_to_clouds2(albedo                                 & ! I
                                 ,cloud_trans_l,cloud_trans_i            & ! O
                                 ,cloud_od_l,cloud_od_i                  & ! O
                                 ,cloud_opac_l,cloud_opac_i)               ! O

        use mem_namelist, ONLY: r_missing_data

        if(albedo .eq. r_missing_data)then
            cloud_trans_l = r_missing_data
            cloud_trans_i = r_missing_data
            cloud_od_l = r_missing_data
            cloud_od_i = r_missing_data
            cloud_opac_l = r_missing_data
            cloud_opac_i = r_missing_data
            return
        endif

        cloud_albedo = min(albedo,0.99999)     ! Back Scattered

        cloud_trans_l = 1.0 - cloud_albedo     ! Fwd Scattered + Direct Transmission
        cloud_trans_i = 1.0 - cloud_albedo     ! Fwd Scattered + Direct Transmission

        cloud_od_l = cloud_albedo / (bksct_eff_clwc * (1.-cloud_albedo)) ! Tau
        cloud_od_i = cloud_albedo / (bksct_eff_cice * (1.-cloud_albedo)) ! Tau

        cloud_opac_l = 1.0 - exp(-cloud_od_l) ! 1 - Direct Transmission
        cloud_opac_i = 1.0 - exp(-cloud_od_i) ! 1 - Direct Transmission

        return

     END subroutine albedo_to_clouds2

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

END MODULE cloud_rad


submodule(forlab_sorting) forlab_sorting_argsort

    implicit none

contains

    module procedure argsort_int8
    integer::i, n
    integer(int8), allocatable::xsort(:)
    integer::order1
    n = size(x)
    xsort = x
    argsort_int8 = [(i, i=1, n)]
    if (.not. present(order)) then
        order1 = 1
    else
        order1 = order
    end if
    call quickargsort_int8(xsort, argsort_int8, n, order1)
    end procedure argsort_int8
    recursive subroutine quickargsort_int8(x, idx, n, order)
        integer(int8), dimension(n), intent(inout) :: x
        integer, dimension(n), intent(inout) :: idx
        integer, intent(in) :: n, order
        integer:: left, right, marker
        integer(int8) :: pivot, tmp1
        integer::tmp2
        if (n > 1) then
            left = 0
            right = n + 1
            pivot = x(randu(1, n))
            select case (order)
            case (1)
                do while (left < right)
                    left = left + 1
                    right = right - 1
                    do while (x(left) < pivot)
                        left = left + 1
                    end do
                    do while (x(right) > pivot)
                        right = right - 1
                    end do
                    if (left < right) then
                        tmp1 = x(left)
                        x(left) = x(right)
                        x(right) = tmp1
                        tmp2 = idx(left)
                        idx(left) = idx(right)
                        idx(right) = tmp2
                    end if
                end do
            case (2)
                do while (left < right)
                    left = left + 1
                    right = right - 1
                    do while (x(left) > pivot)
                        left = left + 1
                    end do
                    do while (x(right) < pivot)
                        right = right - 1
                    end do
                    if (left < right) then
                        tmp1 = x(left)
                        x(left) = x(right)
                        x(right) = tmp1
                        tmp2 = idx(left)
                        idx(left) = idx(right)
                        idx(right) = tmp2
                    end if
                end do
            case default
                error stop "Error:Sort order MUST be 1 or 2"
            end select
            if (left == right) then
                marker = left + 1
            else
                marker = left
            end if
            call quickargsort_int8(x(:marker - 1), idx(:marker - 1), marker - 1, order)
            call quickargsort_int8(x(marker:), idx(marker:), n - marker + 1, order)
        end if
    end subroutine quickargsort_int8
    module procedure argsort_int16
    integer::i, n
    integer(int16), allocatable::xsort(:)
    integer::order1
    n = size(x)
    xsort = x
    argsort_int16 = [(i, i=1, n)]
    if (.not. present(order)) then
        order1 = 1
    else
        order1 = order
    end if
    call quickargsort_int16(xsort, argsort_int16, n, order1)
    end procedure argsort_int16
    recursive subroutine quickargsort_int16(x, idx, n, order)
        integer(int16), dimension(n), intent(inout) :: x
        integer, dimension(n), intent(inout) :: idx
        integer, intent(in) :: n, order
        integer:: left, right, marker
        integer(int16) :: pivot, tmp1
        integer::tmp2
        if (n > 1) then
            left = 0
            right = n + 1
            pivot = x(randu(1, n))
            select case (order)
            case (1)
                do while (left < right)
                    left = left + 1
                    right = right - 1
                    do while (x(left) < pivot)
                        left = left + 1
                    end do
                    do while (x(right) > pivot)
                        right = right - 1
                    end do
                    if (left < right) then
                        tmp1 = x(left)
                        x(left) = x(right)
                        x(right) = tmp1
                        tmp2 = idx(left)
                        idx(left) = idx(right)
                        idx(right) = tmp2
                    end if
                end do
            case (2)
                do while (left < right)
                    left = left + 1
                    right = right - 1
                    do while (x(left) > pivot)
                        left = left + 1
                    end do
                    do while (x(right) < pivot)
                        right = right - 1
                    end do
                    if (left < right) then
                        tmp1 = x(left)
                        x(left) = x(right)
                        x(right) = tmp1
                        tmp2 = idx(left)
                        idx(left) = idx(right)
                        idx(right) = tmp2
                    end if
                end do
            case default
                error stop "Error:Sort order MUST be 1 or 2"
            end select
            if (left == right) then
                marker = left + 1
            else
                marker = left
            end if
            call quickargsort_int16(x(:marker - 1), idx(:marker - 1), marker - 1, order)
            call quickargsort_int16(x(marker:), idx(marker:), n - marker + 1, order)
        end if
    end subroutine quickargsort_int16
    module procedure argsort_int32
    integer::i, n
    integer(int32), allocatable::xsort(:)
    integer::order1
    n = size(x)
    xsort = x
    argsort_int32 = [(i, i=1, n)]
    if (.not. present(order)) then
        order1 = 1
    else
        order1 = order
    end if
    call quickargsort_int32(xsort, argsort_int32, n, order1)
    end procedure argsort_int32
    recursive subroutine quickargsort_int32(x, idx, n, order)
        integer(int32), dimension(n), intent(inout) :: x
        integer, dimension(n), intent(inout) :: idx
        integer, intent(in) :: n, order
        integer:: left, right, marker
        integer(int32) :: pivot, tmp1
        integer::tmp2
        if (n > 1) then
            left = 0
            right = n + 1
            pivot = x(randu(1, n))
            select case (order)
            case (1)
                do while (left < right)
                    left = left + 1
                    right = right - 1
                    do while (x(left) < pivot)
                        left = left + 1
                    end do
                    do while (x(right) > pivot)
                        right = right - 1
                    end do
                    if (left < right) then
                        tmp1 = x(left)
                        x(left) = x(right)
                        x(right) = tmp1
                        tmp2 = idx(left)
                        idx(left) = idx(right)
                        idx(right) = tmp2
                    end if
                end do
            case (2)
                do while (left < right)
                    left = left + 1
                    right = right - 1
                    do while (x(left) > pivot)
                        left = left + 1
                    end do
                    do while (x(right) < pivot)
                        right = right - 1
                    end do
                    if (left < right) then
                        tmp1 = x(left)
                        x(left) = x(right)
                        x(right) = tmp1
                        tmp2 = idx(left)
                        idx(left) = idx(right)
                        idx(right) = tmp2
                    end if
                end do
            case default
                error stop "Error:Sort order MUST be 1 or 2"
            end select
            if (left == right) then
                marker = left + 1
            else
                marker = left
            end if
            call quickargsort_int32(x(:marker - 1), idx(:marker - 1), marker - 1, order)
            call quickargsort_int32(x(marker:), idx(marker:), n - marker + 1, order)
        end if
    end subroutine quickargsort_int32
    module procedure argsort_int64
    integer::i, n
    integer(int64), allocatable::xsort(:)
    integer::order1
    n = size(x)
    xsort = x
    argsort_int64 = [(i, i=1, n)]
    if (.not. present(order)) then
        order1 = 1
    else
        order1 = order
    end if
    call quickargsort_int64(xsort, argsort_int64, n, order1)
    end procedure argsort_int64
    recursive subroutine quickargsort_int64(x, idx, n, order)
        integer(int64), dimension(n), intent(inout) :: x
        integer, dimension(n), intent(inout) :: idx
        integer, intent(in) :: n, order
        integer:: left, right, marker
        integer(int64) :: pivot, tmp1
        integer::tmp2
        if (n > 1) then
            left = 0
            right = n + 1
            pivot = x(randu(1, n))
            select case (order)
            case (1)
                do while (left < right)
                    left = left + 1
                    right = right - 1
                    do while (x(left) < pivot)
                        left = left + 1
                    end do
                    do while (x(right) > pivot)
                        right = right - 1
                    end do
                    if (left < right) then
                        tmp1 = x(left)
                        x(left) = x(right)
                        x(right) = tmp1
                        tmp2 = idx(left)
                        idx(left) = idx(right)
                        idx(right) = tmp2
                    end if
                end do
            case (2)
                do while (left < right)
                    left = left + 1
                    right = right - 1
                    do while (x(left) > pivot)
                        left = left + 1
                    end do
                    do while (x(right) < pivot)
                        right = right - 1
                    end do
                    if (left < right) then
                        tmp1 = x(left)
                        x(left) = x(right)
                        x(right) = tmp1
                        tmp2 = idx(left)
                        idx(left) = idx(right)
                        idx(right) = tmp2
                    end if
                end do
            case default
                error stop "Error:Sort order MUST be 1 or 2"
            end select
            if (left == right) then
                marker = left + 1
            else
                marker = left
            end if
            call quickargsort_int64(x(:marker - 1), idx(:marker - 1), marker - 1, order)
            call quickargsort_int64(x(marker:), idx(marker:), n - marker + 1, order)
        end if
    end subroutine quickargsort_int64
    module procedure argsort_sp
    integer::i, n
    real(sp), allocatable::xsort(:)
    integer::order1
    n = size(x)
    xsort = x
    argsort_sp = [(i, i=1, n)]
    if (.not. present(order)) then
        order1 = 1
    else
        order1 = order
    end if
    call quickargsort_sp(xsort, argsort_sp, n, order1)
    end procedure argsort_sp
    recursive subroutine quickargsort_sp(x, idx, n, order)
        real(sp), dimension(n), intent(inout) :: x
        integer, dimension(n), intent(inout) :: idx
        integer, intent(in) :: n, order
        integer:: left, right, marker
        real(sp) :: pivot, tmp1
        integer::tmp2
        if (n > 1) then
            left = 0
            right = n + 1
            pivot = x(randu(1, n))
            select case (order)
            case (1)
                do while (left < right)
                    left = left + 1
                    right = right - 1
                    do while (x(left) < pivot)
                        left = left + 1
                    end do
                    do while (x(right) > pivot)
                        right = right - 1
                    end do
                    if (left < right) then
                        tmp1 = x(left)
                        x(left) = x(right)
                        x(right) = tmp1
                        tmp2 = idx(left)
                        idx(left) = idx(right)
                        idx(right) = tmp2
                    end if
                end do
            case (2)
                do while (left < right)
                    left = left + 1
                    right = right - 1
                    do while (x(left) > pivot)
                        left = left + 1
                    end do
                    do while (x(right) < pivot)
                        right = right - 1
                    end do
                    if (left < right) then
                        tmp1 = x(left)
                        x(left) = x(right)
                        x(right) = tmp1
                        tmp2 = idx(left)
                        idx(left) = idx(right)
                        idx(right) = tmp2
                    end if
                end do
            case default
                error stop "Error:Sort order MUST be 1 or 2"
            end select
            if (left == right) then
                marker = left + 1
            else
                marker = left
            end if
            call quickargsort_sp(x(:marker - 1), idx(:marker - 1), marker - 1, order)
            call quickargsort_sp(x(marker:), idx(marker:), n - marker + 1, order)
        end if
    end subroutine quickargsort_sp
    module procedure argsort_dp
    integer::i, n
    real(dp), allocatable::xsort(:)
    integer::order1
    n = size(x)
    xsort = x
    argsort_dp = [(i, i=1, n)]
    if (.not. present(order)) then
        order1 = 1
    else
        order1 = order
    end if
    call quickargsort_dp(xsort, argsort_dp, n, order1)
    end procedure argsort_dp
    recursive subroutine quickargsort_dp(x, idx, n, order)
        real(dp), dimension(n), intent(inout) :: x
        integer, dimension(n), intent(inout) :: idx
        integer, intent(in) :: n, order
        integer:: left, right, marker
        real(dp) :: pivot, tmp1
        integer::tmp2
        if (n > 1) then
            left = 0
            right = n + 1
            pivot = x(randu(1, n))
            select case (order)
            case (1)
                do while (left < right)
                    left = left + 1
                    right = right - 1
                    do while (x(left) < pivot)
                        left = left + 1
                    end do
                    do while (x(right) > pivot)
                        right = right - 1
                    end do
                    if (left < right) then
                        tmp1 = x(left)
                        x(left) = x(right)
                        x(right) = tmp1
                        tmp2 = idx(left)
                        idx(left) = idx(right)
                        idx(right) = tmp2
                    end if
                end do
            case (2)
                do while (left < right)
                    left = left + 1
                    right = right - 1
                    do while (x(left) > pivot)
                        left = left + 1
                    end do
                    do while (x(right) < pivot)
                        right = right - 1
                    end do
                    if (left < right) then
                        tmp1 = x(left)
                        x(left) = x(right)
                        x(right) = tmp1
                        tmp2 = idx(left)
                        idx(left) = idx(right)
                        idx(right) = tmp2
                    end if
                end do
            case default
                error stop "Error:Sort order MUST be 1 or 2"
            end select
            if (left == right) then
                marker = left + 1
            else
                marker = left
            end if
            call quickargsort_dp(x(:marker - 1), idx(:marker - 1), marker - 1, order)
            call quickargsort_dp(x(marker:), idx(marker:), n - marker + 1, order)
        end if
    end subroutine quickargsort_dp

end submodule forlab_sorting_argsort


** Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
** See https://llvm.org/LICENSE.txt for license information.
** SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

*   INTRINSIC statements.

C  Tests:
C   (1) generic in INTRINSIC stmt doesn't remove generic property.
C   (2) intrinsic in INTRINSIC stmt passed as argument.

	intrinsic iabs
	integer rslts(3), expect(3)
	intrinsic sngl, dprod, or, dfloat
	intrinsic int

        data expect / 2, 7, 7 /

	rslts(1) = int(2.9D0)

	call sub(iabs, ires)
	rslts(2) = ires

	call sub2(dprod, ires)
	rslts(3) = ires

	call check(rslts, expect, 3)
	end
CCCCC
	subroutine sub(ifunc, iout)
	iout = ifunc(-7)
	end
CCCCC
	subroutine sub2(dfunc, iout)
	double precision dfunc
	iout = dfunc(2.35E0, 3.0E0)
	end


program main
    use,intrinsic :: iso_fortran_env
    use mod_runtime_parameters, only : class_runtime_parameters
    implicit none
    type(class_runtime_parameters) :: crp
    character(len=20) :: runtime_parameters_filename
    integer(int32) :: ierror
    !integer(int32) :: it,sit
    !real(real64) :: time

    ! pre-process
    print *,'input run-time parameters file name'
    read(input_unit,*) runtime_parameters_filename
    call crp%read_runtime_parameters(runtime_parameters_filename,ierror)
    if(ierror/=0) error stop
!    call select_procedures
!    call generate_grid
!    call set_flowfield(time)
!    call output_flowfield
!
!    ! main process
!    time_marching : do it = 1, max_it
!        subiteration : do si = 1, max_si
!            call calc_variables
!            call set_boundary_conditions
!            call evaluate_right_hand_side
!            call solve_equations
!        end do subiteration
!        if(mod(it,interval_of_flowfield_output)==0) call output_flowfield
!        if(time>=time_limit) exit
!    end do time_marching
!
!    ! post-process
!    call output_flowfield

end program main


      PROGRAM xellpi
C     driver for routine ellpi
      REAL FAC
      PARAMETER (FAC=3.1415926535/180.)
      INTEGER i,nval
      REAL ak,alpha,ellpi,en,phi,value
      CHARACTER text*37
      open(7,file='FNCVAL.DAT',status='OLD')
10    read(7,'(a)') text
      if (text.ne.'Legendre Elliptic Integral Third Kind') goto 10
      read(7,*) nval
      write(*,*) text
      write(*,'(1x,t4,a3,t10,a3,t15,a10,t29,a6,t47,a16)')
     *     'PHI','-EN','SIN(ALPHA)','Actual','ELLPI(PHI,EN,AK)'
      do 11 i=1,nval
        read(7,*) phi,en,alpha,value
        alpha=alpha*FAC
        ak=sin(alpha)
        en=-en
        phi=phi*FAC
        write(*,'(3f6.2,2e20.6)') phi,en,ak,value,ellpi(phi,en,ak)
11    continue
      close(7)
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xellpi.for