!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!                          Futility Development Group                          !
!                             All rights reserved.                             !
!                                                                              !
! Futility is a jointly-maintained, open-source project between the University !
! of Michigan and Oak Ridge National Laboratory.  The copyright and license    !
! can be found in LICENSE.txt in the head directory of this repository.        !
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!> @brief Module provides a non-linear solver class
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
MODULE NonLinearSolverModule
#include "Futility_DBC.h"
USE Futility_DBC
USE ISO_C_BINDING
USE IntrType
USE Constants_Conversion
USE BLAS
USE ParameterLists
USE ParallelEnv
USE FutilityComputingEnvironmentModule
USE VectorTypes
USE MatrixTypes
USE LinearSolverTypes

IMPLICIT NONE
PRIVATE

PUBLIC :: NonLinearSolverInterface_Base
PUBLIC :: NonLinearSolver_Base
PUBLIC :: NonLinearSolver_Native
#ifdef UNIT_TEST
PUBLIC :: testSolverMethod
PUBLIC :: testTPLType
PUBLIC :: testN
PUBLIC :: testIterations
PUBLIC :: testTol
PUBLIC :: testLinSys
PUBLIC :: testFunc
PUBLIC :: testCE
#endif

!> Non-linear solver TPL enumerations
INTEGER(SIK),PARAMETER,PUBLIC :: NLSOLVER_TPL_NATIVE=1
!> Non-linear solver method enumerations
INTEGER(SIK),PARAMETER,PUBLIC :: NLSOLVER_METHOD_BISECTION=1
INTEGER(SIK),PARAMETER,PUBLIC :: NLSOLVER_METHOD_NEWTON=2
INTEGER(SIK),PARAMETER :: VALID_NLSOLVER_METHODS(2)=(/NLSOLVER_METHOD_BISECTION, &
    NLSOLVER_METHOD_NEWTON/)

!> Abstract type for the non-linear solver interface.  Defines procedures
!> for evaluating the function and its jacobian.  The client should extend
!> this class for its specific applications.
TYPE,ABSTRACT :: NonLinearSolverInterface_Base
  PRIVATE
  CONTAINS
    !> @copybrief NonLinearSolverModule::clearInterface_Base
    !> @copydetails NonLinearSolverModule::clearInterface_Base
    PROCEDURE,PASS :: clear => clearInterface_Base
    !> @copybrief NonLinearSolverModule::nonlinearsolver_eval_absintfc
    !> @copydetails NonLinearSolverModule::nonlinearsolver_eval_absintfc
    PROCEDURE(nonlinearsolver_eval_absintfc),DEFERRED,PASS :: eval
    !> @copybrief NonLinearSolverModule::estimate_jacobian
    !> @copydetails NonLinearSolverModule::estimate_jacobian
    PROCEDURE,PASS :: jacobian => estimate_jacobian
    !> @copybrief NonLinearSolverModule::checkBounds_Base
    !> @copydetails NonLinearSolverModule::checkBounds_Base
    PROCEDURE,PASS :: checkBounds => checkBounds_Base
ENDTYPE NonLinearSolverInterface_Base

!> Abstract type for non-linear solver object.  Defines base initialization
!> and clear procedures and the interface for a solve procedure.
TYPE,ABSTRACT :: NonLinearSolver_Base
  PRIVATE
  !> Initialization status
  LOGICAL(SBK),PUBLIC :: isInit=.FALSE.
  !> Enumeration for the method this solver will use
  INTEGER(SIK) :: solverMethod=-1
  !> Enumeration for the TPL this solver will use
  INTEGER(SIK) :: TPLType=-1
  !> Enumeration for the number of unknowns in the system
  INTEGER(SIK) :: n=-1
  !> Number of iterations that were used to solve the system
  INTEGER(SIK) :: iterations=-1
  !> The maximum number of iterations allowed for the solve
  INTEGER(SIK) :: maxIterations=10000
  !> The target tolerance for the system residual, checked by the @checkBounds
  !> method on @c func
  REAL(SRK) :: tol=1.0E-5_SRK
  !> The linear system used to solve each iteration
  CLASS(LinearSolverType_Base),ALLOCATABLE :: linSys
  !> The function wrapper used to evaluate the function and jacobian, as well as
  !> check the convergence of the solution
  CLASS(NonLinearSolverInterface_Base),POINTER :: func => NULL()
  !> Pointer to the computing environment
  TYPE(FutilityComputingEnvironment),POINTER :: ce => NULL()
  CONTAINS
    !> @copybrief NonLinearSolverModule::init_NonLinearSolverBase
    !> @copydetails NonLinearSolverModule::init_NonLinearSolverBase
    PROCEDURE,PASS :: init => init_NonLinearSolverBase
    !> @copybrief NonLinearSolverModule::init_NonLinearSolverBase
    !> @copydetails NonLinearSolverModule::init_NonLinearSolverBase
    PROCEDURE,PASS,NON_OVERRIDABLE :: initBase => init_NonLinearSolverBase
    !> @copybrief NonLinearSolverModule::clear_NonLinearSolverBase
    !> @copydetails NonLinearSolverModule::clear_NonLinearSolverBase
    PROCEDURE,PASS :: clear => clear_NonLinearSolverBase
    !> @copybrief NonLinearSolverModule::clear_NonLinearSolverBase
    !> @copydetails NonLinearSolverModule::clear_NonLinearSolverBase
    PROCEDURE,PASS,NON_OVERRIDABLE :: clearBase => clear_NonLinearSolverBase
    !> @copybrief NonLinearSolverModule::nonlinearsolver_solve_absintfc
    !> @copydetails NonLinearSolverModule::nonlinearsolver_solve_absintfc
    PROCEDURE(nonlinearsolver_solve_absintfc),DEFERRED,PASS :: solve
    !> @copybrief NonLinearSolverModule::continueSolve
    !> @copydetails NonLinearSolverModule::continueSolve
    PROCEDURE,PASS,PRIVATE :: continueSolve
