MODULE bcset_0_module

  use rgrid_module, only: Igrid
  use parallel_module
  use bc_variables
  use watch_module, only: watchb_omp, time_bcfd
  use omp_variables, only: partition_job_omp

  implicit none

  PRIVATE
  PUBLIC :: bcset_0

CONTAINS

  SUBROUTINE bcset_0( ib1, ib2, ndepth, idir )

    implicit none
    integer,intent(IN) :: ib1,ib2,ndepth,idir
    integer :: a1,a2,a3,b1,b2,b3,nb,ns,ms,mt
    integer :: m,n,ndata,i1,i2,i3,ib,ierr
    integer :: c1,c2,c3,c4,d1,d2,d3,d4,irank,nreq,itags,itagr,ireq(36)
    integer :: i,l,e1,e2,e3,f1,f2,f3,fe1,fe12,fe123,dc1,dc12,dc123
    integer :: istatus(mpi_status_size,123)
    real(8) :: ttmp(2),ttmp_bc(2)

    !call watchb_omp( ttmp_bc )

    a1 = Igrid(1,1)
    b1 = Igrid(2,1)
    a2 = Igrid(1,2)
    b2 = Igrid(2,2)
    a3 = Igrid(1,3)
    b3 = Igrid(2,3)

    nb = ib2 - ib1 + 1

!$OMP master
    nreq=0
!$OMP end master

    n = 1

!(1) [sender][2]-->[1][receiver]

    !call watchb_omp( ttmp )

!$OMP master
    ndata = fdinfo_recv(10,n,1)*nb
    !if ( ndata < 1 ) write(*,*) "bbb"
    irank = fdinfo_recv(8,n,1)
    itagr = 10
    nreq  = nreq + 1
    call mpi_irecv(rbuf(1,n,1),ndata,TYPE_MAIN,irank,itagr &
                  ,comm_grid,ireq(nreq),ierr)
!$OMP end master

    !call watchb_omp( ttmp, time_bcfd(1,1) )

    c1    = b1
    d1    = b1
    ndata = fdinfo_send(10,n,2)*nb
    !if ( ndata < 1 ) write(*,*) "ccc"

    c2 = fdinfo_send(3,n,2)
    d2 = fdinfo_send(4,n,2)
    c3 = fdinfo_send(5,n,2)
    d3 = fdinfo_send(6,n,2)
    c4 = ib1
    d4 = ib2

    e1 = c1
    f1 = d1
    e2 = c2
    f2 = d2
    e3 = c3
    f3 = d3

    fe1 = f1-e1+1
    fe12 = fe1*(f2-e2+1)
    fe123 = fe12*(f3-e3+1)

    call partition_job_omp( c1,d1,c2,d2,c3,d3,c4,d4 )

    !call watchb_omp( ttmp, time_bcfd(1,7) )

    do ib=c4,d4
       do i3=c3,d3
       do i2=c2,d2
       do i1=c1,d1
          i = 1+(i1-e1)+(i2-e2)*fe1+(i3-e3)*fe12+(ib-ib1)*fe123
          sbuf(i,n,2)=www(i1,i2,i3,ib)
       end do
       end do
       end do
    end do ! ib
!$OMP barrier

    !call watchb_omp( ttmp, time_bcfd(1,3) )

!$OMP master
    irank = fdinfo_send(7,n,2)
    itags = 10
    nreq  = nreq + 1
    call mpi_isend(sbuf(1,n,2),ndata,TYPE_MAIN,irank,itags &
                  ,comm_grid,ireq(nreq),ierr)
!$OMP end master

    !call watchb_omp( ttmp, time_bcfd(1,2) )

!(3) [sender][4]-->[3][receiver]

!$OMP master
    ndata = fdinfo_recv(10,n,3)*nb
    !if ( ndata < 1 ) write(*,*) "bbb"
    irank = fdinfo_recv(8,n,3)
    itagr = 30
    nreq  = nreq + 1
    call mpi_irecv(rbuf(1,n,3),ndata,TYPE_MAIN,irank,itagr &
                  ,comm_grid,ireq(nreq),ierr)
!$OMP end master

    !call watchb_omp( ttmp, time_bcfd(1,1) )

    c2    = b2
    d2    = b2
    ndata = fdinfo_send(10,n,4)*nb
    !if ( ndata < 1 ) write(*,*) "ccc"

    c1 = fdinfo_send(1,n,4)
    d1 = fdinfo_send(2,n,4)
    c3 = fdinfo_send(5,n,4)
    d3 = fdinfo_send(6,n,4)
    c4 = ib1
    d4 = ib2

    e1 = c1
    f1 = d1
    e2 = c2
    f2 = d2
    e3 = c3
    f3 = d3

    fe1 = f1-e1+1
    fe12 = fe1*(f2-e2+1)
    fe123 = fe12*(f3-e3+1)

    call partition_job_omp( c1,d1,c2,d2,c3,d3,c4,d4 )

    !call watchb_omp( ttmp, time_bcfd(1,7) )

    do ib=c4,d4
       do i3=c3,d3
       do i2=c2,d2
       do i1=c1,d1
          i = 1+(i1-e1)+(i2-e2)*fe1+(i3-e3)*fe12+(ib-ib1)*fe123
          sbuf(i,n,4)=www(i1,i2,i3,ib)
       end do
       end do
       end do
    end do ! ib
!$OMP barrier

    !call watchb_omp( ttmp, time_bcfd(1,3) )

!$OMP master
    irank = fdinfo_send(7,n,4)
    itags = 30
    nreq  = nreq + 1
    call mpi_isend(sbuf(1,n,4),ndata,TYPE_MAIN,irank,itags &
                  ,comm_grid,ireq(nreq),ierr)
!$OMP end master

    !call watchb_omp( ttmp, time_bcfd(1,2) )

!(5) [sender][6]-->[5][receiver]

!$OMP master
    ndata = fdinfo_recv(10,n,5)*nb
    !if ( ndata < 1 ) write(*,*) "bbb"
    irank = fdinfo_recv(8,n,5)
    itagr = 50
    nreq  = nreq + 1
    call mpi_irecv(rbuf(1,n,5),ndata,TYPE_MAIN,irank,itagr &
                  ,comm_grid,ireq(nreq),ierr)
!$OMP end master

    !call watchb_omp( ttmp, time_bcfd(1,1) )

    c3    = b3
    d3    = b3
    ndata = fdinfo_send(10,n,6)*nb
    !if ( ndata < 1 ) write(*,*) "ccc"

    c1 = fdinfo_send(1,n,6)
    d1 = fdinfo_send(2,n,6)
    c2 = fdinfo_send(3,n,6)
    d2 = fdinfo_send(4,n,6)
    c4 = ib1
    d4 = ib2

    e1 = c1
    f1 = d1
    e2 = c2
    f2 = d2
    e3 = c3
    f3 = d3

    fe1 = f1-e1+1
    fe12 = fe1*(f2-e2+1)
    fe123 = fe12*(f3-e3+1)

    call partition_job_omp( c1,d1,c2,d2,c3,d3,c4,d4 )

    !call watchb_omp( ttmp, time_bcfd(1,7) )

    do ib=c4,d4
       do i3=c3,d3
       do i2=c2,d2
       do i1=c1,d1
          i = 1+(i1-e1)+(i2-e2)*fe1+(i3-e3)*fe12+(ib-ib1)*fe123
          sbuf(i,n,6)=www(i1,i2,i3,ib)
       end do
       end do
       end do
    end do ! ib
!$OMP barrier

    !call watchb_omp( ttmp, time_bcfd(1,3) )

!$OMP master
    irank = fdinfo_send(7,n,6)
    itags = 50
    nreq  = nreq + 1
    call mpi_isend(sbuf(1,n,6),ndata,TYPE_MAIN,irank,itags &
                  ,comm_grid,ireq(nreq),ierr)
!$OMP end master

    !call watchb_omp( ttmp, time_bcfd(1,2) )

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

!(2) [receiver][2]<--[1][sender]

!$OMP master
    ndata = fdinfo_recv(10,n,2)*nb
    !if ( ndata < 1 ) write(*,*) "bbb"
    irank = fdinfo_recv(8,n,2)
    itagr = 20
    nreq  = nreq + 1
    call mpi_irecv(rbuf(1,n,2),ndata,TYPE_MAIN,irank,itagr &
                  ,comm_grid,ireq(nreq),ierr)
!$OMP end master

    !call watchb_omp( ttmp, time_bcfd(1,1) )

    c1    = a1
    d1    = a1
    ndata = fdinfo_send(10,n,1)*nb
    !if ( ndata < 1 ) write(*,*) "ccc"

    c2 = fdinfo_send(3,n,1)
    d2 = fdinfo_send(4,n,1)
    c3 = fdinfo_send(5,n,1)
    d3 = fdinfo_send(6,n,1)
    c4 = ib1
    d4 = ib2

    e1 = c1
    f1 = d1
    e2 = c2
    f2 = d2
    e3 = c3
    f3 = d3

    fe1 = f1-e1+1
    fe12 = fe1*(f2-e2+1)
    fe123 = fe12*(f3-e3+1)

    call partition_job_omp( c1,d1,c2,d2,c3,d3,c4,d4 )

    !call watchb_omp( ttmp, time_bcfd(1,7) )

    do ib=c4,d4
       do i3=c3,d3
       do i2=c2,d2
       do i1=c1,d1
          i = 1+(i1-e1)+(i2-e2)*fe1+(i3-e3)*fe12+(ib-ib1)*fe123
          sbuf(i,n,1)=www(i1,i2,i3,ib)
       end do
       end do
       end do
    end do ! ib
!$OMP barrier

    !call watchb_omp( ttmp, time_bcfd(1,3) )

!$OMP master
    irank = fdinfo_send(7,n,1)
    itags = 20
    nreq  = nreq + 1
    call mpi_isend(sbuf(1,n,1),ndata,TYPE_MAIN,irank,itags &
                  ,comm_grid,ireq(nreq),ierr)
!$OMP end master

    !call watchb_omp( ttmp, time_bcfd(1,2) )

!(4) [receiver][4]<--[3][sender]

!$OMP master
    ndata = fdinfo_recv(10,n,4)*nb
    !if ( ndata < 1 ) write(*,*) "bbb"
    irank = fdinfo_recv(8,n,4)
    itagr = 40
    nreq  = nreq + 1
    call mpi_irecv(rbuf(1,n,4),ndata,TYPE_MAIN,irank,itagr &
                  ,comm_grid,ireq(nreq),ierr)
!$OMP end master

    !call watchb_omp( ttmp, time_bcfd(1,1) )

    c2    = a2
    d2    = a2
    ndata = fdinfo_send(10,n,3)*nb
    !if ( ndata < 1 ) write(*,*) "ccc"

    c1 = fdinfo_send(1,n,3)
    d1 = fdinfo_send(2,n,3)
    c3 = fdinfo_send(5,n,3)
    d3 = fdinfo_send(6,n,3)
    c4 = ib1
    d4 = ib2

    e1 = c1
    f1 = d1
    e2 = c2
    f2 = d2
    e3 = c3
    f3 = d3

    fe1 = f1-e1+1
    fe12 = fe1*(f2-e2+1)
    fe123 = fe12*(f3-e3+1)

    call partition_job_omp( c1,d1,c2,d2,c3,d3,c4,d4 )

    !call watchb_omp( ttmp, time_bcfd(1,7) )

    do ib=c4,d4
       do i3=c3,d3
       do i2=c2,d2
       do i1=c1,d1
          i = 1+(i1-e1)+(i2-e2)*fe1+(i3-e3)*fe12+(ib-ib1)*fe123
          sbuf(i,n,3)=www(i1,i2,i3,ib)
       end do
       end do
       end do
    end do ! ib
!$OMP barrier

    !call watchb_omp( ttmp, time_bcfd(1,3) )

!$OMP master
    irank = fdinfo_send(7,n,3)
    itags = 40
    nreq  = nreq + 1
    call mpi_isend(sbuf(1,n,3),ndata,TYPE_MAIN,irank,itags &
                  ,comm_grid,ireq(nreq),ierr)
!$OMP end master

    !call watchb_omp( ttmp, time_bcfd(1,2) )

!(6) [receiver][6]<--[5][sender]

!$OMP master
    ndata = fdinfo_recv(10,n,6)*nb
    !if ( ndata < 1 ) write(*,*) "bbb"
    irank = fdinfo_recv(8,n,6)
    itagr = 60
    nreq  = nreq + 1
    call mpi_irecv(rbuf(1,n,6),ndata,TYPE_MAIN,irank,itagr &
                  ,comm_grid,ireq(nreq),ierr)