ENDTYPE NonLinearSolver_Base

!> Concrete type for non-linear solver object that uses native vector and
!> matrix objects and native solvers.  Defines concrete implementations
!> required to perform a solve given an abstract function interface.
TYPE,EXTENDS(NonLinearSolver_Base) :: NonLinearSolver_Native
  PRIVATE
  CONTAINS
    !> @copybrief NonLinearSolverModule::init_NonLinearSolverNative
    !> @copydetails NonLinearSolverModule::init_NonLinearSolverNative
    PROCEDURE,PASS :: init => init_NonLinearSolverNative
    !> @copybrief NonLinearSolverModule::clear_NonLinearSolverNative
    !> @copydetails NonLinearSolverModule::clear_NonLinearSolverNative
    PROCEDURE,PASS :: clear => clear_NonLinearSolverNative
    !> @copybrief NonLinearSolverModule::solve_NonLinearSolverNative
    !> @copydetails NonLinearSolverModule::solve_NonLinearSolverNative
    PROCEDURE,PASS :: solve => solve_NonLinearSolverNative
ENDTYPE NonLinearSolver_Native

ABSTRACT INTERFACE
  !> @brief Interface for the @c eval method of a @c NonLinearSolverInterface_Base
  !>        extension
  !> @param this the @c NonLinearSolverInterface_Base object
  !> @param x the @c VectorType to evaluate the function at
  !> @param y the @c VectorType containing the evaluation of the function at @c x
  !>
  SUBROUTINE nonlinearsolver_eval_absintfc(this,x,y)
    IMPORT :: NonLinearSolverInterface_Base,VectorType
    CLASS(NonLinearSolverInterface_Base),INTENT(IN) :: this
    CLASS(VectorType),INTENT(INOUT) :: x
    CLASS(VectorType),INTENT(INOUT) :: y
  ENDSUBROUTINE nonlinearsolver_eval_absintfc

  !> @brief Interface for the @c solve method of a @c NonLinearSolver extension
  !> @param this the @c NonLinearSolver object
  !> @param x the @c VectorType containing the initial guess for the solution
  !>        of the root-finding procedure
  !>
  SUBROUTINE nonlinearsolver_solve_absintfc(this,x)
    IMPORT :: NonLinearSolver_Base,VectorType
    CLASS(NonLinearSolver_Base),INTENT(INOUT) :: this
    CLASS(VectorType),INTENT(INOUT) :: x
  ENDSUBROUTINE nonlinearsolver_solve_absintfc
ENDINTERFACE

!> Module name
CHARACTER(LEN=*),PARAMETER :: modName='NonLinearSolver'

!
!===============================================================================
CONTAINS
!
!-------------------------------------------------------------------------------
!> @brief Defines the interface for clearing a @c NonLinearSolverInterface_Base
!> @param this the object to clear
!>
SUBROUTINE clearInterface_Base(this)
  CLASS(NonLinearSolverInterface_Base),INTENT(INOUT) :: this

  !Does nothing.  This is implemented in case extensions of the interface implement
  !it so we can clear the extensions of this class when clearing the solver itself.

ENDSUBROUTINE clearInterface_Base
!
!-------------------------------------------------------------------------------
!> @brief Checks the bounds of a solution approximation
!> @param this the @c NonLinearSolverInterface_Base object
!> @param x the current solution approximation to check
!> @returns keepSolving a logical indicating whether the solve should continue
!>          or not
!>
!> This procedure defines a default behavior: nothing is checked and the solve will
!> always be told to continue.  Extensions of the @c NonLinearSolverInterface_Base
!> object can implement more advanced techniques.
!>
FUNCTION checkBounds_Base(this,x) RESULT(keepSolving)
  CLASS(NonLinearSolverInterface_Base),INTENT(INOUT) :: this
  CLASS(VectorType),INTENT(INOUT) :: x
  LOGICAL(SBK) :: keepSolving

  REQUIRE(x%isInit)

  keepSolving=.TRUE.

ENDFUNCTION checkBounds_Base
!
!-------------------------------------------------------------------------------
!> @brief Estimates the jacobian of a function
!> @param this the @c NonLinearSolverInterface_Base object
!> @param x the position at which to estimate the jacobian
!> @param J the resulting matrix containing the estimated jacobian
!>
!> This routine evaluates the function at @c x and @c x + @c perturb*x, where
!> @c perturb is a parameter set to 1.000001
!>
SUBROUTINE estimate_jacobian(this,x,J)
  CLASS(NonLinearSolverInterface_Base),INTENT(IN) :: this
  CLASS(VectorType),INTENT(INOUT) :: x
  CLASS(MatrixType),INTENT(INOUT) :: J
  !
  REAL(SRK),PARAMETER :: perturb=1.000001_SRK
  INTEGER(SIK) :: n,m
  REAL(SRK) :: x_real,delx_real,invDelx_real,y_x_real,y_delx_real
  CLASS(VectorType),ALLOCATABLE :: delx,y_x,y_delx

  REQUIRE(x%isInit)
  REQUIRE(J%isInit)
  REQUIRE(x%n > 0)
  REQUIRE(J%n == x%n)

  ALLOCATE(delx,SOURCE=x)
  ALLOCATE(y_x,SOURCE=x)
  ALLOCATE(y_delx,SOURCE=x)

  CALL this%eval(x,y_x)
  DO n=1,x%n
    !Copy the diffusion coefficients and perturb them
    CALL BLAS_copy(x,delx)
    CALL delx%get(n,x_real)
    IF(x_real .APPROXEQ. ZERO) THEN
      delx_real=ONE-perturb
    ELSE
      delx_real=x_real*perturb
    ENDIF
    CALL delx%set(n,delx_real)
    invDelx_real=ONE/(delx_real-x_real)

    !Evaluate the function and store jacobian entries
    CALL this%eval(delx,y_delx)
    DO m=1,x%n
      CALL y_x%get(m,y_x_real)
      CALL y_delx%get(m,y_delx_real)
      CALL J%set(m,n,invDelx_real*(y_delx_real-y_x_real))
    ENDDO !m
  ENDDO !n

ENDSUBROUTINE estimate_jacobian
!
!-------------------------------------------------------------------------------
!> @brief Defines the interface for initializing a @c NonLinearSolver_Base object
!> @param this the object to initialize
!> @param ce the computing environment
!> @param f the @c NonLinearSolverInterface_Base object to use for function evals
!> @param plist the parameter list to use for initialization
!>
!> This procedure takes ownership of @c f and clears the input pointer.  It does
!> not take ownership of @c ce.
!>
SUBROUTINE init_NonLinearSolverBase(this,ce,f,plist)
  CLASS(NonLinearSolver_Base),INTENT(INOUT) :: this
  TYPE(FutilityComputingEnvironment),TARGET,INTENT(IN) :: ce
  CLASS(NonLinearSolverInterface_Base),INTENT(INOUT),TARGET :: f
  TYPE(ParamType),INTENT(IN) :: plist

  REQUIRE(.NOT.this%isInit)
  REQUIRE(plist%has('NonLinearSolver -> n'))
  REQUIRE(plist%has('NonLinearSolver -> method'))

  CALL plist%get('NonLinearSolver -> n',this%n)
  REQUIRE(this%n > 0)
  CALL plist%get('NonLinearSolver -> method',this%solverMethod)
  REQUIRE(ANY(this%solverMethod == VALID_NLSOLVER_METHODS))
  IF(plist%has('NonLinearSolver -> tolerance')) THEN
    CALL plist%get('NonLinearSolver -> tolerance',this%tol)
    REQUIRE(this%tol > ZERO)
  ENDIF
  IF(plist%has('NonLinearSolver -> maxIterations')) THEN
    CALL plist%get('NonLinearSolver -> maxIterations',this%maxIterations)
    REQUIRE(this%maxIterations >= 0)
  ENDIF

  this%ce => ce
  this%func => f

ENDSUBROUTINE init_NonLinearSolverBase
!
!-------------------------------------------------------------------------------
!> @brief Defines the interface for clearing a @c NonLinearSolver_Base object
!> @param this the object to clear
!>
!> This routine clears data on the @c func component and nullifies the pointer
!>
SUBROUTINE clear_NonLinearSolverBase(this)
  CLASS(NonLinearSolver_Base),INTENT(INOUT) :: this

  this%solverMethod=-1
  this%TPLType=-1
  this%n=-1
  this%iterations=-1
  this%maxIterations=10000
  this%tol=1.0E-5_SRK
  CALL this%linSys%clear()
  DEALLOCATE(this%linSys)
  this%ce => NULL()
  IF(ASSOCIATED(this%func)) THEN
    CALL this%func%clear()
  ENDIF
  this%func => NULL()
  this%isInit=.FALSE.