!$OMP end master

    !call watchb_omp( ttmp, time_bcfd(1,1) )

    c3    = a3
    d3    = a3
    ndata = fdinfo_send(10,n,5)*nb
    !if ( ndata < 1 ) write(*,*) "ccc"

    c1 = fdinfo_send(1,n,5)
    d1 = fdinfo_send(2,n,5)
    c2 = fdinfo_send(3,n,5)
    d2 = fdinfo_send(4,n,5)
    c4 = ib1
    d4 = ib2

    e1 = c1
    f1 = d1
    e2 = c2
    f2 = d2
    e3 = c3
    f3 = d3

    fe1 = f1-e1+1
    fe12 = fe1*(f2-e2+1)
    fe123 = fe12*(f3-e3+1)

    call partition_job_omp( c1,d1,c2,d2,c3,d3,c4,d4 )

    !call watchb_omp( ttmp, time_bcfd(1,7) )

    do ib=c4,d4
       do i3=c3,d3
       do i2=c2,d2
       do i1=c1,d1
          i = 1+(i1-e1)+(i2-e2)*fe1+(i3-e3)*fe12+(ib-ib1)*fe123
          sbuf(i,n,5)=www(i1,i2,i3,ib)
       end do
       end do
       end do
    end do ! ib
!$OMP barrier

    !call watchb_omp( ttmp, time_bcfd(1,3) )

!$OMP master
    irank = fdinfo_send(7,n,5)
    itags = 60
    nreq  = nreq + 1
    call mpi_isend(sbuf(1,n,5),ndata,TYPE_MAIN,irank,itags &
                  ,comm_grid,ireq(nreq),ierr)
!$OMP end master

    !call watchb_omp( ttmp, time_bcfd(1,2) )

!$OMP master
    call mpi_waitall(nreq,ireq,istatus,ierr) ; nreq=0
!$OMP end master
!$OMP barrier

    !call watchb_omp( ttmp, time_bcfd(1,4) )

    do m=1,6

       c1=fdinfo_recv(1,n,m)
       d1=fdinfo_recv(2,n,m)
       c2=fdinfo_recv(3,n,m)
       d2=fdinfo_recv(4,n,m)
       c3=fdinfo_recv(5,n,m)
       d3=fdinfo_recv(6,n,m)

       select case(m)
       case(1)
          c1=a1-1
          d1=c1
       case(2)
          c1=b1+1
          d1=c1
       case(3)
          c2=a2-1
          d2=c2
       case(4)
          c2=b2+1
          d2=c2
       case(5)
          c3=a3-1
          d3=c3
       case(6)
          c3=b3+1
          d3=c3
       end select

       dc1 = d1-c1+1
       dc12 = dc1*(d2-c2+1)
       dc123 = dc12*(d3-c3+1)

       do ib=ib1,ib2
!$OMP do
          do i3=c3,d3
          do i2=c2,d2
          do i1=c1,d1
!             i = 1 + i1-c1 + (i2-c2)*(d1-c1+1) &
!                   + (i3-c3)*(d1-c1+1)*(d2-c2+1) &
!                   + (ib-ib1)*(d1-c1+1)*(d2-c2+1)*(d3-c3+1)
             i=1+(i1-c1)+(i2-c2)*dc1+(i3-c3)*dc12+(ib-ib1)*dc123
             www(i1,i2,i3,ib)=rbuf(i,n,m)
          end do
          end do
          end do
!$OMP end do
       end do ! ib

    end do ! m

    !call watchb_omp( ttmp, time_bcfd(1,5) )
    !call watchb_omp( ttmp_bc, time_bcfd(1,6) )

    return

  END SUBROUTINE bcset_0

END MODULE bcset_0_module


!-----------------------------------------------------------------------
!     Module:        beams3d_randomize_particles
!     Authors:       S. Lazerson (samuel.lazerson@ipp.mpg.de)
!     Date:          05/07/2020
!     Description:   This subroutine radomizes the particles so that
!                    no processor follows only slow or fast particles.
!-----------------------------------------------------------------------
      SUBROUTINE beams3d_randomize_particles
!-----------------------------------------------------------------------
!     Libraries
!-----------------------------------------------------------------------
      USE stel_kinds, ONLY: rprec
      USE beams3d_lines, ONLY: nparticles
      USE mpi_params
      USE mpi_inc
      USE beams3d_runtime

!-----------------------------------------------------------------------
!     Local Variables
!          ier            Error Flag
!          iunit          File ID Number
!-----------------------------------------------------------------------
      INTEGER :: i, d1, d2, b_temp
      INTEGER, DIMENSION(:), ALLOCATABLE :: randomindex
      REAL(rprec) :: r_temp, phi_temp, z_temp, vll_temp, w_temp, &
                     za_temp, m_temp, c_temp, mu_temp, t_temp
      REAL(rprec), DIMENSION(3) :: v_temp
      REAL, DIMENSION(:), ALLOCATABLE :: randomnumbers

!-----------------------------------------------------------------------
!     Begin Subroutine
!-----------------------------------------------------------------------
      IF (myworkid == master) THEN
         ALLOCATE(randomindex(nparticles))
         ALLOCATE(randomnumbers(nparticles))
         CALL RANDOM_NUMBER(randomnumbers)
         randomindex = NINT(randomnumbers*nparticles)
         WHERE(randomindex < 1) randomindex = 1
         DEALLOCATE(randomnumbers)
         DO i = 1, nparticles
            d1 = i
            d2 = randomindex(i)
            ! Save swap
            r_temp = R_start(d2)
            phi_temp = phi_start(d2)
            z_temp   = Z_start(d2)
            vll_temp = vll_start(d2)
            w_temp   = weight(d2)
            za_temp  = Zatom(d2)
            m_temp   = mass(d2)
            c_temp   = charge(d2)
            mu_temp  = mu_start(d2)
            t_temp   = t_end(d2)
            v_temp   = v_neut(:,d2)
            b_temp   = Beam(d2)
            !swap
            R_start(d2)   = R_start(d1)
            phi_start(d2) = phi_start(d1)
            Z_start(d2)   = Z_start(d1)
            vll_start(d2) = vll_start(d1)
            weight(d2)    = weight(d1)
            Zatom(d2)     = Zatom(d1)
            mass(d2)      = mass(d1)
            charge(d2)    = charge(d1)
            mu_start(d2)  = mu_start(d1)
            t_end(d2)     = t_end(d1)
            v_neut(:,d2)  = v_neut(:,d1)
            Beam(d2)      = Beam(d1)
            ! Finish
            R_start(d1)   = r_temp
            phi_start(d1) = phi_temp
            Z_start(d1)   = z_temp
            vll_start(d1) = vll_temp
            weight(d1)    = w_temp
            Zatom(d1)     = za_temp
            mass(d1)      = m_temp
            charge(d1)    = c_temp
            mu_start(d1)  = mu_temp
            t_end(d1)     = t_temp
            v_neut(:,d1)  = v_temp
            Beam(d1)      = b_temp
         END DO
         DEALLOCATE(randomindex)
      END IF

#if defined(MPI_OPT)
      CALL MPI_BARRIER(MPI_COMM_BEAMS,ierr_mpi)
      CALL MPI_BCAST(R_start,nparticles,MPI_REAL8, master, MPI_COMM_BEAMS,ierr_mpi)
      CALL MPI_BCAST(phi_start,nparticles,MPI_REAL8, master, MPI_COMM_BEAMS,ierr_mpi)
      CALL MPI_BCAST(Z_start,nparticles,MPI_REAL8, master, MPI_COMM_BEAMS,ierr_mpi)
      CALL MPI_BCAST(vll_start,nparticles,MPI_REAL8, master, MPI_COMM_BEAMS,ierr_mpi)
      CALL MPI_BCAST(weight,nparticles,MPI_REAL8, master, MPI_COMM_BEAMS,ierr_mpi)
      CALL MPI_BCAST(Zatom,nparticles,MPI_REAL8, master, MPI_COMM_BEAMS,ierr_mpi)
      CALL MPI_BCAST(mass,nparticles,MPI_REAL8, master, MPI_COMM_BEAMS,ierr_mpi)
      CALL MPI_BCAST(charge,nparticles,MPI_REAL8, master, MPI_COMM_BEAMS,ierr_mpi)
      CALL MPI_BCAST(mu_start,nparticles,MPI_REAL8, master, MPI_COMM_BEAMS,ierr_mpi)
      CALL MPI_BCAST(t_end,nparticles,MPI_REAL8, master, MPI_COMM_BEAMS,ierr_mpi)
      CALL MPI_BCAST(v_neut,nparticles*3,MPI_REAL8, master, MPI_COMM_BEAMS,ierr_mpi)
      CALL MPI_BCAST(beam,nparticles,MPI_INTEGER, master, MPI_COMM_BEAMS,ierr_mpi)
#endif

      RETURN
!-----------------------------------------------------------------------
!     End Subroutine
!-----------------------------------------------------------------------
      END SUBROUTINE beams3d_randomize_particles


module global ! Define some variables needed thoughout the annealing program
 use spectrum_parameters
 use atom_types, only: maxatoms
 public

type prompt_flag
  logical :: freq = .true.
  logical :: field = .true.
  logical :: ne = .true.
  logical :: fname = .true.
  logical :: zfs = .true.
  logical :: intang = .true.
  logical :: gtens(2) = .true.
  logical :: lw(2) = .true.
  logical :: nucspins(2) = .true.
  logical :: Atens(maxatoms) = .true.
end type prompt_flag

  integer, parameter :: maxparms = maxatoms*6 + 15 ! 15 plus 6 times maxatoms
  integer, parameter :: maxiso = maxatoms + 4 ! 4 plus maxatoms
  type(real8_pointer), dimension(maxparms) :: x_new
  type(spec_parms), target, save :: parms, parmslow, parmshigh, parmsnew !The parameters of the EPR simulation to anneal
  type(spec_parms), dimension(5), save :: isotopomer ! Parameters for isotopic derivatives of the main radical
  real, dimension(5,10000) :: isoref ! Spectra of the isotopic derivatives
  integer :: nD = -1, nE = -1, niso(maxiso) = -1, iso, num_isotopomers, isopts(5)
  real :: init_temperature
end module global


      SUBROUTINE PHOTO(zy, agl, io2, ino, usol, mubar_z, D, nsp2, nw, nq, nz, kj, prates,&
                      surf_radiance, amean)
        use photochem_data, only: np, nsp, fscale, grav_z, &
                                  photoreac, ispec, rstand, qexthc, ghc, W0HC, &
                                  wavl, wav, sq, flux, &
                                  lno, nz1, dz
        use photochem_vars, only: verbose, den, T
        use photochem_wrk, only: rpar, gft, w0T, QEXTT
      implicit none

      ! local variables
      real*8, intent(in) :: zy, agl
      integer, intent(in) :: io2, ino
      integer, intent(in) :: nq, nz, kj, nsp2, nw
      real*8, dimension(nq,nz), intent(in) :: usol
      real(8), intent(in) :: mubar_z(nz)
      real*8, dimension(nsp2,nz), intent(out) :: D

      real*8, dimension(kj,nz), intent(out) :: prates
      real(8), intent(out) :: surf_radiance(nw)
      real(8), intent(out) :: amean(nz,nw)

      real*8, dimension(kj,nz) :: partial_prates

      real*8 :: SIGR(NZ)
      real*8 :: volmix(10,nz)
      integer :: ncomp(nz)
      integer :: l,i,j

      real*8 S(NZ) ! ,SALL(kw,NZ), STAU(kw),smax(kw)
      real*8 D0(2)
      integer LLNO(35)
      integer icomp(10,nz)
      ! real*8 PRATESNO(NZ)  !used in High resolution model
      real*8 PM, BK, RGAS, hc, pi
      integer JNO, jso2, js8l, js8r, js8
      ! integer JO2
      integer l3, tempcount
      real*8 ALNO, alp, am, anc, dij,dr, drs, flx
      integer k, kn, lold, nol
      real*8 qcol, qkno, rmg, rn2, scol, u0
      real*8 vmean, zyr
      integer NZP1, nz2
      real*8 absorbers(kj,nz), columndepth(KJ,NZ), signo(nz,2), efac, ha
      integer :: m
      integer lpolyscount
      real(8) :: surf_rad

      NZP1=NZ+1
      nz2 = 2*nz
      nol = 0
      ! C   NO PREDISSOCIATION WAVELENGTHS (ALLEN AND FREDERICK, 1982)
      ! c- this used only if INO=0
      DATA LLNO/3*0, 2*2, 3*0, 2*1, 25*0/

      PM = 1.67D-24               !used in S8 (???) - what is this?
      BK = 1.38D-16               !Boltzmann constant - in erg/K
      RGAS = 8.3143D7             !erg/mol/K

      PI = 3.14159
      ZYR = ZY*PI/180.            ! note ZY is passed in subroutine call - solar angle in radians
      U0 = COS(ZYR)
      AM = 1./U0