ENDSUBROUTINE clear_NonLinearSolverBase
!
!-------------------------------------------------------------------------------
!> @brief Defines the interface for initializing a @c NonLinearSolver_Native object
!> @param this the object to initialize
!> @param ce the computing environment
!> @param f the @c NonLinearSolverInterface_Base object to use for function evals
!> @param plist the parameter list to use for initialization
!>
!> This procedure takes ownership of @c f and clears the input pointer.  It does
!> not take ownership of @c ce.
!>
SUBROUTINE init_NonLinearSolverNative(this,ce,f,plist)
  CLASS(NonLinearSolver_Native),INTENT(INOUT) :: this
  TYPE(FutilityComputingEnvironment),TARGET,INTENT(IN) :: ce
  CLASS(NonLinearSolverInterface_Base),INTENT(INOUT),TARGET :: f
  TYPE(ParamType),INTENT(IN) :: plist
  !
  CHARACTER(LEN=*),PARAMETER :: myName='init_NonLinearSolverNative'
  TYPE(ParamType) :: linSysPlist

  REQUIRE(.NOT.this%isInit)

  CALL this%initBase(ce,f,plist)

  IF(this%solverMethod == NLSOLVER_METHOD_BISECTION) THEN
    CALL ce%exceptHandler%raiseFatalError(modName//'::'//myName//' - Bisection method '// &
        'is not yet supported by the native NonLinearSolver object!')
  ENDIF
  this%TPLType=NLSOLVER_TPL_NATIVE

  CALL linSysPlist%add('LinearSolverType->TPLType',LINSYS_NATIVE)
  CALL linSysPlist%add('LinearSolverType->solverMethod',GE)
  CALL linSysPlist%add('LinearSolverType->MPI_Comm_ID',PE_COMM_SELF)
  CALL linSysPlist%add('LinearSolverType->numberOMP',1_SNK)
  CALL linSysPlist%add('LinearSolverType->timerName','ODEtimer')
  CALL linSysPlist%add('LinearSolverType->matType',DENSESQUARE)
  CALL linSysPlist%add('LinearSolverType->A->MatrixType->n',this%n)
  CALL linSysPlist%add('LinearSolverType->A->MatrixType->isSym',.FALSE.)
  CALL linSysPlist%add('LinearSolverType->x->VectorType->n',this%n)
  CALL linSysPlist%add('LinearSolverType->b->VectorType->n',this%n)
  ALLOCATE(LinearSolverType_Direct :: this%linSys)
  CALL this%linSys%init(linSysPlist)
  CALL linSysPlist%clear()

  this%isInit=.TRUE.

ENDSUBROUTINE init_NonLinearSolverNative
!
!-------------------------------------------------------------------------------
!> @brief Defines the interface for clearing a @c NonLinearSolver_Native object
!> @param this the object to clear
!>
!> This routine clears data on the @c func component and then deallocates the
!> pointer
!>
SUBROUTINE clear_NonLinearSolverNative(this)
  CLASS(NonLinearSolver_Native),INTENT(INOUT) :: this

  CALL this%clearBase()

ENDSUBROUTINE clear_NonLinearSolverNative
!
!-------------------------------------------------------------------------------
!> @brief Solves a @c NonLinearSolver_Native object
!> @param this the @c NonLinearSolver_Native object to solve
!> @param x @c VectorType containing the initial guess; will be modified to store
!>        final solution
!>
SUBROUTINE solve_NonLinearSolverNative(this,x)
  CLASS(NonLinearSolver_Native),INTENT(INOUT) :: this
  CLASS(VectorType),INTENT(INOUT) :: x
  !
  LOGICAL(SBK) :: lsolve
  CLASS(VectorType),ALLOCATABLE :: y

  REQUIRE(this%isInit)
  REQUIRE(x%isInit)

  IF(this%solverMethod == NLSOLVER_METHOD_NEWTON) THEN
    !Set up the initial solve
    ALLOCATE(y,SOURCE=x)
    CALL this%func%eval(x,y) !Get the solution at the intial guess

    !Check that we actually need to do the solve (initial guess could be correct
    !or user could have set matIterations == 0)
    this%iterations=0
    lsolve=this%continueSolve(y)

    !Solve until all values are under the tolerance
    !  This solves the linear system Jacobian * (x_n+1 - x_n) = -F(x_n)
    !  for the (x_n+1 - x_n) term, then adds that term to x_n to obtain
    !  x_n+1 and update the function evaluation
    DO WHILE(lsolve)
      this%iterations=this%iterations+1
      !Set the RHS to the negative of the previous function evaluation
      CALL this%linSys%b%set(0.0_SRK)
      CALL BLAS_axpy(y,this%linSys%b,-1.0_SRK)
      !Approximate jacobian and store in linSys LHS
      CALL this%func%jacobian(x,this%linSys%A)
      !Solve the linSys
      CALL this%linSys%solve()
      !Add the linSys solution to x to get the new position
      CALL BLAS_axpy(this%linSys%x,x)

      !Enforce all parts of the solution to be in-bounds and allow the function
      !evaluator to stop the solve if certain conditions are met
      lsolve=this%func%checkBounds(x)

      !Update the solution
      CALL this%func%eval(x,y)

      !Check the stop conditions
      lsolve = lsolve .AND. this%continueSolve(y)
    ENDDO
  ENDIF

ENDSUBROUTINE solve_NonLinearSolverNative
!
!-------------------------------------------------------------------------------
!> @brief Checks stop criteria on a @c NonLinearSolver_Native object
!> @param this the @c NonLinearSolver_Native object being solved
!> @param y the current solution to check
!> @returns keepSolving logical indicating if the solver should keep solving
!>
!> If the absolute value of each element of @c y is less than the solver's
!> tolerance or if the maximum number of iterations has been reached, then
!> @c keepSolving will be set to false.  Otherwise, it will be set to true.
!>
FUNCTION continueSolve(this,y) RESULT(keepSolving)
  CLASS(NonLinearSolver_Base),INTENT(IN) :: this
  CLASS(VectorType),INTENT(INOUT) :: y
  LOGICAL(SBK) :: keepSolving
  !
  REAL(SRK),ALLOCATABLE :: vec2real(:)

  ALLOCATE(vec2real(this%n))
  CALL y%get(vec2real)
  keepSolving=.TRUE.

  !Convergence has been reached
  IF(ALL(ABS(vec2real) < this%tol)) THEN
    keepSolving=.FALSE.
  ENDIF
  !Max iterations reached
  IF(this%iterations >= this%maxIterations) THEN
    keepSolving=.FALSE.
  ENDIF

ENDFUNCTION continueSolve
!
!-------------------------------------------------------------------------------
#ifdef UNIT_TEST
!> List of test procedures to allow access to PRIVATE components of module-defined
!> extended types.
FUNCTION testSolverMethod(this) RESULT(val)
  CLASS(NonLinearSolver_Base),INTENT(IN) :: this
  INTEGER(SIK) :: val
  val=this%solverMethod
ENDFUNCTION testSolverMethod
FUNCTION testTPLType(this) RESULT(val)
  CLASS(NonLinearSolver_Base),INTENT(IN) :: this
  INTEGER(SIK) :: val
  val=this%TPLType
ENDFUNCTION testTPLType
FUNCTION testN(this) RESULT(val)
  CLASS(NonLinearSolver_Base),INTENT(IN) :: this
  INTEGER(SIK) :: val
  val=this%n
ENDFUNCTION testN
FUNCTION testIterations(this) RESULT(val)
  CLASS(NonLinearSolver_Base),INTENT(IN) :: this
  INTEGER(SIK) :: val
  val=this%iterations
ENDFUNCTION testIterations
FUNCTION testTol(this) RESULT(val)
  CLASS(NonLinearSolver_Base),INTENT(IN) :: this
  REAL(SRK) :: val
  val=this%tol
ENDFUNCTION testTol
SUBROUTINE testLinSys(this,val)
  CLASS(NonLinearSolver_Base),INTENT(IN) :: this
  CLASS(LinearSolverType_Base),ALLOCATABLE,INTENT(OUT) :: val
  IF(ALLOCATED(this%linSys)) THEN
    ALLOCATE(val,SOURCE=this%linSys)
  ENDIF
ENDSUBROUTINE testLinSys
FUNCTION testFunc(this) RESULT(val)
  CLASS(NonLinearSolver_Base),INTENT(IN) :: this
  CLASS(NonLinearSolverInterface_Base),POINTER :: val
  val => this%func
ENDFUNCTION testFunc
FUNCTION testCE(this) RESULT(val)
  CLASS(NonLinearSolver_Base),INTENT(IN) :: this
  TYPE(FutilityComputingEnvironment),POINTER :: val
  val => this%ce
ENDFUNCTION testCE
#endif
!
ENDMODULE NonLinearSolverModule


      program STRAY_LIGHT

      implicit none
      include 'constants'
      include 'parameters'
      double precision COORD_SAT(1:3), RA_SAT, DEC_SAT, R_SAT
      double precision RA_SUN, DEC_SUN
      double precision RA_STAR, DEC_STAR
      double precision ALFA(1:n_targets_max), DELTA(1:n_targets_max)
	double precision copy_DELTA(1:n_targets_max)
      double precision coord(1:n_alpha, 1:n_delta),
     &     coord_illum(1:n_alpha, 1:n_delta),
     &     coord_photons(1:n_alpha,1:n_delta),
     &     angle_photons(1:n_alpha,1:n_delta),
     &     pst_photons(1:n_alpha,1:n_delta),
     &     proj_surf(1:n_alpha,1:n_delta),
     &     day_night(1:n_alpha, 1:n_delta),
     &	   COORD_SUN(1:3)
      double precision straylight_flux

      integer N_TARGETS, i, count_error

      logical photons_hit, error

      photons_hit = .false.

c--------------------------------------------------------------------------------
c     READ INPUT FILES

      if(include_pst) call READ_PST

      call READ_COORD_SATELLITE(COORD_SAT,RA_SAT,DEC_SAT,R_SAT)

      call READ_NUMBER_TARGETS(N_TARGETS)

      call READ_TARGET_LIST(N_TARGETS, ALFA, DELTA)

      call READ_COORD_SUN(RA_SUN, DEC_SUN, COORD_SUN)