! c -mc now in PHOTABLOK      ALB = 0.25                  ! albedo of surface

      HC = 6.625D-27 * 3.00D10     !planck constant*speed of light, used in EFLUX
! c-mc erg s * cm/s -> erg cm

!below are used in old school NO calculations
      D0(1) = 1.2D-6              ! used for NO
      D0(2) = 2.6D-6              ! used for NO
      ALNO = 5.1D7                ! used for old NO
      QKNO = 1.5D-9               ! used for old NO
      DIJ = 1.65D9                ! used for old NO

      ! zero out prates
      do j=1,kj
        do i=1,nz
          prates(j,i)=0.0D0
        enddo
      enddo

! C ***** CALCULATE COLUMN DEPTHS ABOVE EACH COLLOCATION POINT FOR
! C ***** EACH SPECIES THAT ABSORBS PHOTONS

! c Kevin's likes nothing above the top
      ! HA = 0.0 * RMG*T(NZ)       !cm/mol/K * K -> cm/mol
      ! HAD = 0.0 * HA*DEN(NZ)
      ! TTOT(NZ) = HAD

      ! Not needed I think
      lpolyscount = 0
      do k=1,kj
        do i=1,nz

!     this gets any SL/IN species that have photorates
          if (photoreac(k).gt.nq) then
          !
            absorbers(k,i)=ABS(D(INT(photoreac(k)),i))/DEN(I)

!     quasi-hardcoded S8 behavior WARNING
          elseif (ISPEC(INT(photoreac(k))).eq.'S8      ') then

            absorbers(k,i)=ABS(usol(INT(photoreac(k)),i))
            if (lpolyscount .eq. 2) absorbers(k,i)=0.0
!           S8R doesn't really exist
!           S8L doesn't really either, but this is how we are rolling for now...
!           we are filling up absorbers for S8R and S8, but S8 doesn't
!           have a cross section
!           so only S8R is actually absorbing photons here in the RT scheme.
            if (i.eq.nz) then
!            print *, k,photoreac(k),ISPEC(INT(photoreac(k))),lpolyscount
              lpolyscount=lpolyscount+1
            endif
          else
            absorbers(k,i)=ABS(USOL(INT(photoreac(k)),i))
          endif
        enddo
      enddo

      ! do k=1,kj   !kj=number of photolysis reactions
      !   columndepth(k,NZ)=absorbers(k,NZ)*HAD !zeros out top
      ! enddo
    if (lno /= 0) then ! if NO is present, then compute the xsection
      columndepth = 0.d0
        do k=1,kj
          DO  M=1,NZ1
            I = NZ - M      !run through heights from the top down.
            RMG = RGAS/(mubar_z(m)*grav_z(m))           !gm cm^2/s^2/mol/K  / g *s^2/cm ->  cm/mol/K
            HA = RMG*0.5*(T(I) + T(I+1))  !scale height RT/MG
  !
  ! ! c-mc        DZ = Z(I+1) - Z(I)  !ACK - this is good, but should already exist as a vector
  ! ! c-mc in our new scheme DZ(I)=Z(I)-Z(I-1) so DZ(I+1)=Z(I+1)-Z(I)
  ! ! C ACK - may have to return when I take this to a variable grid
  !
            EFAC = (1. - EXP(-DZ(I+1)/HA))*DEN(I)*HA     !column depth of each layer
            ! TTOT(I) = TTOT(I+1) + EFAC     !total column depth above height level I
            columndepth(k,I)= columndepth(k,I+1) &
                       + EFAC*SQRT(absorbers(k,i)*absorbers(k,i+1))
          enddo
        enddo
        call XS_NO(nz,kj,zy,T,DEN,columndepth,signo)
      endif

! c - cross section 'J numbers' that are used in the loop below
! c - for now, I am assuming that these species exist.  If they don't
! c - the program will crash because the Jnumber will be returned as a '0'
! c which will cause the sq(jnumber,..) or prate(jnumber,..) call to crash
! c - consider some IF's here, but this would also entail changing the output files, etc.
      ! JO2 = 0
      JNO = 0
      JSO2 = 0
      JS8L = 0
      JS8R = 0
      JS8 = 0

      ! if (IO2.EQ.1) then
        ! JO2=minloc(photoreac,1,ISPEC(INT(photoreac)).eq.'O2     ')+1
      ! note this is for the O2 + Hv -> O + O reaction,which is the second O2 reaction
      ! endif

      if (INO.LE.2) then  !used if INO=0 or INO=1 - on JPL grid only... !actually for now using in high res too...
        JNO=minloc(photoreac,1,ISPEC(INT(photoreac)).eq.'NO     ')
! c-mab  print*,'JNO',JNO !debugging for templates w/o NO photolysis
      endif

!return to this sulfur stuff in a bit....

!OK - i want to keep this as it is used to track wavelength dependence of photolysis
!in fact, will probably need to expand this down the road.

        JSO2=minloc(photoreac,1,ISPEC(INT(photoreac)).eq.'SO2    ')

! a numbering scheme that works even if S8 isn't a species.  the key is to just not use JS8L,JS8R,JS8
        JS8L=minloc(photoreac,1,ISPEC(INT(photoreac)).eq.'S8     ')
        JS8R=JS8L+1
        JS8=JS8L+2

! C interpolate the optical properties from the Mie code onto the particle radii computed by photochemical code

     !this was in the time-stepping loop of the original code, but that seems like a mistake
! C-AP Since all model is in cm we should convert RSTAND
! c-mc test test test
! cgna - uncommented why isn't it doing this still??
! c-mc: this was in the time-stepping loop, so in Alex's code it was doing it every timestep, so RSTAND --> O.  Bad bug this was
     !DO k=1,34
      !RSTAND(k) = RSTAND(k)/10000.
     !ENDDO

! C  Calculate Qext , W0, G, for the current hydrocarbon aerosol distribution
! C qext and W0 are hardcoded for sulfate and sulfur in Twostrm.f
      if (NP.GE.3) then
        L3 = 3 !EWS - removes compilation warning
        do L=L3,NP  !loop over hydrocarbon particles ONLY RIGHT now
          DO I=1,nw
            DO J=1,NZ
              DO k=1,33  !ACK - hardcoded num particles (probably OK - this is how the HC grid was computed)
                IF ((RPAR(J,L).GE.RSTAND(k)).and.(RPAR(J,L).LT.RSTAND(k+1))) &
                THEN

                  drs = RSTAND(k+1) - RSTAND(k)
                  dr  = RPAR(J,L) - RSTAND(k)

                  QEXTT(I,J,L) = QEXTHC(I,k) + ((QEXTHC(I,k+1) - &
                    QEXTHC(I,k))/drs)*dr

                  GFT(I,J,L) = GHC(I,k) + ((GHC(I,k+1) - &
                  GHC(I,k))/drs)*dr

                  W0T(I,J,L) = W0HC(I,k) + ((W0HC(I,k+1) - &
                   W0HC(I,k))/drs)*dr

                 ENDIF
               ENDDO
             ENDDO
           ENDDO
         enddo
       endif

! ***** ***** ***** START WAVELENGTH LOOP   ***** ***** *****
      !$OMP PARALLEL PRIVATE(Lold,KN,ncomp,volmix,icomp,SIGR,ALP,S, &
      !$OMP& tempcount,RN2,partial_prates,L,FLX,i,j,k,NOL, surf_rad)
      NOL = 0
      S = 0.d0
      ! zero out prates
      do j=1,kj
        do i=1,nz
          ! prates(j,i)=0.0D0
          partial_prates(j,i) = 0.0D0
        enddo
      enddo
      do i=1,nz
        SIGR(i) = 0.D0
      enddo
      !$OMP DO
      do L=1,nw

        Lold=L-10

        KN = 1      !exponentional sum index - reset below if IO2=1
        ALP = 1.    !exponentional sum coefficient - reset below if IO2=1

        ! IF (IO2.EQ.1 .AND. wavl(L).LE.2041. .AND. wavl(L).GE.1754.) then
          ! KN = NK(Lold) ! NK(L) are the number of exponential sum coefficients needed for O2
        ! endif  ! the coefficients are read in as ALPHAP(L,K) (where 1<K<4) and BETA(L,K)

! c-mc zero out Rayleigh scattering vectors:
        do i=1,nz
          ncomp(i)=0  !number of "major" species at each height
          do j=1,10     !10 is the (arbitrary) number of major absorbers
            volmix(j,i)=0.0  !mixing ratio of major species
            icomp(j,i)=0     !hardcoded "index" number of major species
          enddo
        enddo

!   LOOP OVER K'S AT LOW O2 LEVELS (this is a long loop)
!     note that 19 is also target for loop over L
!     so this is repeated once for L<1754 and L>2041A and NK(L) times for 1754<L<2041

        DO K=1,KN

          if (k.eq.1) then !compute Rayleigh scattering cross section (as a function of height?)
            do i=1,nz

       !set up new Rayleigh scattering vectors
              do j=1,NSP
                if (D(j,i)/DEN(i).GE. 0.01) then  !if more than 1% of atmosphere, consider Rayleigh contribution

! c              if (Z(i)/1e5.eq.107.5) print *, ispec(j)

                  if (ISPEC(j).eq.'CO2') then
                    ncomp(i)=ncomp(i)+1
                    volmix(ncomp(i),i)=D(j,i)/DEN(i)
                    icomp(ncomp(i),i)=2
                  else if (ISPEC(j).eq.'N2') then
                    ncomp(i)=ncomp(i)+1
                    volmix(ncomp(i),i)=D(j,i)/DEN(i)
                    icomp(ncomp(i),i)=3
                  else if (ISPEC(j).eq.'O2') then
                    ncomp(i)=ncomp(i)+1
                    volmix(ncomp(i),i)=D(j,i)/DEN(i)
                    icomp(ncomp(i),i)=4
! c-mab: Added H2O 12/2016 as the 5th item. H2 is now 6 and He 7. Try this?
! c-mab: See "Rayleigh" routine for data reference...
                  else if (ISPEC(j).eq.'H2O') then
                    ncomp(i)=ncomp(i)+1
                    volmix(ncomp(i),i)=D(j,i)/DEN(i)
                    icomp(ncomp(i),i)=5
                  else if (ISPEC(j).eq.'H2') then
                    ncomp(i)=ncomp(i)+1
                    volmix(ncomp(i),i) = D(j,i)/DEN(i)!should matter for gas giants only
! c-mab: Rayleigh scattering routines typically assume the major species abundance don't change much vertically.
! c-mab: Thus ignoring any H2 loss due to photolysis and other reactions that are prevalent at high alt. for HJs.
! c-mab: Using fixedmr value for H2 allows for fastest convergence without qualitatively changing profiles.
                    icomp(ncomp(i),i)=6
                  ! else if (ISPEC(j).eq.'HE') then
                  !   ncomp(i)=ncomp(i)+1
                  !   volmix(ncomp(i),i) = FHE !should matter for gas giants only
                  !   icomp(ncomp(i),i)=7
! c-mab/mc: No scattering contributions for O, N, H, C or Cl!
                  else if (ISPEC(j).eq.'O'.or.ISPEC(J).eq.'H'.or. &
                   ISPEC(J).eq.'N'.or.ISPEC(J).eq.'S'.or. &
                   ISPEC(J).eq.'C'.or.ISPEC(J).eq.'Cl') then
! c-mab: Do nothing! Atoms don't scatter!
                  else
                    ! if(FH2.LT.0.5) then
                    if (.true.) then
! c-mab assuming "rest" to be Earth air is not valid for giant planets!
! c-mab this H2 fraction-based loop is a temporary fix--don't want to hardcode ignoring H
                      ncomp(i)=ncomp(i)+1
                      volmix(ncomp(i),i)=D(j,i)/DEN(i)
                      icomp(ncomp(i),i)=1
!using Earth 'air' for the rocky planets - better than nothing? hard to know...
                      if (wavl(L).eq.2273) then
                        if (tempcount.eq.0) then
                          if (verbose) then
                            ! print *, ISPEC(j),'at ', Z(i)/1e5, 'km is major '// &
                            ! 'species without Rayleigh data - using AIR', D(j,i)/DEN(i)
                            tempcount=1
                          endif
                        endif
                      endif
                    endif
                  endif
                endif !end loop over major species
              enddo  !end loop over all species in new Rayleigh setup loop
            enddo

          tempcount=0

          call RAYLEIGH(wavl(l)*1e-4,ncomp,icomp,volmix,nz,SIGR)

          endif   !end case for Rayleigh loop

          ! if (IO2 .EQ. 1) then   !re-compute O2 cross section via exponential sums
          !   if (wavl(L) .LE. 2041. .AND. wavl(L).GE.1754.) then
          !     ALP = ALPHAP(Lold,K)  !ALPHAP(17,4) are coeficients where 1<K<4
          !     do I=1,NZ
          !       sq(JO2,I,L)= SO2HZ(Lold) + BETA(Lold,K)
          !     enddo
          !   endif !end O2 sum computation loop
          ! endif !end IO2=1 loop