c--------------------------------------------------------------------------------
c     Coordinates of the illuminated part of the Earth by the SUN

      call ILLUMINATED_EARTH(RA_SUN, DEC_SUN, !I
     &     day_night)           !O

c--------------------------------------------------------------------------------
c     Calculate the coordinates of the Earth as seen from the satellite
      call EARTH_SEEN_FROM_SAT(COORD_SAT, RA_SAT, DEC_SAT, day_night, !Input
     &     coord_illum)               !Output

c--------------------------------------------------------------------------------
c     Calculate the coordinates of the illuminated Earth that the satellite sees

	count_error = 0

	open(unit=211, file='../OUTPUT/straylight.out')

	do i = 1, N_TARGETS

         DEC_STAR = DELTA(i)
         RA_STAR = ALFA(i)

c--------------------------------------------------------------------------------
c     Given the coordinates of the target star, we caculate the energy
c     at the telescope for the given direction

         call PHOTONS_AT_TELESCOPE(coord_illum, RA_STAR,	! Input
     &        DEC_STAR, COORD_SAT,
     &        coord_photons, photons_hit,				! Output
     & 	      angle_photons, pst_photons, error)

	if (.not. error) then
         if(photons_hit) then

c     for the regions where the photons that hit the detector come we:
c     1) take into account the orientation of the satellite or include the PST

            call TOTAL_PHOTONS_AT_TELESCOPE(coord_photons,
     &           angle_photons,  pst_photons, COORD_SAT,
     &		RA_SAT,DEC_SAT, day_night,  !Input
     &           straylight_flux)          !Output
         else
            straylight_flux = 0.d0
         endif

c	2) Finally, we write the result for this particular direction into the output file.
	 write(211,*) RA_STAR,DEC_STAR,straylight_flux
	else
		count_error = count_error + 1
	endif

      enddo

      close(211)! close flux file

	if (verbose .and. count_error .gt. 0) write(*,"(I2,a17)")
     & count_error,' points discarded'

      END