!mc - there used to be a mechanism for a Beer's law calculation when the optical depth was high or if IO2=0.
!removing this in favor of a permanent Twostr.f. Check the subversion archives if this ever needs to come back

          ! IKN=1
          ! IF (K.NE.KN) IKN=0   !output flag

          CALL TWOSTR(SIGR,U0,sq,WAV(L),L,nzp1,nz2,absorbers,S,surf_rad)  !two stream radiative tranfer
          surf_radiance(l) = surf_rad
          amean(:,l) = S
  ! this returns the Source function S to this code

          FLX = FLUX(L)*AGL*ALP*FSCALE

      !AGL is diurnal averaging factor, ALP is 1 if out of the SR band or IO2.NE.1
      ! or is the exponential sum coeffiecent if in the SR band and IO2.EQ.1
      ! FLUX is already corrected based on solar age (timeGa set in INPUTFILES/PLANET.dat)
      !FSACLE adjusts for position in the solar system (set in INPUTFILES/PLANET.dat)
          !FSCALE=1 is Earth, FSCALE=0.43 is Mars

! c compute photlysis rates for each reaction at each height (summed over wavelength)
          do j=1,kj
            do i=1,nz
              partial_prates(j,i) = partial_prates(j,i) + FLX*sq(j,i,L)*S(i)
            enddo
          enddo
        ! print*,S(1),flx,flux(l),agl,alp,fscale

! c save wavelength dependence of SO2 photolysis and optical depth
        ! do I=1,NZ
        !   PSO2MC(L,I) = FLX*sq(JSO2,I,L)*S(I)
        !   SALL(L,I) = S(I)
        ! enddo
          if (INO.LE.1) then
! C   NO PREDISSOCIATION IN THE D00 (1910 A) AND D10 (1830 A) BANDS
            if (wavl(L).LE.2500.0 .AND. wavl(L).GE.1754.) then
! c -mab: JNO = 0 when there is no NO photolysis in template (e.g. hjs).
              IF(JNO.NE.0)NOL = LLNO(Lold)!DATA LLNO/3*0, 2*2, 3*0, 2*1, 25*0/
              IF (NOL .NE. 0) THEN         !else bail out of loop over K (GOTO 19)

                IF (INO .EQ. 1) THEN
! C             old (cieslik and nicolet) method with intensities updated to
! C              frederick and hudson (1979)

                  do I=1,NZ
                    RN2 = DIJ/(ALNO + DIJ + QKNO*DEN(I))
                    partial_prates(JNO,I)=partial_prates(JNO,I)+ 0.5*D0(NOL)*S(I)*RN2*AGL*ALP
                  enddo

                ELSE
! C               frederick and allen method (effective cross sections)
                  do I=1,NZ
                    partial_prates(JNO,I)=partial_prates(JNO,I) + FLX*SIGNO(I,NOL)*S(I)
                  enddo
                ENDIF

              ENDIF     !if NOL=0, then do nothing...

            endif !end NO wavlength loop

          else  !end if loop which restricts this behavior to INO=0 or INO=1
!so ww get here if INO=2
!for now just use the NO photo rate generated from the band model, even at high res (Jim's suggestion)
!the below is dumb - it should be removed from the wavelength loop to make it more clear...
!leaving in place for now as I try to get results by 5PM...
            print*, "INO>1 won't work... I'll fix this someday"
            stop
          ! if(LTIMES.EQ.0) then
          !   if(L.eq.1) then
          !     print *, 'using hardcoded NO photorates'
          !     print *, 'be sure out.NOprates is valid for this atmosphere'
          !     open(60, file='out.NOprates',status='OLD')         ! formatted input
          !     read (60,*) (pratesNO(I),I=1,nz)
          !     close(60)
          !   endif
          ! endif
          ! if(L.eq.1) then
          !   do i=1,nz
          !     prates(JNO,I)=pratesNO(I)
          !   enddo
          ! endif
          endif !end INO=2 loop

!print out on last timestep
 !        if (N .NE. 0 .AND. K.EQ.KN) then !N.NE.0 only on last timestep,  KN=1 or 1-4 for L<17
 !          TAUR = SIGR(1)*TTOT(1)  !ack simple way of indicating total rayleigh optical depth. should be sum
 !          DELWAV = WAVU(L) - WAVL(L)
 !          EFLUX = 1.E6*HC*FLX/(WAV(L)*DELWAV*AGL)  !convert to W/m^2
 !          GFLUX = EFLUX*S(1)  !ground flux = TOA flux*optical path
 !          write(14, 120) L,WAV(L),TAUR,EFLUX,GFLUX,S(1)
 ! 120      FORMAT(1X,I3,1X,F6.1,1X,1P4E10.3)
 !        endif

! C ***** ***** ***** END WAVELENGTH LOOP ***** ***** *****
        enddo
      enddo
      !$OMP END DO

      !$OMP CRITICAL
      do j=1,kj
        do i=1,nz
          prates(j,i) = prates(j,i) + partial_prates(j,i)
        enddo
      enddo
      !$OMP END CRITICAL

      !$OMP END PARALLEL

      if (JS8L.GT.0) then  !if gaseous S8 is in the model, compute the photolysis rate by black magic
! C
! C ***** CALCULATE S8 PHOTORATE USING ANDY YOUNG'S METHOD *****
! C     (ANC IS THE NUMBER OF COLLISIONS REQUIRED TO CLOSE THE RING,
! C      QCOL IS THE COLLISION CROSS SECTION OF A MOLECULE, SCOL IS
! C      THE COLLISION FREQUENCY, PS8R AND PS8L ARE THE PHOTOLYSIS
! C      RATES OF THE RING AND LINEAR S8 MOLECULES, RESPECTIVELY.)
! c   there is a bug in computing PS8 - the photolysis cross sections
! c   go through "crises" that seem to be unrelated to column depths
        ANC = 1.
        QCOL = 3.D-15
        DO I=1,NZ
          VMEAN = SQRT(8.*BK*T(I)/(mubar_z(i)*PM*PI))
          SCOL = DEN(I)*QCOL*VMEAN
          prates(JS8,I) = prates(JS8R,I) * prates(JS8L,I)/ &
                    (prates(JS8L,I) + SCOL/ANC)

          prates(JS8L,I)=0.0   !this keeps these predissociation reactions from
          prates(JS8R,I)=0.0   !factoring into the photoylsis/radiative transfer schemes

        enddo

      endif !end gaseous S8 loop

      ! if (N.NE.0) then  !on last timestep only...

!ACK - hardcoded wavelength grid

 !        DO 301 J=1,NZ
 ! 301     write(27,399) (PSO2MC(L,J),L=11,30)   !ACK  11-30 is 1762-2116.5A
 ! 399  format(20(1PE9.2,2X))
 !
 !      DO 302 J=1,NZ
 ! 302     write(27,499) (PSO2MC(L,J),L=31,45)   !ACK 31-45 is 2139.5-2516A
 ! 499  format(15(1PE9.2,2X))

!now print out so2 photorates on the high resolution grid
!       if (LGRID.eq.1) then
! !L-13 is 1786.25 and L-934 is 2246.75
!        L1=minloc(wavl,1,wavl.ge.1786.25)  !ACK hardcoded to high resolution grid
!        L2=minloc(wavl,1,wavl.ge.2246.75)  !ACK hardcoded to high resolution grid
!        write(61,*),L1,L2
!         fmtstr='(    (1PE9.2,2x))'
!         write(fmtstr(2:5),'(I4)')NZ
!        do j=L1,L2
!         write(61,fmtstr) (PSO2MC(j,i),i=1,nz)
!        enddo

      ! endif

! c - td printout - here we are going to write out where tau=1
! c - at each wavelength, need to find maximum height at which tau=1

!       opticaldepth=1.0
!       slev=EXP(-1.0*AM*opticaldepth)   !optical path length where tau=1 given zenith angle
!
!       smax=MAXLOC(SALL,2, SALL .le. slev)
!
! c orig      STAU=Z(MAXLOC(SALL,2, SALL .le. slev))/1e5   !original code not in loop
!       do L=1,nw
!          if (smax(L) .eq. 0) smax(L)=1.      !for some reason MAXLOC started returning 0 for the lower bound
!          STAU=Z(INT(smax(L)))/1e5
!       enddo
!
!       write(48,322) (STAU(L), L=1,nw) !write out tau=1 heights for the time-dependent codes
!
!  322  format(118(F10.3))  !ACK a hardcoded wavelength grid

!print cross sections - should disable for production runs
!or better yet, just don't save them in evolve script...
       !
       ! do L=1,nw
       !  do I=1,nz
!         write(29,*) (sq(J,I,L),J=1,kj)   !not needed for now
       !  enddo
       ! enddo

! c print wavlength and height grids...
! c so analysis programs can pick up on nz and nw

      !  do i=1,nz
      !   write(30,*) Z(i)
      !  enddo
      !
      !
      !  do L=1,nw
      !    write(31,*) wavl(L),wavu(L),wav(L)
      !    write(41,*), flux(L),relflux(L)
      !  enddo
      !  write(41,*) AM    !write out mu
      !
      ! do L=1,nw
      !  write(41,*) (SALL(L,I),I=1,NZ)
      ! enddo
      ! endif
      !

! C ***** FILL UP RATE MATRIX *****

      ! do j=1,kj
      !   do i=1,nz
      !     A(INT(photonums(j)),i)=prates(j,i)
      !   enddo
      ! enddo

      ! sacrafice precision for reproducibility
      do j=1,kj
        do i=1,nz
          call round(prates(j,i),-8)
        enddo
      enddo

! c      print *,'stopping in PHOTO'
! c      stop

      ! LTIMES = LTIMES + 1

      end subroutine

      real*8 FUNCTION SIGRAY(W)
      ! implicit real*8(A-H,O-Z)
      implicit none
      real*8 w1, w, w2, w4
      W1 = 1.E-4 * W
      W2 = W1 * W1
      W4 = W2 * W2
      SIGRAY = 4.006E-28*(1. + .0113/W2 + .00013/W4)/W4
      RETURN
      END

      subroutine round(in,precision)
        implicit none
        real*8, intent(inout) :: in
        integer precision, order
        order = nint(log10(abs(in)))
        in = nint(in * 10.d0**(-precision-order),8)*10.d0**(precision+order)
      end subroutine


!======================================================================!
  SUBROUTINE UserForce(var)
!----------------------------------------------------------------------!
!   Discretizes and solves momentum conservation equations             !
!----------------------------------------------------------------------!
!------------------------------[Modules]-------------------------------!
  USE all_mod
  USE pro_mod
!----------------------------------------------------------------------!
  IMPLICIT NONE
!-----------------------------[Parameters]-----------------------------!
  INTEGER :: var ! 1 -> U,  2 -> V,  3 -> W
!-------------------------------[Locals]-------------------------------!
  INTEGER :: c
!--------------------------------[CVS]---------------------------------!
!  $Id: UserForce.f90,v 1.9 2002/10/30 16:30:02 niceno Exp $
!  $Source: /home/muhamed/.CVSROOT/T-Rex/User/UserForce.f90,v $
!----------------------------------------------------------------------!
! Description:                                                         !
! ~~~~~~~~~~~~                                                         !
!   Adds bouyancy terms to the right hand side of velocity equation.   !
!                                                                      !
! Note:                                                                !
! ~~~~~                                                                !
!   Relies on two assumtions:                                          !
!   1. gravitational constant is assumed to be 1                       !
!   2. refference temperature is assumed to be 0                       !
!======================================================================!

  return

  if(var == 3) then  ! only for W velocity component
    do c=1,NC
      b(c)=b(c) + T % n(c)*volume(c)
    end do
  end if

  END SUBROUTINE UserForce


!
! NESDIS_LandEM_Module
!
! Module containing the NESDIS microwave land emissivity model
!
!
! CREATION HISTORY:
!       Written by:     Banghua Yan, QSS Group Inc., 01-Jun-2005
!                       Banghua.Yan@noaa.gov
!                       Fuzhong Weng, NOAA/NESDIS/ORA,
!                       Fuzhong.Weng@noaa.gov
!

MODULE NESDIS_LandEM_Module

  ! -----------------
  ! Enviroment set up
  ! -----------------
  ! Module use
  USE CSEM_Type_Kinds,  ONLY: fp => CSEM_fp
  ! Disable implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  PRIVATE
  ! Procedures
  PUBLIC  :: NESDIS_LandEM_213
  PUBLIC  :: NESDIS_LandEM_OLD
  ! Parameters

  ! -----------------
  ! Module parameters
  ! -----------------
  REAL(fp), PARAMETER :: ZERO   = 0.0_fp
  REAL(fp), PARAMETER :: POINT1 = 0.1_fp
  REAL(fp), PARAMETER :: POINT5 = 0.5_fp
  REAL(fp), PARAMETER :: ONE    = 1.0_fp
  REAL(fp), PARAMETER :: TWO    = 2.0_fp
  REAL(fp), PARAMETER :: THREE  = 3.0_fp
  REAL(fp), PARAMETER :: FOUR   = 4.0_fp
  REAL(fp), PARAMETER :: PI     = 3.141592653589793238462643_fp
  REAL(fp), PARAMETER :: TWOPI  = TWO*PI
  REAL(fp), PARAMETER :: EMISSH_DEFAULT = 0.25_fp
  REAL(fp), PARAMETER :: EMISSV_DEFAULT = 0.30_fp

  REAL(fp), PARAMETER :: ONE_TENTH = POINT1
  REAL(fp), PARAMETER :: HALF      = POINT5

  REAL(fp), PARAMETER :: C_2 = 1.438775246065196E-002_fp   ! Second Planck function constant
                                                   ! c2=h.c/k

CONTAINS

!################################################################################
!################################################################################
!##                                                                            ##
!##                         ## PUBLIC MODULE ROUTINES ##                       ##
!##                                                                            ##
!################################################################################
!################################################################################

!--------------------------------------------------------------------------------
!
! NAME:
!       NESDIS_LandEM
!
! PURPOSE:
!       Subroutine to simulate microwave emissivity over land conditions.
!
! REFERENCES:
!       Weng, F., B. Yan, and N. Grody, 2001: "A microwave land emissivity model",
!         J. Geophys. Res., 106, 20, 115-20, 123
!
! CALLING SEQUENCE:
!       CALL NESDIS_LandEM(Angle,                 &   ! Input
!                          Frequency,             &   ! Input
!                          Soil_Moisture_Content, &   ! Input
!                          Vegetation_Fraction,   &   ! Input
!                          Soil_Temperature,      &   ! Input
!                          Land_Temperature,      &   ! Input
!                          Snow_Depth,            &   ! Input
!                          Emissivity_H,          &   ! Output
!                          Emissivity_V)              ! Output
!
! INPUT ARGUMENTS:
!         Angle:                   The angle values in degree.
!                                  UNITS:      Degrees
!                                  TYPE:       REAL(fp)
!                                  DIMENSION:  Rank-1, (I)
!
!         Frequency                Frequency User defines
!                                  This is the "I" dimension
!                                  UNITS:      GHz
!                                  TYPE:       REAL(fp)
!                                  DIMENSION:  Scalar
!
!         Soil_Moisture_Content:   The volumetric water content of the soil (0:1).
!                                  UNITS:      N/A
!                                  TYPE:       REAL(fp)
!                                  DIMENSION:  Scalar
!
!         Vegetation_Fraction:     The vegetation fraction of the surface (0:1).
!                                  UNITS:      N/A
!                                  TYPE:       REAL(fp)
!                                  DIMENSION:  Scalar
!
!         Soil_Temperature:        The soil temperature.
!                                  UNITS:      Kelvin, K
!                                  TYPE:       REAL(fp)
!                                  DIMENSION:  Scalar
!
!         Land_Temperature:        The land surface temperature.
!                                  UNITS:      Kelvin, K
!                                  TYPE:       REAL(fp)
!                                  DIMENSION:  Scalar
!
!         Snow_Depth:              The snow depth.
!                                  UNITS:      mm
!                                  TYPE:       REAL(fp)
!                                  DIMENSION:  Scalar
!
! OUTPUT ARGUMENTS:
!         Emissivity_H:            The surface emissivity at a horizontal
!                                  polarization.
!                                  UNITS:      N/A
!                                  TYPE:       REAL(fp)
!                                  DIMENSION:  Scalar
!
!         Emissivity_V:            The surface emissivity at a vertical polarization.
!                                  UNITS:      N/A
!                                  TYPE:       REAL(fp)
!                                  DIMENSION:  Scalar
!
!
! INTERNAL ARGUMENTS:
!       theta       -  local zenith angle in radian
!       rhob        -  bulk volume density of the soil (1.18-1.12)
!       rhos        -  density of the solids (2.65 g.cm^3 for solid soil material)
!       sand        -  sand fraction (sand + clay = 1.0)
!       clay        -  clay fraction
!       lai         -  leaf area index (eg. lai = 4.0 for corn leaves)
!       sigma       -  surface roughness formed between medium 1 and 2,
!                      expressed as the standard deviation of roughtness height (mm)
!       leaf_thick  --  leaf thickness (mm)
!       rad         -  radius of dense medium scatterers (mm)
!       va          -  fraction volume of dense medium scatterers(0.0 - 1.0)
!       ep          -  dielectric constant of ice or sand particles, complex value
!                               (e.g, 3.0+i0.0)
!
! CREATION HISTORY:
!       Written by:     Banghua Yan, QSS Group Inc., 16-May-2005
!                       Banghua.Yan@noaa.gov
!                       Fuzhong Weng, NOAA/NESDIS/ORA,
!                       Fuzhong.Weng@noaa.gov
!
!------------------------------------------------------------------------------------------------------------

  SUBROUTINE NESDIS_LandEM_213(Angle,                 &   ! Input
                           Frequency,             &   ! Input
                           Soil_Moisture_Content, &   ! Input
                           Vegetation_Fraction,   &   ! Input
                           Soil_Temperature,      &   ! Input
                           t_skin,                &   ! Input
                           Lai,                   &   ! Input
                           Soil_Type,             &   ! Input
                           Vegetation_Type,       &   ! Input
                           Emissivity_H,          &   ! Output
                           Emissivity_V)              ! Output
    ! Arguments
    REAL(fp), intent(in) :: Angle
    REAL(fp), intent(in) :: Frequency
    REAL(fp), intent(in) :: Soil_Moisture_Content
    REAL(fp), intent(in) :: Vegetation_Fraction
    REAL(fp), intent(in) :: Soil_Temperature
    REAL(fp), intent(in) :: t_skin
    REAL(fp), intent(in) :: Lai
    INTEGER,  intent(in) :: Soil_Type
    INTEGER,  intent(in) :: Vegetation_Type
    REAL(fp), intent(out):: Emissivity_V,Emissivity_H
    ! Local parameters
    REAL(fp), PARAMETER :: snow_depth_c     = 10.0_fp
    REAL(fp), PARAMETER :: tsoilc_undersnow = 280.0_fp
    REAL(fp), PARAMETER :: rhos = 2.65_fp
    REAL(fp)            :: sand, clay, rhob
    REAL(fp), PARAMETER, dimension(0:9) :: frac_sand = (/ 0.80_fp,     &
                          0.92_fp, 0.10_fp, 0.20_fp, 0.51_fp, 0.50_fp, &
                          0.35_fp, 0.60_fp, 0.42_fp,  0.92_fp  /)
    REAL(fp), PARAMETER, dimension(0:9) :: frac_clay = (/ 0.20_fp,     &
                          0.06_fp, 0.34_fp, 0.63_fp, 0.14_fp, 0.43_fp, &
                          0.34_fp, 0.28_fp, 0.085_fp, 0.06_fp /)
    REAL(fp), PARAMETER, dimension(0:9) :: rhob_soil = (/ 1.48_fp,     &
                          1.68_fp, 1.27_fp, 1.21_fp, 1.48_fp, 1.31_fp, &
                          1.32_fp, 1.40_fp, 1.54_fp, 1.68_fp /)
! Specific Density
    REAL(fp), PARAMETER, dimension(0:13) :: veg_rho  = (/ 0.33_fp,     &
                          0.40_fp, 0.40_fp, 0.40_fp, 0.40_fp, 0.40_fp, &
                          0.25_fp, 0.25_fp, 0.40_fp, 0.40_fp, 0.40_fp, &
                          0.40_fp, 0.33_fp, 0.33_fp            /)
! MGE
    REAL(fp), PARAMETER, dimension(0:13) :: veg_mge  = (/ 0.50_fp,     &
                          0.45_fp, 0.45_fp, 0.45_fp, 0.40_fp, 0.40_fp, &
                          0.30_fp, 0.35_fp, 0.30_fp, 0.30_fp, 0.40_fp, &
                          0.30_fp, 0.50_fp, 0.40_fp            /)
! LAI
    REAL(fp), PARAMETER, dimension(0:13) :: lai_min  = (/ 0.52_fp,     &
                          3.08_fp, 1.85_fp, 2.80_fp, 5.00_fp, 1.00_fp, &
                          0.50_fp, 0.52_fp, 0.60_fp, 0.50_fp, 0.60_fp, &
                          0.10_fp, 1.56_fp, 0.01_fp            /)
    REAL(fp), PARAMETER, dimension(0:13) :: lai_max  = (/ 2.90_fp,     &
                          6.48_fp, 3.31_fp, 5.50_fp, 6.40_fp, 5.16_fp, &
                          3.66_fp, 2.90_fp, 2.60_fp, 3.66_fp, 2.60_fp, &
                          0.75_fp, 5.68_fp, 0.01_fp            /)
! Leaf_thickness
    REAL(fp), PARAMETER, dimension(0:13) :: leaf_th  = (/ 0.07_fp,     &
                          0.18_fp, 0.18_fp, 0.18_fp, 0.18_fp, 0.18_fp, &
                          0.12_fp, 0.12_fp, 0.12_fp, 0.12_fp, 0.12_fp, &
                          0.12_fp, 0.15_fp, 0.12_fp            /)
    ! Local variables
    REAL(fp) :: mv,veg_frac,theta,theta_i,theta_t,mu,r21_h,r21_v,r23_h,r23_v,  &
                t21_v,t21_h,gv,gh,ssalb_h,ssalb_v,tau_h,tau_v,mge, &
                    leaf_thick,rad,sigma,va,ep_real,ep_imag
    REAL(fp) :: t_soil
    REAL(fp) :: rhoveg, vlai
    REAL(fp) :: local_snow_depth
    COMPLEX(fp) :: esoil, eveg, esnow, eair
    LOGICAL :: SnowEM_Physical_Model

    eair = CMPLX(ONE,-ZERO,fp)
    theta = Angle*PI/180.0_fp

    ! By default use the
    ! Assign local variable
    mv               = Soil_Moisture_Content
    veg_frac         = Vegetation_Fraction
    t_soil           = Soil_Temperature
    sand = frac_sand(Soil_Type)
    clay = frac_clay(Soil_Type )
    rhob = rhob_soil(Soil_Type )
    local_snow_depth = 0.0_fp

    ! Check soil/skin temperature
    if ( (t_soil <= 100.0_fp .OR.  t_soil >= 350.0_fp) .AND. &
         (t_skin >= 100.0_fp .AND. t_skin <= 350.0_fp) ) t_soil = t_skin

    ! Check soil moisture content range
    mv = MAX(MIN(mv,ONE),ZERO)

    ! Surface type based on snow depth
    IF (local_snow_depth > POINT1) THEN

      ! O.k.; we're going to compute snow emissivities....

      ! By default use the physical model for snow
      SnowEM_Physical_Model = .TRUE.
      if (local_snow_depth > snow_depth_c) SnowEM_Physical_Model = .FALSE.

      ! Compute the snow emissivity
      IF ( SnowEM_Physical_Model ) THEN

        ep_real = 3.2_fp
        ep_imag = -0.0005_fp
        sigma = ONE

        ! For deep snow, the performance of the model is poor
        local_snow_depth = MIN(local_snow_depth,1000.0_fp)

        ! The fraction volume of dense medium
        ! scatterers must be in the range (0-1)
        va = 0.4_fp + 0.0004_fp*local_snow_depth
        va = MAX(MIN(va,ONE),ZERO)

        ! Limit for snow grain size
        rad = MIN((POINT5 + 0.005_fp*local_snow_depth),ONE)

        ! Limit for soil temperature
        t_soil = MIN(t_soil,tsoilc_undersnow)

        CALL Snow_Diel(Frequency, ep_real, ep_imag, rad, va, esnow)
        CALL Soil_Diel(Frequency, t_soil, mv, rhob, rhos, sand, clay, esoil)

        theta_i = ASIN(REAL(SIN(theta)*SQRT(eair)/SQRT(esnow),fp))

        CALL Reflectance(esnow, eair, theta_i,  theta, r21_v, r21_h)
        CALL Transmittance(esnow, eair, theta_i, theta, t21_v, t21_h)

        mu      = COS(theta_i)
        theta_t = ASIN(REAL(SIN(theta_i)*SQRT(esnow)/SQRT(esoil),fp))

        CALL Reflectance(esnow, esoil, theta_i, theta_t, r23_v, r23_h)
        CALL Roughness_Reflectance(Frequency, sigma, r23_v, r23_h)
        CALL Snow_Optic(Frequency,rad,local_snow_depth,va,ep_real, ep_imag,gv,gh,&
                        ssalb_v,ssalb_h,tau_v,tau_h)
        CALL Two_Stream_Solution(mu,gv,gh,ssalb_h,ssalb_v,tau_h,tau_v, &
                                 r21_h,r21_v,r23_h,r23_v,t21_v,t21_h,Emissivity_V,Emissivity_H, &
                               frequency, t_soil, t_skin)
      ELSE
        ! Use the empirical method
        !CALL SnowEM_Default(Frequency,t_skin, local_snow_depth,Emissivity_V,Emissivity_H)
      END IF

    ELSE

      ! No snow, so we're going to compute canopy emissivities....

      ! Limit for vegetation fraction
      veg_frac = MAX(MIN(veg_frac,ONE),ZERO)

!     lai = THREE*veg_frac + POINT5
!     mge = POINT5*veg_frac
!     leaf_thick = 0.07_fp
      mu  = COS(theta)
      sigma = POINT5

      vlai = Lai*veg_frac
      mge = veg_mge(Vegetation_Type)
      rhoveg = veg_rho(Vegetation_Type)
      leaf_thick = leaf_th(Vegetation_Type)

      r21_h    = ZERO
      r21_v    = ZERO
      t21_h    = ONE
      t21_v    = ONE

      CALL Soil_Diel(Frequency, t_soil, mv, rhob, rhos, sand, clay, esoil)
      theta_t = ASIN(REAL(SIN(theta)*SQRT(eair)/SQRT(esoil),fp))
      CALL Reflectance(eair, esoil, theta, theta_t, r23_v, r23_h)
      CALL Roughness_Reflectance(Frequency, sigma, r23_v, r23_h)
      CALL Canopy_Diel(Frequency, mge, eveg, rhoveg)
      CALL Canopy_Optic(vlai,Frequency,theta,eveg,leaf_thick,gv,gh,ssalb_v,ssalb_h,tau_v,tau_h)
      CALL Two_Stream_Solution(mu,gv,gh,ssalb_h,ssalb_v,tau_h,tau_v, &
                               r21_h,r21_v,r23_h,r23_v,t21_v,t21_h,Emissivity_V,Emissivity_H, &
                               frequency, t_soil, t_skin)
    END IF

  END SUBROUTINE NESDIS_LandEM_213

 SUBROUTINE NESDIS_LandEM_OLD(Angle,                 &   ! Input
                           Frequency,             &   ! Input
                           Soil_Moisture_Content, &   ! Input
                           Vegetation_Fraction,   &   ! Input
                           Soil_Temperature,      &   ! Input
                           t_skin,                &   ! Input
                           Lai,                   &   ! Input
                           Soil_Type,             &   ! Input
                           Vegetation_Type,       &   ! Input
                           Emissivity_H,          &   ! Output
                           Emissivity_V)              ! Output
    ! Arguments
    REAL(fp), intent(in) :: Angle
    REAL(fp), intent(in) :: Frequency
    REAL(fp), intent(in) :: Soil_Moisture_Content
    REAL(fp), intent(in) :: Vegetation_Fraction
    REAL(fp), intent(in) :: Soil_Temperature
    REAL(fp), intent(in) :: t_skin
    REAL(fp), intent(in) :: Lai
    INTEGER,  intent(in) :: Soil_Type
    INTEGER,  intent(in) :: Vegetation_Type
    REAL(fp), intent(out):: Emissivity_V,Emissivity_H
    ! Local parameters
    REAL(fp), PARAMETER :: snow_depth_c     = 10.0_fp
    REAL(fp), PARAMETER :: tsoilc_undersnow = 280.0_fp
    REAL(fp), PARAMETER :: rhos = 2.65_fp
    REAL(fp)            :: sand, clay, rhob
    REAL(fp), PARAMETER, dimension(0:9) :: frac_sand = (/ 0.80_fp,     &
                          0.92_fp, 0.10_fp, 0.20_fp, 0.51_fp, 0.50_fp, &
                          0.35_fp, 0.60_fp, 0.42_fp,  0.92_fp  /)
    REAL(fp), PARAMETER, dimension(0:9) :: frac_clay = (/ 0.20_fp,     &
                          0.06_fp, 0.34_fp, 0.63_fp, 0.14_fp, 0.43_fp, &
                          0.34_fp, 0.28_fp, 0.085_fp, 0.06_fp /)
    REAL(fp), PARAMETER, dimension(0:9) :: rhob_soil = (/ 1.48_fp,     &
                          1.68_fp, 1.27_fp, 1.21_fp, 1.48_fp, 1.31_fp, &
                          1.32_fp, 1.40_fp, 1.54_fp, 1.68_fp /)
! Specific Density
    REAL(fp), PARAMETER, dimension(0:13) :: veg_rho  = (/ 0.33_fp,     &
                          0.40_fp, 0.40_fp, 0.40_fp, 0.40_fp, 0.40_fp, &
                          0.25_fp, 0.25_fp, 0.40_fp, 0.40_fp, 0.40_fp, &
                          0.40_fp, 0.33_fp, 0.33_fp            /)
! MGE
    REAL(fp), PARAMETER, dimension(0:13) :: veg_mge  = (/ 0.50_fp,     &
                          0.45_fp, 0.45_fp, 0.45_fp, 0.40_fp, 0.40_fp, &
                          0.30_fp, 0.35_fp, 0.30_fp, 0.30_fp, 0.40_fp, &
                          0.30_fp, 0.50_fp, 0.40_fp            /)
! LAI
    REAL(fp), PARAMETER, dimension(0:13) :: lai_min  = (/ 0.52_fp,     &
                          3.08_fp, 1.85_fp, 2.80_fp, 5.00_fp, 1.00_fp, &
                          0.50_fp, 0.52_fp, 0.60_fp, 0.50_fp, 0.60_fp, &
                          0.10_fp, 1.56_fp, 0.01_fp            /)
    REAL(fp), PARAMETER, dimension(0:13) :: lai_max  = (/ 2.90_fp,     &
                          6.48_fp, 3.31_fp, 5.50_fp, 6.40_fp, 5.16_fp, &
                          3.66_fp, 2.90_fp, 2.60_fp, 3.66_fp, 2.60_fp, &
                          0.75_fp, 5.68_fp, 0.01_fp            /)
! Leaf_thickness
    REAL(fp), PARAMETER, dimension(0:13) :: leaf_th  = (/ 0.07_fp,     &
                          0.18_fp, 0.18_fp, 0.18_fp, 0.18_fp, 0.18_fp, &
                          0.12_fp, 0.12_fp, 0.12_fp, 0.12_fp, 0.12_fp, &
                          0.12_fp, 0.15_fp, 0.12_fp            /)
    ! Local variables
    REAL(fp) :: mv,veg_frac,theta,theta_i,theta_t,mu,r21_h,r21_v,r23_h,r23_v,  &
                t21_v,t21_h,gv,gh,ssalb_h,ssalb_v,tau_h,tau_v,mge, &
                    leaf_thick,rad,sigma,va,ep_real,ep_imag
    REAL(fp) :: t_soil
    REAL(fp) :: rhoveg, vlai
    REAL(fp) :: local_snow_depth
    COMPLEX(fp) :: esoil, eveg, esnow, eair
    LOGICAL :: SnowEM_Physical_Model

    eair = CMPLX(ONE,-ZERO,fp)
    theta = Angle*PI/180.0_fp

    ! By default use the
    ! Assign local variable
    mv               = Soil_Moisture_Content
    veg_frac         = Vegetation_Fraction
    t_soil           = Soil_Temperature
    sand = frac_sand(Soil_Type)
    clay = frac_clay(Soil_Type )
    rhob = rhob_soil(Soil_Type )
    local_snow_depth = 0.0_fp

    ! Check soil/skin temperature
    if ( (t_soil <= 100.0_fp .OR.  t_soil >= 350.0_fp) .AND. &
         (t_skin >= 100.0_fp .AND. t_skin <= 350.0_fp) ) t_soil = t_skin

    ! Check soil moisture content range
    mv = MAX(MIN(mv,ONE),ZERO)

    ! Surface type based on snow depth
    IF (local_snow_depth > POINT1) THEN

      ! O.k.; we're going to compute snow emissivities....

      ! By default use the physical model for snow
      SnowEM_Physical_Model = .TRUE.
      if (local_snow_depth > snow_depth_c) SnowEM_Physical_Model = .FALSE.

      ! Compute the snow emissivity
      IF ( SnowEM_Physical_Model ) THEN

        ep_real = 3.2_fp
        ep_imag = -0.0005_fp
        sigma = ONE

        ! For deep snow, the performance of the model is poor
        local_snow_depth = MIN(local_snow_depth,1000.0_fp)

        ! The fraction volume of dense medium
        ! scatterers must be in the range (0-1)
        va = 0.4_fp + 0.0004_fp*local_snow_depth
        va = MAX(MIN(va,ONE),ZERO)

        ! Limit for snow grain size
        rad = MIN((POINT5 + 0.005_fp*local_snow_depth),ONE)

        ! Limit for soil temperature
        t_soil = MIN(t_soil,tsoilc_undersnow)

        CALL Snow_Diel(Frequency, ep_real, ep_imag, rad, va, esnow)
        CALL Soil_Diel(Frequency, t_soil, mv, rhob, rhos, sand, clay, esoil)

        theta_i = ASIN(REAL(SIN(theta)*SQRT(eair)/SQRT(esnow),fp))

        CALL Reflectance(esnow, eair, theta_i,  theta, r21_v, r21_h)
        CALL Transmittance(esnow, eair, theta_i, theta, t21_v, t21_h)

        mu      = COS(theta_i)
        theta_t = ASIN(REAL(SIN(theta_i)*SQRT(esnow)/SQRT(esoil),fp))

        CALL Reflectance(esnow, esoil, theta_i, theta_t, r23_v, r23_h)
        CALL Roughness_Reflectance(Frequency, sigma, r23_v, r23_h)
        CALL Snow_Optic(Frequency,rad,local_snow_depth,va,ep_real, ep_imag,gv,gh,&
                        ssalb_v,ssalb_h,tau_v,tau_h)
        CALL Two_Stream_Solution(mu,gv,gh,ssalb_h,ssalb_v,tau_h,tau_v, &
                                 r21_h,r21_v,r23_h,r23_v,t21_v,t21_h,Emissivity_V,Emissivity_H, &
                               frequency, t_soil, t_skin)
      ELSE
        ! Use the empirical method
        !CALL SnowEM_Default(Frequency,t_skin, local_snow_depth,Emissivity_V,Emissivity_H)
      END IF

    ELSE

      ! No snow, so we're going to compute canopy emissivities....

      ! Limit for vegetation fraction
      veg_frac = MAX(MIN(veg_frac,ONE),ZERO)

!     lai = THREE*veg_frac + POINT5
!     mge = POINT5*veg_frac
!     leaf_thick = 0.07_fp
      mu  = COS(theta)
      sigma = POINT5

      vlai = Lai*veg_frac
      mge = veg_mge(Vegetation_Type)
      rhoveg = veg_rho(Vegetation_Type)
      leaf_thick = leaf_th(Vegetation_Type)

      r21_h    = ZERO
      r21_v    = ZERO
      t21_h    = ONE
      t21_v    = ONE

      CALL Soil_Diel(Frequency, t_soil, mv, rhob, rhos, sand, clay, esoil)
      theta_t = ASIN(REAL(SIN(theta)*SQRT(eair)/SQRT(esoil),fp))
      CALL Reflectance(eair, esoil, theta, theta_t, r23_v, r23_h)
      CALL Roughness_Reflectance(Frequency, sigma, r23_v, r23_h)
      CALL Canopy_Diel(Frequency, mge, eveg, rhoveg)
      CALL Canopy_Optic(vlai,Frequency,theta,eveg,leaf_thick,gv,gh,ssalb_v,ssalb_h,tau_v,tau_h)
      CALL Two_Stream_Solution(mu,gv,gh,ssalb_h,ssalb_v,tau_h,tau_v, &
                               r21_h,r21_v,r23_h,r23_v,t21_v,t21_h,Emissivity_V,Emissivity_H, &
                               frequency, t_soil, t_skin)
    END IF

  END SUBROUTINE NESDIS_LandEM_OLD

!##################################################################################
!##################################################################################
!##                                                                              ##
!##                          ## PRIVATE MODULE ROUTINES ##                       ##
!##                                                                              ##
!##################################################################################
!##################################################################################

subroutine SnowEM_Default(frequency,ts, depth,Emissivity_V,Emissivity_H)

!----------------------------------------------------------------------------------
!$$$  subprogram documentation block
!                .      .    .
!   prgmmr:  Banghua Yan and Fuzhong Weng               org: nesdis              date: 2005-12-01
!
! abstract: preliminary estimate of snow emissivity using  surface temperature and snow depth
!
! input argument list:
!
!      ts         -  surface temperature
!      frequency   -  frequency (ghz)
!
! output argument list:
!
!      Emissivity_V         -  snow emissivty at V-POL
!      Emissivity_H         -  snow emissivty at H-POL
!
! remarks:
!
! attributes:
!   language: f90
!   machine:  ibm rs/6000 sp
!
!------------------------------------------------------------------------------------------------------------

  ! Arguments
  REAL(fp) :: frequency,ts, depth,Emissivity_V,Emissivity_H
  ! Local parameters
  INTEGER , PARAMETER :: new = 7
  INTEGER , PARAMETER :: NFRESH_SHALLOW_SNOW = 1
  INTEGER , PARAMETER :: NPOWDER_SNOW        = 2
  INTEGER , PARAMETER :: NWET_SNOW           = 3
  INTEGER , PARAMETER :: NDEEP_SNOW          = 4
  REAL(fp), PARAMETER :: twet    = 270.0_fp
  REAL(fp), PARAMETER :: tcrust  = 235.0_fp
  REAL(fp), PARAMETER :: depth_s =  50.0_fp
  REAL(fp), PARAMETER :: depth_c = 100.0_fp

  frequency=frequency
  ts = ts; depth = depth
  Emissivity_V = EMISSH_DEFAULT
  Emissivity_H = EMISSH_DEFAULT

end subroutine SnowEM_Default

subroutine Canopy_Optic(vlai,frequency,theta,esv,d,gv,gh,&
                        ssalb_v,ssalb_h,tau_v, tau_h)

!----------------------------------------------------------------------------------
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    canopy_optic compute optic parameters for canopy
!
!   prgmmr:  Fuzhong Weng and Banghua Yan                org: nesdis              date: 2000-11-28
!
! abstract: compute optic parameters for canopy
!
! program history log:
!
! input argument list:
!
!      lai         -  leaf area index
!      frequency   -  frequency (ghz)
!      theta       -  incident angle
!      esv         -  leaf dielectric constant
!      d           -  leaf thickness (mm)
!
! output argument list:
!
!      gv           -  asymmetry factor for v pol
!      gh           -  asymmetry factor for h pol
!      ssalb_v      -  single scattering albedo at v. polarization
!      ssalb_h      -  single scattering albedo at h. polarization
!      tau_v        -  optical depth at v. polarization
!      tau_h        -  optical depth at h. polarization
!
! remarks:
!
! attributes:
!   language: f90
!   machine:  ibm rs/6000 sp
!
!------------------------------------------------------------------------------------------------------------

  REAL(fp) :: frequency,theta,d,vlai,ssalb_v,ssalb_h,tau_v,tau_h,gv, gh, mu
  COMPLEX(fp) :: ix,k0,kz0,kz1,rhc,rvc,esv,expval1,factt,factrvc,factrhc
  REAL(fp) :: rh,rv,th,tv
  REAL(fp), PARAMETER :: threshold = 0.999_fp

  mu = COS(theta)
  ix = CMPLX(ZERO, ONE, fp)

  k0  = CMPLX(TWOPI*frequency/300.0_fp, ZERO, fp)   ! 1/mm
  kz0 = k0*mu
  kz1 = k0*SQRT(esv - SIN(theta)**2)

  rhc = (kz0 - kz1)/(kz0 + kz1)
  rvc = (esv*kz0 - kz1)/(esv*kz0 + kz1)

  expval1 = EXP(-TWO*ix*kz1*d)
  factrvc = ONE-rvc**2*expval1
  factrhc = ONE-rhc**2*expval1
  factt   = FOUR*kz0*kz1*EXP(ix*(kz0-kz1)*d)

  rv = ABS(rvc*(ONE - expval1)/factrvc)**2
  rh = ABS(rhc*(ONE - expval1)/factrhc)**2

  th = ABS(factt/((kz1+kz0)**2*factrhc))**2
  tv = ABS(esv*factt/((kz1+esv*kz0)**2*factrvc))**2

  gv = POINT5
  gh = POINT5

  tau_v = POINT5*vlai*(TWO-tv-th)
  tau_h = tau_v

  ssalb_v = MIN((rv+rh)/(TWO-tv-th),threshold)
  ssalb_h = ssalb_v

end subroutine Canopy_Optic

subroutine Snow_Optic(frequency,a,h,f,ep_real,ep_imag,gv,gh, ssalb_v,ssalb_h,tau_v,tau_h)

!-------------------------------------------------------------------------------------------------------------
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    landem      comput optic parameters for snow
!
!   prgmmr: Fuzhong Weng and Banghua Yan                 org: nesdis              date: 2000-11-28
!
! abstract: compute optic parameters for snow
!
! program history log:
!
! input argument list:
!
!      theta        -  local zenith angle (degree)
!      frequency    -  frequency (ghz)
!      ep_real      -  real part of dielectric constant of particles
!      ep_imag      -  imaginary part of dielectric constant of particles
!      a            -  particle radiu (mm)
!      h            -  snow depth(mm)
!      f            -  fraction volume of snow (0.0 - 1.0)
!
! output argument list:
!
!       ssalb       -  single scattering albedo
!       tau         -  optical depth
!       g           -  asymmetry factor
!
!   important internal variables:
!
!       ks          -  scattering coeffcient (/mm)
!       ka          -  absorption coeffient (/mm)
!       kp          -  eigenvalue of two-stream approximation
!       y           -  = yr+iyi
!
! remarks:
!
! attributes:
!   language: f90
!   machine:  ibm rs/6000 sp
!
!----------------------------------------------------------------------------------

  REAL(fp) :: yr,yi,ep_real,ep_imag
  REAL(fp) :: frequency,a,h,f,ssalb_v,ssalb_h,tau_v,tau_h,gv,gh,k
  REAL(fp) :: ks1,ks2,ks3,ks,kr1,kr2,kr3,kr,ki1,ki2,ki3,ki
  REAL(fp) :: fact1,fact2,fact3,fact4,fact5

  k = TWOPI/(300._fp/frequency)

  yr = (ep_real - ONE)/(ep_real + TWO)
  yi = -ep_imag/(ep_real + TWO)

  fact1 = (ONE+TWO*f)**2
  fact2 = ONE-f*yr
  fact3 = (ONE-f)**4
  fact4 = f*(k*a)**3
  fact5 = ONE+TWO*f*yr

  ks1 = k*SQRT(fact2/fact5)
  ks2 = fact4*fact3/fact1
  ks3 = (yr/fact2)**2
  ks = ks1*ks2*ks3

  kr1 = fact5/fact2
  kr2 = TWO*ks2
  kr3 = TWO*yi*yr/(fact2**3)
  kr = k*SQRT(kr1+kr2*kr3)

  ki1 = THREE*f*yi/fact2**2
  ki2 = kr2
  ki3 = ks3
  ki  = k**2/(TWO*kr)*(ki1+ki2*ki3)

  gv = POINT5
  gh = POINT5

  ssalb_v = MIN(ks/ki, 0.999_fp)
  ssalb_h = ssalb_v
  tau_v = TWO*ki*h
  tau_h = tau_v

end subroutine Snow_Optic

subroutine Soil_Diel(freq,t_soil,vmc,rhob,rhos,sand,clay,esm)

!----------------------------------------------------------------------------------
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    Soil_Diel   calculate the dielectric properties of soil
!
!   prgmmr: Fuzhong Weng and Banghua Yan                 org: nesdis              date: 2000-11-28
!
! abstract: compute the dilectric constant of the bare soil
!
! program history log:
!
! input argument list:
!
!      theta        -  local zenith angle (degree)
!      frequency    -  frequency (ghz)
!      t_soil       -  soil temperature
!      vmc          -  volumetric moisture content (demensionless)
!      rhob         -  bulk volume density of the soil (1.18-1.12)
!      rhos         -  density of the solids (2.65 g.cm^3 for
!                       solid soil material)
!      sand         -  sand fraction (sand + clay = 1.0)
!      clay         -  clay fraction
!
! output argument list:
!
!      esm          -  dielectric constant for bare soil
!
! important internal variables:
!
!      esof         -  the permittivity of free space
!      eswo         -  static dieletric constant
!      tauw         -  relaxation time of water
!      s            -  salinity
!
! remarks:
!
! attributes:
!   language: f90
!   machine:  ibm rs/6000 sp
!
!----------------------------------------------------------------------------------

  REAL(fp) :: f,tauw,freq,t_soil,vmc,rhob,rhos,sand,clay
  REAL(fp) :: alpha,beta,ess,rhoef,t,eswi,eswo
  REAL(fp) :: esof
  COMPLEX(fp) :: esm,esw,es1,es2

  alpha = 0.65_fp
  beta  = 1.09_fp - 0.11_fp*sand + 0.18_fp*clay
  ess = (1.01_fp + 0.44_fp*rhos)**2 - 0.062_fp
  rhoef = -1.645_fp + 1.939_fp*rhob - 0.020213_fp*sand + 0.01594_fp*clay
  t = t_soil - 273.0_fp
  f = freq*1.0e9_fp

  ! the permittivity at the high frequency limit
  eswi = 5.5_fp

  ! the permittivity of free space (esof)
  esof = 8.854e-12_fp

  ! static dieletric constant (eswo)
  eswo = 87.134_fp+(-1.949e-1_fp+(-1.276e-2_fp+2.491e-4_fp*t)*t)*t
  tauw = 1.1109e-10_fp+(-3.824e-12_fp+(6.938e-14_fp-5.096e-16_fp*t)*t)*t

  if (vmc > ZERO) then
     es1 = CMPLX(eswi, -rhoef*(rhos-rhob)/(TWOPI*f*esof*rhos*vmc), fp)
  else
     es1 = CMPLX(eswi, ZERO, fp)
  endif

  es2 = CMPLX(eswo-eswi, ZERO, fp)/CMPLX(ONE, f*tauw, fp)
  esw = es1 + es2
  esm = ONE + (ess**alpha - ONE)*rhob/rhos + vmc**beta*esw**alpha - vmc
  esm = esm**(ONE/alpha)

  if(AIMAG(esm) >= ZERO) esm = CMPLX(REAL(esm,fp),-0.0001_fp, fp)

end subroutine Soil_Diel

subroutine Snow_Diel(frequency,ep_real,ep_imag,rad,frac,ep_eff)

!----------------------------------------------------------------------------------
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    Snow_Diel   compute dielectric constant of snow
!
!   prgmmr: Fuzhong Weng and Banghua Yan                 org: nesdis              date: 2000-11-28
!
! abstract: compute dielectric constant of snow
!
!
! program history log:
!
! input argument list:
!
!       frequency   -  frequency (ghz)
!       ep_real     -  real part of dielectric constant of particle
!       ep_imag     -  imaginary part of dielectric constant of particle
!       rad         -  particle radiu (mm)
!       frac        -  fraction volume of snow (0.0 - 1.0)
!
! output argument list:
!
!       ep_eff      -  dielectric constant of the dense medium
!
! remarks:
!
! attributes:
!   language: f90
!   machine:  ibm rs/6000 sp
!
!  Copyright (C) 2005 Fuzhong Weng and Banghua Yan
!
!  This program is free software; you can redistribute it and/or modify it under the terms of the GNU
!  General Public License as published by the Free Software Foundation; either version 2 of the License,
!  or (at your option) any later version.
!
!  This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even
!  the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
!  License for more details.
!
!  You should have received a copy of the GNU General Public License along with this program; if not, write
!  to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
!----------------------------------------------------------------------------------

  REAL(fp) :: ep_imag,ep_real
  REAL(fp) :: frequency,rad,frac,k0,yr,yi
  COMPLEX(fp) :: y,ep_r,ep_i,ep_eff,fracy

  k0 = TWOPI/(300.0_fp/frequency)

  yr = (ep_real - ONE)/(ep_real + TWO)
  yi = ep_imag/(ep_real + TWO)

  y = CMPLX(yr, yi, fp)
  fracy=frac*y

  ep_r = (ONE + TWO*fracy)/(ONE - fracy)
  ep_i = TWO*fracy*y*(k0*rad)**3*(ONE-frac)**4/((ONE-fracy)**2*(ONE+TWO*frac)**2)
  ep_eff = ep_r - CMPLX(ZERO,ONE,fp)*ep_i

  if (AIMAG(ep_eff) >= ZERO) ep_eff = CMPLX(REAL(ep_eff), -0.0001_fp, fp)

end subroutine Snow_Diel

subroutine Canopy_Diel(frequency,mg,esv,rhoveg)

!----------------------------------------------------------------------------------
!
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:   canopy_diel compute the dielectric constant of the vegetation canopy
!
!   prgmmr:  Fuzhong Weng and Banghua Yan                org: nesdis              date: 2000-11-28
!
! abstract: compute the dielectric constant of the vegetation canopy geomatrical optics approximation
!
!           for vegetation canopy work for horizontal leaves
!
! program history log:
!
! input argument list:
!
!      frequency    -  frequency (ghz)
!      mg           -  gravimetric water content
!
! output argument list:
!
!      esv          -  dielectric constant of leaves
!
! remarks:
!
! references:
!
!     ulaby and el-rayer, 1987: microwave dielectric spectrum of vegetation part ii,
!           dual-dispersion model, ieee trans geosci. remote sensing, 25, 550-557
!
! attributes:
!   language: f90
!   machine:  ibm rs/6000 sp
!
!----------------------------------------------------------------------------------

  REAL(fp) :: frequency,  mg, en, vf, vb
  REAL(fp) :: rhoveg, vmv
  COMPLEX(fp) :: esv, xx

  vmv = mg*rhoveg/( ONE - mg*(ONE-rhoveg) )
  en = 1.7_fp + (3.2_fp + 6.5_fp*vmv)*vmv

  vf = vmv*(0.82_fp*vmv + 0.166_fp)
  vb = 31.4_fp*vmv*vmv/( ONE + 59.5_fp*vmv*vmv)

  xx = CMPLX(ZERO,ONE,fp)

  esv = en + vf*(4.9_fp + 75.0_fp/(ONE + xx*frequency/18.0_fp)-xx*(18.0_fp/frequency)) + &
        vb*(2.9_fp + 55.0_fp/(ONE + SQRT(xx*frequency/0.18_fp)))

  if (AIMAG(esv) >= ZERO) esv = CMPLX(REAL(esv), -0.0001_fp, fp)

end subroutine Canopy_Diel

subroutine Reflectance(em1, em2, theta_i, theta_t, rv, rh)

!----------------------------------------------------------------------------------
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    Reflectance compute the surface reflectivity
!
!   prgmmr:                  org: nesdis              date: 2000-11-28
!
! abstract: compute the surface reflectivety using fresnel equations
!    for a rough surface having a standard deviation of height of sigma
!
! program history log:
!
! input argument list:
!      theta_i      -  incident angle (degree)
!      theta_t      -  transmitted angle (degree)
!      em1          -  dielectric constant of the medium 1
!      em2          -  dielectric constant of the medium 2
!
! output argument list:
!
!      rv           -  reflectivity at vertical polarization
!      rh           -  reflectivity at horizontal polarization
!
! remarks:
!
! attributes:
!   language: f90
!   machine:  ibm rs/6000 sp
!
!----------------------------------------------------------------------------------

  REAL(fp) :: theta_i, theta_t
  REAL(fp) :: rh, rv,cos_i,cos_t
  COMPLEX(fp) :: em1, em2, m1, m2, angle_i, angle_t

  ! compute the refractive index ratio between medium 2 and 1
  ! using dielectric constant (n = SQRT(e))
  cos_i = COS(theta_i)
  cos_t = COS(theta_t)

  angle_i = CMPLX(cos_i, ZERO, fp)
  angle_t = CMPLX(cos_t, ZERO, fp)

  m1 = SQRT(em1)
  m2 = SQRT(em2)

  rv = (ABS((m1*angle_t-m2*angle_i)/(m1*angle_t+m2*angle_i)))**2
  rh = (ABS((m1*angle_i-m2*angle_t)/(m1*angle_i+m2*angle_t)))**2

end subroutine Reflectance

subroutine Transmittance(em1,em2,theta_i,theta_t,tv,th)

!----------------------------------------------------------------------------------
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    Transmittance    calculate Transmittance
!
!   prgmmr:  Banghua Yan and Fuzhong Weng               org: nesdis              date: 2000-11-28
!
! abstract: compute Transmittance
!
! program history log:
!
! input argument list:
!
!      theta        -  local zenith angle (degree)
!      theta_i      -  incident angle (degree)
!      theta_t      -  transmitted angle (degree)
!      em1          -  dielectric constant of the medium 1
!      em2          -  dielectric constant of the medium 2
!
! output argument list:
!
!      tv           -  transmisivity at vertical polarization
!      th           -  transmisivity at horizontal polarization
!
! remarks:
!
! attributes:
!   language: f90
!   machine:  ibm rs/6000 sp
!
!----------------------------------------------------------------------------------

  REAL(fp) :: theta_i, theta_t
  REAL(fp) :: th, tv, rr, cos_i,cos_t
  COMPLEX(fp) :: em1, em2, m1, m2, angle_i, angle_t

  ! compute the refractive index ratio between medium 2 and 1
  ! using dielectric constant (n = SQRT(e))
  cos_i = COS(theta_i)
  cos_t = COS(theta_t)

  angle_i = CMPLX(cos_i, ZERO, fp)
  angle_t = CMPLX(cos_t, ZERO, fp)

  m1 = SQRT(em1)
  m2 = SQRT(em2)

  rr = ABS(m2/m1)*cos_t/cos_i
  tv = rr*(ABS(TWO*m1*angle_i/(m1*angle_t + m2*angle_i)))**2
  th = rr*(ABS(TWO*m1*angle_i/(m1*angle_i + m2*angle_t)))**2

end subroutine Transmittance

subroutine Roughness_Reflectance(frequency,sigma,rv,rh)

!-------------------------------------------------------------------------------------------------------------
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    rought_reflectance    calculate surface relectivity
!
!   prgmmr: Banghua Yan and Fuzhong Weng                 org: nesdis              date: 2000-11-28
!
! abstract: compute the surface reflectivety for a rough surface having a standard devoation of height of sigma
!
!
! program history log:
!
! input argument list:
!
!      frequency    -  frequency (ghz)
!
!      theta        -  local zenith angle (degree) (currently, not used here)
!
!      sigma        -  standard deviation of rough surface height
!
!                      smooth surface:0.38, medium: 1.10, rough:2.15 cm
!
!    internal variables
!
!
! output argument list:
!
!      rv            -  reflectivity at vertical polarization
!      rh            -  reflectivity at horizontal polarization
!
!
!   important internal variables:
!
!      k0           -  a propagation constant or wavenumber in a free space
!
! remarks:
!
! references:
!
!   wang, j. and b. j. choudhury, 1992: passive microwave radiation from soil: examples...
!    passive microwave remote sensing of .. ed. b. j. choudhury, etal vsp.
!    also wang and choudhury (1982)
!
! attributes:
!   language: f90
!   machine:  ibm rs/6000 sp
!
!-------------------------------------------------------------------------------------------------------------

  REAL(fp) :: frequency
  REAL(fp) :: q, rh, rv, rh_s, rv_s, sigma

  rh_s = 0.3_fp*rh
  rv_s = 0.3_fp*rv
  q = 0.35_fp*(ONE - EXP(-0.60_fp*frequency*sigma**TWO))
  rh = rh_s + q*(rv_s-rh_s)
  rv = rv_s + q*(rh_s-rv_s)

end subroutine Roughness_Reflectance

subroutine Two_Stream_Solution(mu,gv,gh,ssalb_h,ssalb_v,tau_h,tau_v, &
      r21_h,r21_v,r23_h,r23_v,t21_v,t21_h,esv,esh,frequency,t_soil,t_skin)

!-------------------------------------------------------------------------------------------------------------
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    two_stream_solution
!
!   prgmmr: Banghua Yan and Fuzhong Weng                 org: nesdis              date: 2000-11-28
!
! abstract: two stream solution
!         Updated with the more accurate formula of total upwelling radiance emanating from the surface.
!
! REFERENCES:
!       Weng, F., B. Yan, and N. Grody, 2001: "A microwave land emissivity model", J. Geophys. Res., 106,
!                                             20, 115-20, 123
!   version: beta
!
! program history log:
!
! input argument list:
!
!      b            -  scattering layer temperature (k)         (gdas)   (not used here)
!      mu           -  cos(theta)
!      gv           -  asymmetry factor for v pol
!      gh           -  asymmetry factor for h pol
!      ssalb_v      -  single scattering albedo at v. polarization
!      ssalb_h      -  single scattering albedo at h. polarization
!      tau_v        -  optical depth at v. polarization
!      tau_h        -  optical depth at h. polarization
!      r12_v        -  reflectivity at vertical polarization   (not used here)
!      r12_h        -  reflectivity at horizontal polarization (not used here)
!      r21_v        -  reflectivity at vertical polarization
!      r21_h        -  reflectivity at horizontal polarization
!      r23_v        -  reflectivity at vertical polarization
!      r23_h        -  reflectivity at horizontal polarization
!      t21_v        -  transmisivity at vertical polarization
!      t21_h        -  transmisivity at horizontal polarization
!      t12_v        -  transmisivity at vertical polarization   (not used here)
!      t12_h        -  transmisivity at horizontal polarization (not used here)
!      Frequency    -  frequency
!      t_soil       -  soil temperature
!      t_skin       -  land surface temperature
!
! output argument list:
!
!       esh         -  emissivity for horizontal polarization
!       esv         -  emissivity for vertical polarization
!
! Local variables:
!       gsect0, gsect1_h, gsect1_v, gsect2_h, gsect2_v
!
! remarks:
!
! attributes:
!   language: f90
!   machine:  ibm rs/6000 sp
!
!-------------------------------------------------------------------------------------------------------------

  REAL(fp) :: mu, gv, gh, ssalb_h, ssalb_v, tau_h,tau_v,                 &
              r21_h, r21_v, r23_h, r23_v, t21_v, t21_h, esv, esh
  REAL(fp) :: alfa_v, alfa_h, kk_h, kk_v, gamma_h, gamma_v, beta_v, beta_h
  REAL(fp) :: fact1,fact2
  REAL(fp) :: frequency, t_soil, t_skin
  REAL(fp) :: gsect0, gsect1_h, gsect1_v, gsect2_h, gsect2_v

  alfa_h  = SQRT((ONE - ssalb_h)/(ONE - gh*ssalb_h))
  kk_h    = SQRT((ONE - ssalb_h)*(ONE -  gh*ssalb_h))/mu
  beta_h  = (ONE - alfa_h)/(ONE + alfa_h)
  gamma_h = (beta_h -r23_h)/(ONE-beta_h*r23_h)

  alfa_v  = SQRT((ONE-ssalb_v)/(ONE - gv*ssalb_v))
  kk_v    = SQRT((ONE-ssalb_v)*(ONE - gv*ssalb_v))/mu
  beta_v  = (ONE - alfa_v)/(ONE + alfa_v)
  gamma_v = (beta_v -r23_v)/(ONE-beta_v*r23_v)

  fact1=gamma_h*EXP(-TWO*kk_h*tau_h)
  fact2=gamma_v*EXP(-TWO*kk_v*tau_v)

  gsect0  =(EXP(C_2*frequency/t_skin) -ONE)/(EXP(C_2*frequency/t_soil) -ONE)

  gsect1_h=(ONE-r23_h)*(gsect0-ONE)
  gsect2_h=((ONE-beta_h*beta_h)/(ONE-beta_h*r23_h))*EXP(-kk_h*tau_h)

  gsect1_v=(ONE-r23_v)*(gsect0-ONE)
  gsect2_v=((ONE-beta_v*beta_v)/(ONE-beta_v*r23_v))*EXP(-kk_h*tau_v)

  esh  = t21_h*((ONE - beta_h)*(ONE + fact1)+gsect1_h*gsect2_h) /(ONE-beta_h*r21_h-(beta_h-r21_h)*fact1)
  esv  = t21_v*((ONE - beta_v)*(ONE + fact2)+gsect1_v*gsect2_v) /(ONE-beta_v*r21_v-(beta_v-r21_v)*fact2)

  if (esh < EMISSH_DEFAULT) esh = EMISSH_DEFAULT
  if (esv < EMISSV_DEFAULT) esv = EMISSV_DEFAULT

  if (esh > ONE) esh = ONE
  if (esv > ONE) esv = ONE

end subroutine Two_Stream_Solution

END MODULE NESDIS_LandEM_Module