! EVP dynamics of ice module
subroutine ice_evp
    use schism_glbl,only: rkind,time_stamp,rnday,eta2,np,ne,nea, &
   &elnode,i34,dldxy,cori,grav,isbnd,indel,nne,area,iself,fdb,lfdb, &
   &xnd,ynd,iplg,ielg,elside,mnei,rho0,idry,errmsg,npa
    use schism_msgp, only: myrank,nproc,parallel_abort,exchange_p2d
    use ice_module
    use ice_therm_mod
    use icedrv_main,   only: rdg_conv_elem, rdg_shear_elem,icepack_to_schism, &
    &dt_dyn

    implicit none
    integer :: isub,i,j,ie,n1,n2,icount,m,id
    real(rkind) :: dtevp,t_evp_inv,det1,det2,tmp1,tmp2,sum1,sum2, &
   &pp0,delta,delta_inv,rr1,rr2,rr3,sig1,sig2,x10,x20,y10,y20,rl10, &
   &rl20,sintheta,bb1,bb2,h_ice_el,a_ice_el,h_snow_el,dsig_1,dsig_2,mass, &
   &cori_nd,umod,gam1,rx,ry,rxp,ryp,eps11,eps12,eps22, &
   &zeta,delta_nd

    integer :: iball(mnei),n
    real(rkind) :: swild(2,3),swild2(nea),deta(2,nea),p_ice(3)

    dtevp=dt_dyn/evp_rheol_steps
    t_evp_inv=3/dt_dyn !inverse of T
    det1=1./(1+0.5*dtevp*t_evp_inv) !used in solving EVP eqs
    det2=1./(1+0.5*ellipse*ellipse*dtevp*t_evp_inv)

    rdg_conv_elem(:)  = 0.0
    rdg_shear_elem(:) = 0.0

    do isub=1,evp_rheol_steps
      !Update stress @ elem
      call icepack_to_schism (nx_in=npa, &
                  aice_out=a_ice0,                 &
                  vice_out=m_ice0,                 &
                  vsno_out=m_snow0)
      do i=1,nea
  !      if(h_ice(i)<=ice_cutoff.or.a_ice(i)<=ice_cutoff) then
  !        sigma11(i)=0; sigma12(i)=0; sigma22(i)=0; delta_ice(i)=0
  !        cycle
  !      endif

        eps11=dot_product(U_ice(elnode(1:i34(i),i)),dldxy(1:i34(i),1,i)) !epsilon11=du_dx
        eps22=dot_product(V_ice(elnode(1:i34(i),i)),dldxy(1:i34(i),2,i)) !epsilon22=dv_dy
        tmp1=dot_product(U_ice(elnode(1:i34(i),i)),dldxy(1:i34(i),2,i)) !du_dy
        tmp2=dot_product(V_ice(elnode(1:i34(i),i)),dldxy(1:i34(i),1,i)) !dv_dx
        eps12=0.5*(tmp1+tmp2) !epsilon12
        !Deformation rate
        tmp1=eps11+eps22 !divergence
        tmp2=(eps11-eps22)**2+4*eps12*eps12 !shear strain rate squared
        delta_ice(i)=sqrt(tmp1*tmp1+tmp2/ellipse/ellipse)

        rdg_conv_elem(i)  = -min((eps11+eps22),0.0)
        rdg_shear_elem(i) = 0.5*(delta_ice(i) - abs(eps11+eps22))

        h_ice_el=sum(m_ice0(elnode(1:3,i)))/3.0
        a_ice_el=sum(a_ice0(elnode(1:3,i)))/3.0
        pp0=h_ice_el*pstar*exp(-c_pressure*(1-a_ice_el)) !P_0
        zeta=pp0*0.5/max(delta_ice(i),delta_min)

        rr1=zeta*t_evp_inv*(eps11+eps22-delta_ice(i)) !RHS for 1st eq
        rr2=zeta*t_evp_inv*(eps11-eps22)
        rr3=zeta*t_evp_inv*eps12
        sig1=sigma11(i)+sigma22(i) !from previous step
        sig2=sigma11(i)-sigma22(i)

        sig1=det1*(sig1+rr1*dtevp)
        sig2=det2*(sig2+rr2*dtevp)

        sigma12(i)=det2*(sigma12(i)+rr3*dtevp)
        sigma11(i)=0.5*(sig1+sig2)
        sigma22(i)=0.5*(sig1-sig2)
      enddo !i=1,nea

  !    if(isub==evp_rheol_steps.and.it_main==1) then
  !      do i=1,nea
  !        write(96,*)i,real(sigma11(i))
  !        write(95,*)i,real(sigma12(i))
  !        write(94,*)i,real(sigma22(i))
  !      enddo !i
  !      close(94); close(95); close(96);
  !    endif

      !RHS of mom eq
      !Derivatives of stress: projection/reconstruction method
  !    dsigdxy=0 !init
  !    do i=1,ne
  !      dsigdxy(i,1,1)=dot_product(sigma11(elnode(1:i34(i),i)),dldxy(1:i34(i),1,i)) !d{sigma11}/dx
  !      dsigdxy(i,2,3)=dot_product(sigma22(elnode(1:i34(i),i)),dldxy(1:i34(i),2,i)) !d{sigma22}/dy
  !      dsigdxy(i,1,2)=dot_product(sigma12(elnode(1:i34(i),i)),dldxy(1:i34(i),1,i)) !d{sigma12}/dx
  !      dsigdxy(i,2,2)=dot_product(sigma12(elnode(1:i34(i),i)),dldxy(1:i34(i),2,i)) !d{sigma12}/dy
  !    enddo !i
  !
  !    do i=1,3
  !      do j=1,2
  !        swild2=dsigdxy(:,j,i)
  !        call exchange_e2d(swild2)
  !        dsigdxy(:,j,i)=swild2
  !      enddo !j
  !    enddo !i

      !Coriolis @ elem
      do i=1,nea
        swild2(i)=sum(cori(elside(1:i34(i),i)))/i34(i)
        !Pressure gradient @elem
        if(ice_tests==1) then
          deta(1,i)=swild2(i)*sum(v_ocean(elnode(1:i34(i),i)))/i34(i)/grav
          deta(2,i)=-swild2(i)*sum(u_ocean(elnode(1:i34(i),i)))/i34(i)/grav
        else
          if(maxval(idry(elnode(1:i34(i),i)))/=0) then !dry
            deta(1:2,i)=0
          else !wet
            p_ice=(rhoice*m_ice0(elnode(1:i34(i),i))+rhosno*m_snow0(elnode(1:i34(i),i)))/rho0
            do n=1,3
              p_ice(n)=min(p_ice(n),5.0)
            end do
            deta(1,i)=dot_product((eta2(elnode(1:i34(i),i))+p_ice(1:3)),dldxy(1:i34(i),1,i))
            deta(2,i)=dot_product((eta2(elnode(1:i34(i),i))+p_ice(1:3)),dldxy(1:i34(i),2,i))
          endif !dry
        endif !
      enddo !i

      !Solve mom eq.
      do i=1,np !resident
        if(isbnd(1,i)/=0) then !b.c. (including open)
          U_ice(i)=0; V_ice(i)=0
          cycle
        endif

        iball(1:nne(i))=indel(1:nne(i),i)
        if(a_ice0(i)<=ice_cutoff.or.m_ice0(i)<=ice_cutoff) then !no ice
          U_ice(i)=0; V_ice(i)=0
          cycle
        endif

        !Not bnd node; has ice
        mass=(rhoice*m_ice0(i)+rhosno*m_snow0(i)) !>0
        !mass=max(mass,9*a_ice0(i))
        !Error: limit mass>9?
        !Coriolis @ node
        cori_nd=dot_product(weit_elem2node(1:nne(i),i),swild2(iball(1:nne(i))))
        !Debug
        !if(isub==1.and.it_main==1) then
        !  write(93,*)i,real(xnd(i)),real(ynd(i)),real(),real(cori_nd) !,real(h_ice_nd),real(mass)
        !endif

        !RHS
  !Error: tri only
        umod=sqrt((U_ice(i)-u_ocean(i))**2+(V_ice(i)-v_ocean(i))**2)
        gam1=a_ice0(i)/mass*cdwat*rho0*umod
        rxp=a_ice0(i)*stress_atmice_x(i)/mass
        ryp=a_ice0(i)*stress_atmice_y(i)/mass
        !Pressure gradient
        sum1=0; sum2=0
        do j=1,nne(i)
          ie=indel(j,i)
          h_ice_el=sum(m_ice0(elnode(1:3,ie)))/3.0
          h_snow_el=sum(m_snow0(elnode(1:3,ie)))/3.0
          tmp1=rhoice*h_ice_el+rhosno*h_snow_el !mass @elem
          sum1=sum1+tmp1*deta(1,ie)*area(ie)/3
          sum2=sum2+tmp1*deta(2,ie)*area(ie)/3
        enddo !j
        rxp=rxp-grav*sum1/mass/area_median(i)
        ryp=ryp-grav*sum2/mass/area_median(i)
        !Stress
        sum1=0; sum2=0
        do j=1,nne(i)
          ie=indel(j,i)
          id=iself(j,i)
          sum1=sum1+area(ie)*(dldxy(id,1,ie)*sigma11(ie)+dldxy(id,2,ie)*sigma12(ie))
          sum2=sum2+area(ie)*(dldxy(id,1,ie)*sigma12(ie)+dldxy(id,2,ie)*sigma22(ie))
        enddo !j
        rxp=rxp-sum1/mass/area_median(i)
        ryp=ryp-sum2/mass/area_median(i)

        rx=U_ice(i)+rxp*dtevp+gam1*dtevp*(u_ocean(i)*cos_io-v_ocean(i)*sin_io)
        ry=V_ice(i)+ryp*dtevp+gam1*dtevp*(u_ocean(i)*sin_io+v_ocean(i)*cos_io)

        tmp1=1+gam1*dtevp*cos_io
        tmp2=dtevp*(cori_nd+gam1*sin_io)
        delta=tmp1*tmp1+tmp2*tmp2
        if(delta<=0) call parallel_abort('ice_evp: delta<=0')
        U_ice(i)=(rx*tmp1+ry*tmp2)/delta
        V_ice(i)=(-rx*tmp2+ry*tmp1)/delta
        if(abs(U_ice(i))>0.5) then
          U_ice(i)=0.5*U_ice(i)/abs(U_ice(i))
        endif
        if(abs(V_ice(i))>0.5) then
          V_ice(i)=0.5*V_ice(i)/abs(V_ice(i))
        endif
        !Debug
        !if(isub==evp_rheol_steps.and.it_main==1) then
        !  write(92,*)real(xnd(i)),real(ynd(i)),real(U_ice(i)),real(V_ice(i))
        !endif
      enddo !i=1,np
      do i=1,nea
        if(maxval(idry(elnode(1:i34(i),i)))/=0) then
          U_ice(elnode(1:i34(i),i))=0
          V_ice(elnode(1:i34(i),i))=0
        endif
      enddo
      call exchange_p2d(U_ice)
      call exchange_p2d(V_ice)
    enddo !isub: sub-cycling

    !Check NaN
  !  do i=1,nea
  !    if(sigma11(i)/=sigma11(i).or.sigma12(i)/=sigma12(i).or.sigma22(i)/=sigma22(i)) then
  !      write(errmsg,*)'NaN in ice_evp (1):',ielg(i),sigma11(i),sigma12(i),sigma22(i)
  !      call parallel_abort(errmsg)
  !    endif
  !  enddo !i
  !  do i=1,npa
  !    if(U_ice(i)/=U_ice(i).or.V_ice(i)/=V_ice(i)) then
  !      write(errmsg,*)'NaN in ice_evp (2):',iplg(i),U_ice(i),V_ice(i)
  !      call parallel_abort(errmsg)
  !    endif
  !  enddo !i

    !Debug
  !  if(abs(time_stamp-rnday*86400)<0.1) then
  !    fdb='iceuv_0000'
  !    lfdb=len_trim(fdb)
  !    write(fdb(lfdb-3:lfdb),'(i4.4)') myrank
  !    open(10,file='outputs/'//fdb,status='replace')
  !    write(10,*)np,nproc
  !    do i=1,np
  !      write(10,'(i11,3(1x,e20.12))')iplg(i),xnd(i),ynd(i),U_ice(i),V_ice(i)
  !    enddo !i
  !    close(10)
  !
  !    fdb='icedel_0000'
  !    lfdb=len_trim(fdb)
  !    write(fdb(lfdb-3:lfdb),'(i4.4)') myrank
  !    open(10,file='outputs/'//fdb,status='replace')
  !    write(10,*)ne
  !    do i=1,ne
  !      write(10,*)ielg(i),delta_ice(i)
  !    enddo !i
  !    close(10)
  !  endif

  end subroutine ice_evp