*----------------------------------------------------------------------*
!>     solve eigenvalue problem  Mx = lambda x
!!
!!     the formula with label "label_form" describes how to calculate
!!     the matrix trial-vector products and the r.h.s.
!!
!!     @para nopt                  number of x operators to be solved for
!!                           in case of coupled equations
!!     @param nroots                number of roots per x operator
!!     @param targ_root             the target root per x operator
!!
!!     @param label_opt(nopt)       label of solution vectors
!!     @param label_prc(nopt)       label of preconditioners
!!     @param label_op_mvp(nopt)    label operators describing Mx-products
!!     @param label_op_met(nopt)    label operators describing Sx-products
!!                                  if S is unity, pass label of operator
!!                                   associated with ME-list label_opt
!!
!!     the latter two are used to initilize temporary ME-lists
!!
!!     @param op_info:   operator/ME-list definitions
!!     @param form_info: formula definitions
!!     @param str_info: string information (to be passed to subroutines)
!!     @param strmap_info: string mappings (to be passed to subroutines)
!!     @param orb_info: orbital space information (to be passed)
!!
!!     @param thr_suggest: allows weaker convergence threshold
!!
!!     'choice' is used to prefer a particular operator over other for the guess
!!     choice = 0 (default), consider all the operators involved
!!     choice = iopt, consider operator iopt, iopt=1,nopt, nopt is the number
!!              of operators involved
!!     init: it is used to initialise guesses for each of list_opt(s)
!!           from existing files instead of going through 'init_guess'.
!!           The same can also be done using the keyword 'calculate.solve.eigen.resume',
!!           But that would be imposed to all the calls of this solver during the process.
!----------------------------------------------------------------------*
      subroutine solve_evp(mode_str,
     &     nopt,nroots,targ_root,label_opt,label_prc,label_op_mvp,
     &     label_op_met,label_form,
     &     label_special,nspecial,label_spcfrm,nspcfrm,thr_suggest,
     &     choice_opt,init,
     &     op_info,form_info,str_info,strmap_info,orb_info)
*----------------------------------------------------------------------*
      implicit none             ! for sure

      include 'opdim.h'
      include 'stdunit.h'
      include 'ioparam.h'
      include 'mdef_operator_info.h'
      include 'def_graph.h'
      include 'def_strinf.h'
      include 'def_strmapinf.h'
      include 'def_orbinf.h'
      include 'def_optimize_info.h'
      include 'def_file_array.h'
      include 'def_optimize_status.h'
      include 'def_contraction.h'
      include 'def_formula_item.h'
      include 'mdef_formula_info.h'
      include 'def_dependency_info.h'
      include 'ifc_memman.h'
      include 'mdef_target_info.h'
      include 'ifc_input.h'
      include 'molpro_out.h'

      integer, parameter ::
     &     ntest = 000

      integer, intent(in) ::
     &     nopt, nroots, nspecial, nspcfrm, targ_root,choice_opt
      character(*), intent(in) ::
     &     mode_str,
     &     label_opt(nopt),
     &     label_prc(nopt),
     &     label_op_mvp(nopt),
     &     label_op_met(nopt),
     &     label_special(nspecial),
     &     label_spcfrm(nspcfrm),
     &     label_form
      real(8), intent(in) ::
     &     thr_suggest
      type(formula_info) ::
     &     form_info
      type(operator_info) ::
     &     op_info
      type(strinf) ::
     &     str_info
      type(strmapinf) ::
     &     strmap_info
      type(orbinf) ::
     &     orb_info
      logical, intent(in) ::
     &     init

      logical ::
     &     conv, use_s_t, use_s(nopt), trafo, use_init_guess(nopt),
     &     home_in, restart, error
      character(len_opname) ::
     &     label
      integer ::
     &     iter, iprint, task, ifree, iopt, jopt, nintm, irequest,
     &     nrequest, nvectors, iroot, idx, ierr, idxmel, nout,
     &     jdx, nspec_, nextra_, idxspc
      real(8) ::
     &     xresmax, xdum, xnrm,
     &     xeig(nroots,2), xresnrm(nroots*nopt),
     &     old_eig(nroots,2)
      type(me_list_array), pointer ::
     &     me_opt(:), me_dia(:), me_trv(:), me_mvp(:), me_met(:),
     &     me_special(:), me_scr(:), me_home(:), me_ext(:)
      type(file_array), pointer ::
     &     ffdia(:), ff_trv(:),
     &     ffopt(:), ff_mvp(:), ff_met(:), ffspecial(:), ff_scr(:),
     &     ffhome(:), ff_ext(:)
      type(me_list), pointer ::
     &     me_pnt
      type(dependency_info) ::
     &     depend
      type(optimize_info) ::
     &     opti_info
      type(optimize_status) ::
     &     opti_stat
      type(formula), pointer ::
     &     form_mvp
      type(formula_item) ::
     &     fl_mvp, fl_spc(nspcfrm)

      integer, pointer ::
     &     irecmvp(:), irectrv(:), irecmet(:)
      real(8), pointer ::
     &      xret(:), xbuf1(:), xbuf2(:), xoverlap(:)

      character ::
     &     fname*256

      logical, external ::
     &     file_exists
      integer, external ::
     &     idx_formlist, idx_mel_list, idx_xret
      real(8), external ::
     &     fndmnx, da_ddot

      real(8)::
     &     cpu0_r,sys0_r,wall0_r, ! beginning of a rule
     &     cpu0_t,sys0_t,wall0_t, ! beginning of a target
     &     cpu,sys,wall ! variables for timing information
      character(len=512)::
     &     timing_msg
      character(len=50)::
     &     output
      character(len=80)::
     &     mol_format,
     &     mol_format2
      real(8)::
     &     time_per_it
      integer ::
     &     i, print_iter

      ifree = mem_setmark('solve_evp')

      if (ntest.ge.100) then
        call write_title(lulog,wst_dbg_subr,'entered solve_evp')
        write(lulog,*) 'nopt   = ',nopt
        write(lulog,*) 'nroots = ',nroots
        write(lulog,*) 'targ_root = ',targ_root
      end if

      idx = idx_formlist(label_form,form_info)
      if (idx.le.0)
     &     call quit(1,'solve_evp',
     &     'did not find formula '//trim(label_form))
      form_mvp => form_info%form_arr(idx)%form

      allocate(me_opt(nopt),me_dia(nopt),me_trv(nopt),me_mvp(nopt),
     &      me_met(nopt),me_special(nspecial),me_scr(nopt),me_ext(nopt))
      allocate(ffopt(nopt),ffdia(nopt),
     &     ff_trv(nopt),ff_mvp(nopt),ff_met(nopt),ffspecial(nspecial),
     &     ff_scr(nopt),ff_ext(nopt))
      do iopt = 1, nopt
        ! pointer array for operators:
        ierr = 1
        jopt = iopt
        idxmel = idx_mel_list(label_opt(iopt),op_info)
        if (idxmel.le.0) exit
        ierr = 2
        me_opt(iopt)%mel   => op_info%mel_arr(idxmel)%mel
        ffopt(iopt)%fhand => op_info%mel_arr(idxmel)%mel%fhand
        if (.not.associated(ffopt(iopt)%fhand)) exit
        ierr = 3
        jopt = iopt
        idxmel = idx_mel_list(label_prc(iopt),op_info)
        if (idxmel.le.0) exit
        me_dia(iopt)%mel   => op_info%mel_arr(idxmel)%mel
        ierr = 4
        ffdia(iopt)%fhand => op_info%mel_arr(idxmel)%mel%fhand
        if (.not.associated(ffdia(iopt)%fhand)) exit
        ierr = 0
      end do

      ! special lists needed?
      if (ierr.eq.0) then
        do idx = 1, nspecial
          jopt = idx
          idxmel = idx_mel_list(label_special(idx),op_info)
          ierr = 5
          if (idxmel.le.0) exit
          me_special(idx)%mel  => op_info%mel_arr(idxmel)%mel
          ffspecial(idx)%fhand => op_info%mel_arr(idxmel)%mel%fhand
          ierr = 6
          if (.not.associated(ffspecial(idx)%fhand)) exit
          ierr = 0
        end do
      end if

      ! error handling
      if (ierr.gt.0) then
        if (ierr.eq.1.or.ierr.eq.2) label = label_opt(jopt)
        if (ierr.eq.3.or.ierr.eq.4) label = label_prc(jopt)
        if (ierr.eq.5.or.ierr.eq.6) label = label_special(jopt)
        if (mod(ierr,2).eq.1)
     &       call quit(1,'solve_evp',
     &       'did not find list '//trim(label))
        if (mod(ierr,2).eq.0)
     &       call quit(1,'solve_evp',
     &       'no file associated with list '//trim(label))
      end if

      ! special formulae
      do jdx = 1, nspcfrm
        idx = idx_formlist(label_spcfrm(jdx),form_info)
        if (idx.le.0)
     &       call quit(1,'solve_evp',
     &       'did not find formula '//trim(label_spcfrm(jdx)))
        ! read formula
        call read_form_list(form_info%form_arr(idx)%form%fhand,
     &                      fl_spc(jdx),.true.)
      end do

      call set_opti_info(opti_info,3,nopt,nroots,me_opt,mode_str)

      ! do some postprocessing of options and make sure they fit
      ! to current code (which is not as flexible as it should be)
      ! in particular there are a number of assumptions about the
      ! "special" lists and formulas
      nspec_ = nspecial
      idxspc = 1
      error = .false.
      do iopt = 1, nopt
        if (opti_info%typ_prc(iopt).eq.optinf_prc_traf.or.
     &      opti_info%typ_prc(iopt).eq.optinf_prc_traf_spc) then
          if (iopt.ne.1) then
            write(lulog,*)
     &      'Detected TRF or TR0 option, but not for first vector!'
            error = .true.
          end if
        end if
        if (opti_info%typ_prc(iopt).eq.optinf_prc_spinp.or.
     &      opti_info%typ_prc(iopt).eq.optinf_prc_prj.or.
     &      opti_info%typ_prc(iopt).eq.optinf_prc_spinrefp) then
          if (nopt.gt.1.and.iopt.ne.2) then
            write(lulog,*)
     &       'Detected SPP, PRJ or SRP option in coupled equations,'
            write(lulog,*)
     &       'but the vector is not the second!'
            error = .true.
          end if
          ! SPP and SRP have one extra ME list that we need to "hide"
          if (opti_info%typ_prc(iopt).ne.optinf_prc_prj) then
            nspec_ = nspec_-1  ! # "special" lists for TRF (if there)
            idxspc = nspecial  ! idx "special" list for SPP or SRP
          end if
        end if
      end do
      nextra_ = nspecial - nspec_

      if (error) call quit(1,'solve_evp',
     &                       'Error in use of routine, see output')

      nvectors = opti_info%maxsbsp
      use_s_t = .false.

      do iopt = 1, nopt
        ! weaker convergence threshold requested?
        opti_info%thrgrd(iopt)=max(opti_info%thrgrd(iopt),thr_suggest)

        ! get a ME-list for scratch trial-vectors
        ! in case of ab-sym braking trafo, get sym props from special list
        if (opti_info%typ_prc(iopt).eq.optinf_prc_traf
     &      .and.nspecial.ge.3) then
          me_pnt => me_special(1)%mel
        elseif (opti_info%typ_prc(iopt).eq.optinf_prc_traf_spc)then
           me_pnt => me_special(4)%mel
        else
          me_pnt => me_opt(iopt)%mel
        end if
        write(fname,'("scr_",i3.3)') iopt
        call define_me_list(fname,me_opt(iopt)%mel%op%name,
     &       me_pnt%absym,me_pnt%casym,
     &       me_pnt%gamt,me_pnt%s2,
     &       me_pnt%mst,.false.,
     &       -1,1,nvectors,0,0,0,
     &       op_info,orb_info,str_info,strmap_info)
        idxmel = idx_mel_list(fname,op_info)
        me_scr(iopt)%mel   => op_info%mel_arr(idxmel)%mel
        ff_scr(iopt)%fhand => op_info%mel_arr(idxmel)%mel%fhand

        ! Here is a new ME-list that will be fed in the
        ! routine 'optc_minspace'. Previously ff_scr was
        ! used there but the use was erroneous
        write(fname,'("ext_",i3.3)') iopt
        call define_me_list(fname,me_opt(iopt)%mel%op%name,
     &       me_pnt%absym,me_pnt%casym,
     &       me_pnt%gamt,me_pnt%s2,
     &       me_pnt%mst,.false.,
     &       -1,1,nvectors,0,0,0,
     &       op_info,orb_info,str_info,strmap_info)
        idxmel = idx_mel_list(fname,op_info)
        me_ext(iopt)%mel   => op_info%mel_arr(idxmel)%mel
        ff_ext(iopt)%fhand => op_info%mel_arr(idxmel)%mel%fhand

        ! get a ME-list for trial-vectors
        write(fname,'("trv_",i3.3)') iopt
        call define_me_list(fname,me_opt(iopt)%mel%op%name,
     &       me_opt(iopt)%mel%absym,me_opt(iopt)%mel%casym,
     &       me_opt(iopt)%mel%gamt,me_opt(iopt)%mel%s2,
     &       me_opt(iopt)%mel%mst,.false.,
     &       -1,1,nvectors,0,0,0,
     &       op_info,orb_info,str_info,strmap_info)
        idxmel = idx_mel_list(fname,op_info)
        me_trv(iopt)%mel   => op_info%mel_arr(idxmel)%mel
        ff_trv(iopt)%fhand => op_info%mel_arr(idxmel)%mel%fhand

        ! get a ME list for matrix-vector products
        ! (have same symmtry properties as result!)
        write(fname,'("mvp_",i3.3)') iopt
        call define_me_list(fname,label_op_mvp(iopt),
     &       me_opt(iopt)%mel%absym,me_opt(iopt)%mel%casym,
     &       me_opt(iopt)%mel%gamt,me_opt(iopt)%mel%s2,
     &       me_opt(iopt)%mel%mst,.false.,
     &       -1,1,nvectors,0,0,0,
     &       op_info,orb_info,str_info,strmap_info)
        idxmel = idx_mel_list(fname,op_info)
        me_mvp(iopt)%mel   => op_info%mel_arr(idxmel)%mel
        ff_mvp(iopt)%fhand => op_info%mel_arr(idxmel)%mel%fhand

        ! use of metric requested?
        use_s(iopt) = trim(label_op_met(iopt)).ne.
     &       trim(me_opt(iopt)%mel%op%name)
        if (use_s(iopt)) then
          use_s_t = .true.
          ! get a ME list for metric-times-vector products
          ! (have same symmtry properties as result!)
          write(fname,'("svp_",i3.3)') iopt
          call define_me_list(fname,label_op_met(iopt),
     &         me_opt(iopt)%mel%absym,me_opt(iopt)%mel%casym,
     &         me_opt(iopt)%mel%gamt,me_opt(iopt)%mel%s2,
     &         me_opt(iopt)%mel%mst,.false.,
     &         -1,1,nvectors,0,0,0,
     &         op_info,orb_info,str_info,strmap_info)
          idxmel = idx_mel_list(fname,op_info)
          me_met(iopt)%mel   => op_info%mel_arr(idxmel)%mel
          ff_met(iopt)%fhand => op_info%mel_arr(idxmel)%mel%fhand
        end if

      end do

c dbg
c      do iopt = 1,nopt
c         write(lulog,*) 'preconditioner: iopt = ',iopt
c         call wrt_mel_file(lulog,5,
c     &        me_dia(iopt)%mel,
c     &        1,me_dia(iopt)%mel%op%n_occ_cls,
c     &        str_info,orb_info)
c      enddo
c
c dbgend

      ! write information to opti_info about signs which occur
      ! in trv*mvp or trv*met  multiplication
      ! relevant when trv is njoined=1 op. but mvp (met) are njoined=2 op's
      call set_opti_info_signs(opti_info,3,nopt,
     &                         me_trv,me_mvp,me_met,me_met,use_s)

      ! read formula
      call read_form_list(form_mvp%fhand,fl_mvp,.true.)

      ! set dependency info for submitted formula list
      call set_formula_dependencies(depend,fl_mvp,op_info)
      ! number of info values returned on xret
      nout = depend%ntargets
      allocate(xret(nout))

      ! records with trial vectors and Mv-products, needed in evp_control:
      ifree = mem_alloc_int(irectrv,nroots,'rectrv')
      ifree = mem_alloc_int(irecmvp,nroots,'recmvp')
      ifree = mem_alloc_int(irecmet,nroots,'recmet')

      use_init_guess = .true.
      home_in = .false.
      do iopt = 1, nopt
        ! open result vector file(s)
        ! if file already open, use as initial guess (if requested)!
        if (ffopt(iopt)%fhand%unit.gt.0.and.opti_info%resume
     &      .and.nroots.eq.1) then ! switched off due to frequent
                                   ! problems for nroots>1
          write(lulog,'(a,i4,a)')
     &          'Using last vector as initial guess (iopt =',iopt,')'
          use_init_guess(iopt) = .false.
        end if
        if (ffopt(iopt)%fhand%unit.gt.0.and.nroots.gt.1) then
          ! copy this root so that we may home in on it later
          if (nopt.ne.1) call quit(1,'solve_evp',
     &         'homing in available only for one opt. vector yet')
          home_in = .true.
          allocate(me_home(1),ffhome(1))
          if (opti_info%typ_prc(iopt).eq.optinf_prc_traf
     &         .and.nspecial.ge.3) then
             me_pnt => me_special(1)%mel
          elseif (opti_info%typ_prc(iopt).eq.optinf_prc_traf_spc)then
             me_pnt => me_special(4)%mel
          else
             me_pnt => me_opt(iopt)%mel
          end if

          call define_me_list('home',me_opt(iopt)%mel%op%name,
     &         me_pnt%absym,me_pnt%casym,
     &         me_pnt%gamt,me_pnt%s2,
     &         me_pnt%mst,.false.,
     &         -1,1,1,0,0,0,
     &         op_info,orb_info,str_info,strmap_info)
          idxmel = idx_mel_list('home',op_info)
          me_home(1)%mel   => op_info%mel_arr(idxmel)%mel
          ffhome(1)%fhand => op_info%mel_arr(idxmel)%mel%fhand
          call assign_me_list(me_trv(iopt)%mel%label,
     &                        me_opt(iopt)%mel%op%name,op_info)
          call file_open(ffhome(1)%fhand)
          call list_copy(me_opt(iopt)%mel,me_home(1)%mel,.false.)
c dbg
c          print *,'preparing for homing in later. Saved vector:'
c          call wrt_mel_file(lulog,5,
c     &         me_home(1)%mel,
c     &         1,me_trv(iopt)%mel%op%n_occ_cls,
c     &         str_info,orb_info)
c dbgend
        else if (ffopt(iopt)%fhand%unit.le.0) then
          call file_open(ffopt(iopt)%fhand)
        end if
        call file_open(ff_scr(iopt)%fhand)
        call file_open(ff_trv(iopt)%fhand)
        ! open corresponding matrix vector products ...
        call file_open(ff_mvp(iopt)%fhand)
        if (use_s(iopt))
     &       call file_open(ff_met(iopt)%fhand)
        ! ... and corresponding preconditioner(s)
        if (ffdia(iopt)%fhand%unit.le.0)
     &       call file_open(ffdia(iopt)%fhand)
      end do

      do idx = 1, nspecial
        if (ffspecial(idx)%fhand%unit.le.0)
     &       call file_open(ffspecial(idx)%fhand)
      end do

      if (init) then
      ! get the initial amplitudes from files
        do iopt = 1,nopt
          if (ffopt(iopt)%fhand%unit.le.0) then
            call file_open(ffopt(iopt)%fhand)
          endif
          inquire(file=trim(ffopt(iopt)%fhand%name),exist=restart)
          if (.not.restart) call warn('solve_evp',
     &         'No amplitude file found for restart! Setting to zero.')
          if (restart) then
            write(lulog,'(x,a,i1,a)')
     &         'Using old amplitude file for vector ',iopt,'!'
!           if(iopt.eq.1) call zeroop(me_opt(iopt)%mel)
            do iroot = 1, nroots
              call switch_mel_record(me_trv(iopt)%mel,iroot)
              call switch_mel_record(me_opt(iopt)%mel,iroot)
              call list_copy(me_opt(iopt)%mel,me_trv(iopt)%mel,.false.)
            enddo
          else
            do iroot = 1, nroots
              call switch_mel_record(me_trv(iopt)%mel,iroot)
              call zeroop(me_trv(iopt)%mel)
            enddo
          endif
        enddo

      else

        ! get initial amplitudes
        if (nopt.eq.1) then
        call init_guess(nopt,use_init_guess,nroots,
     &                  me_opt,me_trv,me_dia,me_special,nspecial,
     &                  fl_mvp,depend,fl_spc,nspcfrm,
     &                  opti_info,orb_info,op_info,str_info,strmap_info)
        else
        call init_guess2(nopt,use_init_guess,nroots,
     &                  me_opt,me_trv,me_dia,me_special,
     &                  nspec_,nextra_,idxspc,
     &                  fl_mvp,depend,fl_spc,nspcfrm,choice_opt,
     &                  opti_info,orb_info,op_info,str_info,strmap_info)
        end if
      endif

      ! Header for molpro output
      if (lmol .and. .not. no_print) then
         write(luout,*)
         write(luout,'(A71)') "ITER.    TOTAL ENERGY    ENERGY"//
     &      " CHANGE     RES         TIME    TIME/IT"
      end if

c dbg
c      do iopt = 1,nopt
c        write(lulog,*) 'starting trial vector (before): iopt = ',iopt
c        call wrt_mel_file(lulog,5,
c     &        me_trv(iopt)%mel,
c     &        1,me_trv(iopt)%mel%op%n_occ_cls,
c     &        str_info,orb_info)
c      enddo
c
c dbgend
      ! start optimization loop
      iter = 0
      task = 0
      old_eig = 0d0
      opt_loop: do while(task.lt.8)
      call atim_csw(cpu0_t,sys0_t,wall0_t)
        call leq_evp_control
     &       ('EVP',iter,
     &       task,conv,xresnrm,xeig,
     &       use_s,
     &       nrequest,irectrv,irecmvp,irecmet,
     &       me_opt,me_scr,me_trv,me_mvp,me_met,me_dia,me_dia,me_ext,
     &       me_special,nspec_,nextra_,idxspc,
c     &       ffopt,ff_trv,ff_mvp,ff_met,ffdia,ffdia,  ! #5 is dummy
     &       fl_mvp,depend,
     &       fl_spc,nspcfrm,
     &       opti_info,opti_stat,
     &       orb_info,op_info,str_info,strmap_info)
        if (iter.gt.1) then
          xresmax = fndmnx(xresnrm,nroots*nopt,2)
          write(lulog,'("E>>",i3,24x,x,g10.4)') iter-1,xresmax

          if (lulog.ne.luout) then
            if (lmol) then
               if (.not. no_print) then
                  time_per_it = cpu0_t / (iter-1)
                  mol_format = '(i4,f18.8,f16.8,d12.2,f10.2,f11.2)'
                  mol_format2 = '(f22.8,f16.8,d12.2)'

                  if (conv) then
                     print_iter = iter
                  else
                     print_iter = iter-1
                  end if

                  do i = 1, nroots
                     if (i==1) then
                        write(luout,mol_format)
     &                  print_iter,xeig(i,1),xeig(i,1)-old_eig(i,1),
     &                  xresnrm(i),cpu0_t,time_per_it
                     else
                        write(luout,mol_format2)
     &                  xeig(i,1),xeig(i,1)-old_eig(i,1),xresnrm(i)
                     end if

                  end do
                  if (nroots>1) write(luout,*)

                  do i = 1, nroots
                     old_eig(i,1) = xeig(i,1)
                  end do
               end if
            else
               write(luout,'("   ",i3,24x,x,g10.4)') iter-1,xresmax
            end if
          end if

          if (iprlvl.gt.0 .and. .not. lmol) then
            do iroot = 1, nroots
              if (xeig(iroot,2).eq.0d0) then
                write(lulog,'(" E>",3x,f24.12,x,3g10.4)')
     &               xeig(iroot,1),(xresnrm(iroot+idx*nroots),
     &                              idx = 0, nopt-1)
                if (lulog.ne.luout.and.iprlvl.ge.5)
     &           write(luout,'("   ",3x,f24.12,x,3g10.4)')
     &               xeig(iroot,1),(xresnrm(iroot+idx*nroots),
     &                              idx = 0, nopt-1)
              else
                write(lulog,
     &               '(" E>",3x,f24.12,x,g10.4," (img=",g24.12,")")')
     &               xeig(iroot,1),xresnrm(iroot),xeig(iroot,2)
                if (lulog.ne.luout.and.iprlvl.ge.5)
     &            write(luout,
     &               '("   ",3x,f24.12,x,g10.4," (img=",g24.12,")")')
     &               xeig(iroot,1),xresnrm(iroot),xeig(iroot,2)
              end if
            end do
          end if
        end if

        ! 4 - get residual
        if (iand(task,4).eq.4) then
          ! preliminary solution:
          !   outside loop over requested Mv-products
          do irequest = 1, nrequest
            do iopt = 1, nopt
              call switch_mel_record(me_trv(iopt)%mel,irectrv(irequest))
              call switch_mel_record(me_mvp(iopt)%mel,irecmvp(irequest))
              if (use_s(iopt))
     &             call switch_mel_record(me_met(iopt)%mel,
     &                                                irecmet(irequest))

              ! enforce MS-combination symmetry of trial vectors
              ! (if requested)
c              if (me_trv(iopt)%mel%absym.ne.0)
c dbg
c        write(lulog,*) 'current trial vector (before): iopt = ',iopt
c        call wrt_mel_file(lulog,5,
c    &       me_trv(iopt)%mel,
c    &       1,me_trv(iopt)%mel%op%n_occ_cls,
c    &       str_info,orb_info)
c dbgend
              if (iter.gt.1.and.me_trv(iopt)%mel%absym.ne.0)
     &             call sym_ab_list(
     &             0.5d0,me_trv(iopt)%mel,me_trv(iopt)%mel,
     &             xdum,.false.,
     &             op_info,str_info,strmap_info,orb_info)

              ! here?
              call touch_file_rec(me_trv(iopt)%mel%fhand)
            end do

c dbg
c            do iopt = 1, nopt
c            write(lulog,*) 'input for request, iopt: ',irequest, iopt
c            call wrt_mel_file(lulog,5,me_trv(iopt)%mel,
c     &           1,me_trv(iopt)%mel%op%n_occ_cls,
c     &           str_info,orb_info)
c            end do
c dbg

            call frm_sched(xret,fl_mvp,depend,0,0,
     &           .true.,.false.,op_info,str_info,strmap_info,orb_info)

            ! apply sign-fix (if needed)
            do iopt = 1, nopt
c             write(lulog,*) 'Fixing signs of residual+metric,iopt=',iopt
              ifree = mem_setmark('solve_evp.fix_sign')
              ifree = mem_alloc_real(xbuf1,opti_info%nwfpar(iopt),
     &                                         'xbuf1')
              call optc_fix_signs2(me_mvp(iopt)%mel%fhand,
     &                            irecmvp(irequest),
     &                            opti_info,iopt,
     &                            opti_info%nwfpar(iopt),xbuf1)
              if (use_s(iopt))
     &           call optc_fix_signs2(me_met(iopt)%mel%fhand,
     &                            irecmet(irequest),
     &                            opti_info,iopt,
     &                            opti_info%nwfpar(iopt),xbuf1)
              ifree = mem_flushmark()
            end do
c dbg
c            write(lulog,*) 'output for request: ',irequest
c            call wrt_mel_file(lulog,5,me_mvp(1)%mel,
c     &           1,me_mvp(1)%mel%op%n_occ_cls,
c     &           str_info,orb_info)
c dbg
              ! enforce MS-combination symmetry of Mv-products:
              ! (if requested)
            do iopt = 1, nopt
              if (me_mvp(iopt)%mel%absym.ne.0)
     &             call sym_ab_list(
     &             0.5d0,me_mvp(iopt)%mel,me_mvp(iopt)%mel,
     &             xdum,.false.,
     &             op_info,str_info,strmap_info,orb_info)

              ! project out spin contaminations?
              if (opti_info%typ_prc(iopt).eq.optinf_prc_spinp.or.
     &            opti_info%typ_prc(iopt).eq.optinf_prc_prj.or.
     &            opti_info%typ_prc(iopt).eq.optinf_prc_spinrefp) then
                ifree = mem_setmark('solve_evp.spin_proj_res')
                ifree = mem_alloc_real(xbuf1,opti_info%nwfpar(iopt),
     &                                 'xbuf1')
                ifree = mem_alloc_real(xbuf2,opti_info%nwfpar(iopt),
     &                                 'xbuf2')
                ! assign op. with list containing the mvp vector
                call assign_me_list(me_mvp(iopt)%mel%label,
     &                              me_opt(iopt)%mel%op%name,op_info)
                if (opti_info%typ_prc(iopt).eq.optinf_prc_spinp) then
                  call spin_project(me_mvp(iopt)%mel,
     &                                        me_special(idxspc)%mel,
     &                             fl_spc(1),opti_info%nwfpar(iopt),
     &                             xbuf1,xbuf2,.false.,xnrm,
     &                             opti_info,orb_info,
     &                             op_info,str_info,strmap_info)
                elseif (opti_info%typ_prc(iopt).eq.
     &                  optinf_prc_spinrefp) then
                  call spin_project(me_mvp(iopt)%mel,
     &                                        me_special(idxspc)%mel,
     &                             fl_spc(2),opti_info%nwfpar(iopt),
     &                             xbuf1,xbuf2,.false.,xnrm,
     &                             opti_info,orb_info,
     &                             op_info,str_info,strmap_info)

                  call evaluate2(fl_spc(1),.false.,.false.,
     &                           op_info,str_info,strmap_info,orb_info,
     &                           xnrm,.false.)

                else
                  call evaluate2(fl_spc(1),.false.,.false.,
     &                           op_info,str_info,strmap_info,orb_info,
     &                           xnrm,.false.)
                end if
                ! reassign lists to correct ops
                call assign_me_list(me_trv(iopt)%mel%label,
     &                              me_opt(iopt)%mel%op%name,op_info)
                call assign_me_list(me_mvp(iopt)%mel%label,
     &                              label_op_mvp(iopt),op_info)
                ifree = mem_flushmark()
              end if
            end do

            ! normalize initial trial vector?
            if (iter.eq.1.and.use_init_guess(1).and.
     &          (opti_info%typ_prc(1).eq.optinf_prc_traf.or.
     &           opti_info%typ_prc(1).eq.optinf_prc_prj.or.
     &           opti_info%typ_prc(1).eq.optinf_prc_spinrefp))
     &          call normalize_guess(ff_trv(1)%fhand,irectrv(irequest),
     &                          ff_mvp,irecmvp(irequest),
     &                          ff_met,irecmet(irequest),
     &                          use_s,1,nopt,opti_info)

          end do
        end if
      call atim_csw(cpu,sys,wall)
         if(iprlvl.ge.5)then
         write (timing_msg,"(x,'time for iteration ')")
         call prtim(lulog,trim(timing_msg),
     &          cpu-cpu0_t,sys-sys0_t,wall-wall0_t)
         end if

      end do opt_loop

      if (lmol .and. nroots<2 .and. .not. no_print)
     &    write(luout,*)

      ! Set ci_iter from molpro_out.h for use in molpro output
      ci_iter = iter

      do iopt = 1, nopt

        ! remove the temporary lists
        call del_me_list(me_scr(iopt)%mel%label,op_info)
        call del_me_list(me_ext(iopt)%mel%label,op_info)
        call del_me_list(me_trv(iopt)%mel%label,op_info)
        call del_me_list(me_mvp(iopt)%mel%label,op_info)
        if (use_s(iopt))
     &       call del_me_list(me_met(iopt)%mel%label,op_info)

        ! make sure that the operator is now associated with
        ! the list containing the solution vector
        call assign_me_list(label_opt(iopt),
     &                      me_opt(iopt)%mel%op%name,op_info)

c        ! solution vector has been updated (if we had some iteration)
c        if (iter.gt.1) call touch_file_rec(me_opt(iopt)%mel%fhand)
        ! solution vector has been updated
        call touch_file_rec(me_opt(iopt)%mel%fhand)

        if (home_in) then
          ! home in on root with largest overlap with prior solution
          ifree = mem_setmark('solve_evp.home_in')
          ifree = mem_alloc_real(xoverlap,nroots,'xoverlap')
          ifree = mem_alloc_real(xbuf1,opti_info%nwfpar(iopt),'xbuf1')
          ifree = mem_alloc_real(xbuf2,opti_info%nwfpar(iopt),'xbuf2')
          xresmax = 0d0
          do iroot = 1, nroots
            xoverlap(iroot) = da_ddot(ffhome(1)%fhand,1,
     &                                ffopt(iopt)%fhand,iroot,
     &                                opti_info%nwfpar(iopt),
     &                                xbuf1,xbuf2,
     &                                opti_info%nwfpar(iopt))
            xoverlap(iroot) = abs(xoverlap(iroot))
            if (xoverlap(iroot).gt.xresmax) then
              idx = iroot
              xresmax = xoverlap(iroot)
            end if
c dbg
c            print *,'root / overlap: ',iroot,xoverlap(iroot)
c dbgend
          end do
          ifree = mem_flushmark()
          if (idx.ne.targ_root) then
            write(lulog,'(a,i4,a,f8.4)')
     &            'Homing in on root ',idx,' with overlap ',xresmax
            ! Interchange this record and the current record
            ! and leave everything else unchanged (a bit dirty)
            call switch_mel_record(me_opt(iopt)%mel,targ_root)
            call list_copy(me_opt(iopt)%mel,me_home(1)%mel,.false.)
            call switch_mel_record(me_opt(iopt)%mel,idx)
            call list_copy(me_home(1)%mel,me_opt(iopt)%mel,.true.)
            call switch_mel_record(me_opt(iopt)%mel,targ_root)
            call list_copy(me_home(1)%mel,me_opt(iopt)%mel,.false.)
          end if
          call del_me_list(me_home(1)%mel%label,op_info)
          deallocate(me_home,ffhome)
        end if

      end do

      do idx = 1, nspecial
        if (ffspecial(idx)%fhand%unit.gt.0)
     &       call file_close_keep(ffspecial(idx)%fhand)
      end do

      ! print results
      call print_roots(lulog)
      if (lulog.ne.luout.and.iprlvl.ge.10) call print_roots(luout)

      ! switch to target root if possible
!      ! (we assume that nroots has been chosen for this reason,
!      !  otherwise a new keyword must be set up for this purpose)
!      if (nroots.ge.me_opt(1)%mel%fhand%active_records(1).and.
!     &    nroots.le.me_opt(1)%mel%fhand%active_records(2))
!     &           call switch_mel_record(me_opt(1)%mel,nroots)
!
      if (targ_root.ge.me_opt(1)%mel%fhand%active_records(1).and.
     &    targ_root.le.me_opt(1)%mel%fhand%active_records(2))
     &           call switch_mel_record(me_opt(1)%mel,targ_root)

      call clean_formula_dependencies(depend)

      ! note that only the pointer array ffopt (but not the entries)
      ! is deallocated:
      deallocate(me_opt,me_dia,me_trv,me_mvp,me_met,me_special,me_scr,
     &           me_ext)
      deallocate(ff_trv,ff_mvp,ffdia,ffopt,ff_met,xret,ffspecial,
     &           ff_scr,ff_ext)
      call dealloc_formula_list(fl_mvp)
      do jdx = 1, nspcfrm
        call dealloc_formula_list(fl_spc(jdx))
      end do

      ifree = mem_flushmark()

      return

      contains

      subroutine print_roots(lu)

      integer, intent(in) :: lu

      call write_title(lu,wst_title,
     &     'Results for '//trim(label_opt(1)))
      write(lu,'("E>>",66("="))')
      write(lu,'("E>>",2x,'//
     &     '"root     eigenvalue (real)       eigenvalue (img.)'//
     &     '  |residual|")')
      write(lu,'("E>>",66("-"))')
      do iroot = 1, nroots
        if (xeig(iroot,2).eq.0d0) then
          write(lu,'("E>>",2x,i3,x,f22.12,20x,"---",2x,x,g10.4)')
     &         iroot,xeig(iroot,1),xresnrm(iroot)
        else
          write(lu,
     &         '("E>>",3x,i2,x,f22.12,x,g24.12,x,g10.4)')
     &         iroot,xeig(iroot,1:2),xresnrm(iroot)
        end if
c dbg
c        if (xresnrm(iroot).lt.opti_info%thrgrd(iopt)
c    &                  .and.abs(xeig(iroot,2)).lt.1d-12) then
c         do iopt=1,nopt
c           call switch_mel_record(me_opt(iopt)%mel,iroot)
c           call wrt_mel_file(lulog,5,me_opt(iopt)%mel,
c    &             1,me_opt(iopt)%mel%op%n_occ_cls,
c    &             str_info,orb_info)
c         enddo
c        end if
c dbg
      end do
      write(lu,'("E>>",66("="))')

      end subroutine

      end


!***********************************************************************
!  Integrated Water Flow Model (IWFM)
!  Copyright (C) 2005-2021
!  State of California, Department of Water Resources
!
!  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.
!  (http://www.gnu.org/copyleft/gpl.html)
!
!  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.
!
!  For tecnical support, e-mail: IWFMtechsupport@water.ca.gov
!***********************************************************************
MODULE Class_AppLake_v50
  USE Class_Version                , ONLY: ReadVersion
  USE MessageLogger                , ONLY: SetLastMessage                , &
                                           EchoProgress                  , &
                                           MessageArray                  , &
                                           iFatal
  USE GeneralUtilities             , ONLY: StripTextUntilCharacter       , &
                                           IntToText                     , &
                                           FirstLocation                 , &
                                           ShellSort                     , &
                                           LocateInList                  , &
                                           EstablishAbsolutePathFilename , &
                                           CleanSpecialCharacters        , &
                                           ConvertID_To_Index
  USE TimeSeriesUtilities          , ONLY: TimeStepType                  , &
                                           IsTimeIntervalValid           , &
                                           TimeIntervalConversion
  USE IOInterface                  , ONLY: GenericFileType
  USE Package_Misc                 , ONLY: PairedDataType                , &
                                           f_iFlowDest_Outside           , &
                                           f_iFlowDest_StrmNode          , &
                                           f_iFlowDest_Lake              , &
                                           f_iLakeComp
  USE Package_Discretization       , ONLY: AppGridType                   , &
                                           StratigraphyType
  USE Package_Budget               , ONLY: BudgetHeaderType
  USE Package_ComponentConnectors  , ONLY: LakeGWConnectorType           , &
                                           StrmLakeConnectorType         , &
                                           f_iStrmToLakeFlow             , &
                                           f_iBypassToLakeFlow           , &
                                           f_iLakeToStrmFlow
  USE Class_Lake                   , ONLY: LakeType                      , &
                                           ReadInitialLakeElevs
  USE Class_MaxLakeElevFile        , ONLY: MaxLakeElevFileType
  USE Package_PrecipitationET      , ONLY: ETType                        , &
                                           PrecipitationType
  USE Package_Matrix               , ONLY: MatrixType
  USE Class_BaseAppLake            , ONLY: BaseAppLakeType               , &
                                           PrepareLakeBudgetHeader       , &
                                           GenerateRatingTable
  IMPLICIT NONE

! ******************************************************************
! ******************************************************************
! ******************************************************************
! ***
! *** VARIABLE DEFINITIONS
! ***
! ******************************************************************
! ******************************************************************
! ******************************************************************

  ! -------------------------------------------------------------
  ! --- PUBLIC ENTITIES
  ! -------------------------------------------------------------
  PRIVATE
  PUBLIC :: AppLake_v50_Type

  ! -------------------------------------------------------------
  ! --- APPLICATION LAKES DATA TYPE
  ! -------------------------------------------------------------
  TYPE,EXTENDS(BaseAppLakeType) :: AppLake_v50_Type
      PRIVATE
      CHARACTER(LEN=6)                 :: cTimeUnitOutflow       = ''  !Time unit of lake outflow
      TYPE(PairedDataType),ALLOCATABLE :: OutflowRatingTables(:)       !Rating tables for lake elevation vs. outflow
  CONTAINS
      PROCEDURE,PASS :: SetStaticComponent              => AppLake_v50_SetStaticComponent
      PROCEDURE,PASS :: SetStaticComponentFromBinFile   => AppLake_v50_SetStaticComponentFromBinFile
      PROCEDURE,PASS :: SetDynamicComponent             => AppLake_v50_SetDynamicComponent
      PROCEDURE,PASS :: SetAllComponents                => AppLake_v50_SetAllComponents
      PROCEDURE,PASS :: SetAllComponentsWithoutBinFile  => AppLake_v50_SetAllComponentsWithoutBinFile
      PROCEDURE,PASS :: KillImplementation              => AppLake_v50_Kill
      PROCEDURE,PASS :: GetVersion                      => AppLake_v50_GetVersion
      PROCEDURE,PASS :: Simulate                        => AppLake_v50_Simulate
      PROCEDURE,PASS :: ReadTSData                      => AppLake_v50_ReadTSData
      PROCEDURE,PASS :: CheckExternalTSDataPointers     => AppLake_v50_CheckExternalTSDataPointers
      PROCEDURE,PASS :: ConvertTimeUnit                 => AppLake_v50_ConvertTimeUnit
      PROCEDURE,PASS :: ComputeLakeETa                  => AppLake_v50_ComputeLakeETa
  END TYPE AppLake_v50_Type

  ! -------------------------------------------------------------
  ! --- LAKE PACKAGE VERSION RELATED DATA
  ! -------------------------------------------------------------
  INTEGER,PARAMETER                    :: iVersion    = 50
  INTEGER,PARAMETER                    :: iLenVersion = 8
  CHARACTER(LEN=iLenVersion),PARAMETER :: cVersion    ='5.0.0000'
  INCLUDE 'AppLake_v50_Revision.fi'

  ! -------------------------------------------------------------
  ! --- MISC. DATA
  ! -------------------------------------------------------------
  INTEGER,PARAMETER                   :: ModNameLen = 19
  CHARACTER(LEN=ModNameLen),PARAMETER :: ModName    = 'Class_AppLake_v50::'

CONTAINS

! ******************************************************************
! ******************************************************************
! ******************************************************************
! ***
! *** CONSTRUCTORS
! ***
! ******************************************************************
! ******************************************************************
! ******************************************************************

  ! -------------------------------------------------------------
  ! --- NEW LAKE FROM RAW DATA (GENERALLY CALLED IN PRE-PROCESSOR)
  ! -------------------------------------------------------------
  SUBROUTINE AppLake_v50_SetStaticComponent(AppLake,cFileName,Stratigraphy,AppGrid,StrmLakeConnector,LakeGWConnector,iStat)
    CLASS(AppLake_v50_Type),INTENT(OUT)   :: AppLake
    CHARACTER(LEN=*),INTENT(IN)           :: cFileName
    TYPE(StratigraphyType),INTENT(IN)     :: Stratigraphy
    TYPE(AppGridType),INTENT(IN)          :: AppGrid
    TYPE(StrmLakeConnectorType)           :: StrmLakeConnector
    TYPE(LakeGWConnectorType),INTENT(OUT) :: LakeGWConnector
    INTEGER,INTENT(OUT)                   :: iStat

    !Local variables
    CHARACTER(LEN=ModNameLen+30) :: ThisProcedure = ModName // 'AppLake_v50_SetStaticComponent'
    INTEGER                      :: NLakes,ErrorCode,indxLake,DummyArray(5),ID,iDestType,NElements, &
                                    indxElem,iDestID,iElem,indxLake1,iElemIDs(AppGrid%NElements),   &
                                    iDest
    INTEGER,ALLOCATABLE          :: iElems_Work(:),iLakeIDs(:)
    INTEGER,PARAMETER            :: f_iDestTypes(3) = [f_iFlowDest_Outside , f_iFlowDest_StrmNode , f_iFlowDest_Lake]
    CHARACTER(:),ALLOCATABLE     :: cVersion
    TYPE(GenericFileType)        :: InFile

    !Initialize
    iStat    = 0
    iElemIDs = AppGrid%AppElement%ID

    !Return if filename is empty
    IF (cFileName .EQ. '') RETURN

    !Echo progress
    CALL EchoProgress('Instantiating static component of application lakes')

    !Open file
    CALL InFile%New(FileName=cFileName,InputFile=.TRUE.,IsTSFile=.FALSE.,Descriptor='pre-processor lake data file',iStat=iStat)
    IF (iStat .EQ. -1) RETURN

    !Read the first line that holds version number
    CALL ReadVersion(InFile,'LAKE',cVersion,iStat)
    IF (iStat .EQ. -1) RETURN

    !Number of lakes
    CALL InFile%ReadData(NLakes,iStat)  ;  IF (iStat .EQ. -1) RETURN
    AppLake%NLakes = NLakes

    !Allocate memory
    ALLOCATE (AppLake%Lakes(NLakes) , STAT=ErrorCode)
    IF (ErrorCode .NE. 0) THEN
        CALL SetLastMessage('Error in allocating memory for lakes!',iFatal,ThisProcedure)
        iStat = -1
        RETURN
    END IF
    IF (NLakes .EQ. 0) RETURN

    !Read lake elements and outflow destination
    DO indxLake=1,NLakes
        CALL InFile%ReadData(DummyArray,iStat)  ;  IF(iStat .EQ. -1) RETURN

        !Lake ID
        ID                         = DummyArray(1)
        AppLake%Lakes(indxLake)%ID = ID

        !Make sure lake ID is not used more than once
        DO indxLake1=1,indxLake-1
            IF (ID .EQ. AppLake%Lakes(indxLake1)%ID) THEN
                CALL SetLastMessage('Lake ID '//TRIM(IntToText(ID))//' is used more than once!',iFatal,ThisProcedure)
                iStat = -1
                RETURN
            END IF
        END DO

        !Outflow destination type
        iDestType = DummyArray(2)
        IF (.NOT. ANY(iDestType.EQ.f_iDestTypes)) THEN
            CALL SetLastMessage('Outflow destination type for lake '//TRIM(IntToText(ID))//' is not recognized!',iFatal,ThisProcedure)
            iStat = -1
            RETURN
        END IF
        AppLake%Lakes(indxLake)%OutflowDestType = iDestType

        !Outflow destination
        AppLake%Lakes(indxLake)%OutflowDest = DummyArray(3)

        !Lake elements
        NElements                         = DummyArray(4)
        AppLake%Lakes(indxLake)%NElements = NElements
        DEALLOCATE (iElems_Work , STAT=ErrorCode)
        ALLOCATE (AppLake%Lakes(indxLake)%Elements(NElements) , iElems_Work(NElements))
        iElems_Work(1) = DummyArray(5)
        DO indxElem=2,NElements
            CALL InFile%ReadData(iElems_Work(indxElem),iStat)
            IF(iStat .EQ. -1) RETURN
        END DO
        CALL ConvertID_To_Index(iElems_Work,iElemIDs,AppLake%Lakes(indxLake)%Elements)
        IF (ANY(AppLake%Lakes(indxLake)%Elements.EQ.0)) THEN
            CALL SetLastMessage('One or more elements listed for lake '//TRIM(IntToText(ID))//' are not in the model!',iFatal,ThisProcedure)
            iStat = -1
            RETURN
        END IF
        CALL ShellSort(AppLake%Lakes(indxLake)%Elements)

        !Make sure lake elements are not listed for more than one lake
        DO indxElem=1,NElements
            iElem = AppLake%Lakes(indxLake)%Elements(indxElem)
            DO indxLake1=1,indxLake-1
                IF (ANY(iElem .EQ. AppLake%Lakes(indxLake1)%Elements)) THEN
                    CALL SetLastMessage('Element '//TRIM(IntToText(iElemIDs(iElem)))//' listed for lake '//TRIM(IntToText(ID))//' is also listed for lake '//TRIM(IntToText(AppLake%Lakes(indxLake1)%ID))//'!',iFatal,ThisProcedure)
                    iStat = -1
                    RETURN
                END IF
            END DO
        END DO

        !Lake nodes
        CALL AppLake%Lakes(indxLake)%CompileLakeNodes(AppGrid,iStat)
        IF (iStat .EQ. -1) RETURN

        !Rating table
        CALL GenerateRatingTable(AppGrid,AppLake%Lakes(indxLake)%Elements,AppLake%Lakes(indxLake)%Nodes,Stratigraphy%GSElev,AppLake%Lakes(indxLake)%RatingTable,iStat)
        IF (iStat .EQ. -1) RETURN

        !Lake node areas
        CALL AppLake%Lakes(indxLake)%ComputeLakeNodeAreas(AppGrid)

        !Add GW nodes to LakeGWConnector
        CALL LakeGWConnector%AddGWNodes(indxLake,AppLake%Lakes(indxLake)%Elements,AppGrid,Stratigraphy)

    END DO

    !Process outflow destinations
    ALLOCATE (iLakeIDs(NLakes))
    iLakeIDs = AppLake%Lakes%ID
    DO indxLake=1,NLakes
        ID      = iLakeIDs(indxLake)
        iDestID = AppLake%Lakes(indxLake)%OutflowDest
        SELECT CASE (AppLake%Lakes(indxLake)%OutflowDestType)
            !If flow to stream, make sure that stream node is modeled
            CASE (f_iFlowDest_StrmNode)
                AppLake%Lakes(indxLake)%OutflowDest = iDestID
                CALL StrmLakeConnector%AddData(f_iLakeToStrmFlow,indxLake,iDestID)

            !If flow to lake, make sure downstream lake is modeled
            CASE (f_iFlowDest_Lake)
                IF (iDestID .EQ. ID) THEN
                    CALL SetLastMessage('Outflow from lake '//TRIM(IntToText(ID))//' cannot flow into itself!',iFatal,ThisProcedure)
                    iStat = -1
                    RETURN
                END IF
                iDest = LocateInList(iDestID,iLakeIDs)
                IF (iDest .EQ. 0) THEN
                    CALL SetLastMessage('Lake '//TRIM(IntToText(iDestID))//' as outflow destination for lake '//TRIM(IntToText(ID))//' is not in the model!',iFatal,ThisProcedure)
                    iStat = -1
                    RETURN
                END IF
                AppLake%Lakes(indxLake)%OutflowDest = iDest
        END SELECT
    END DO

    !Close lake data file
    CALL InFile%Kill()

  END SUBROUTINE AppLake_v50_SetStaticComponent

  ! -------------------------------------------------------------
  ! --- NEW STATIC LAKE DATA FROM PRE-PROCESSOR BINARY FILE
  ! -------------------------------------------------------------
  SUBROUTINE AppLake_v50_SetStaticComponentFromBinFile(AppLake,BinFile,iStat)
    CLASS(AppLake_v50_Type),INTENT(OUT) :: AppLake
    TYPE(GenericFileType)               :: BinFile
    INTEGER,INTENT(OUT)                 :: iStat

    !Initailize
    iStat = 0

    !Read the preprocessed data for lakes
    CALL AppLake%ReadPreprocessedData(BinFile,iStat)

  END SUBROUTINE AppLake_v50_SetStaticComponentFromBinFile

  ! -------------------------------------------------------------
  ! --- INSTANTIATE THE DYNAMIC COMPONENT OF LAKE DATA (GENERALLY CALLED IN SIMULATION)
  ! -------------------------------------------------------------
  SUBROUTINE AppLake_v50_SetDynamicComponent(AppLake,IsForInquiry,cFileName,cWorkingDirectory,TimeStep,NTIME,AppGrid,LakeGWConnector,iStat)
    CLASS(AppLake_v50_Type)       :: AppLake
    LOGICAL,INTENT(IN)            :: IsForInquiry
    CHARACTER(LEN=*),INTENT(IN)   :: cFileName,cWorkingDirectory
    TYPE(TimeStepType),INTENT(IN) :: TimeStep
    INTEGER,INTENT(IN)            :: NTIME
    TYPE(AppGridType),INTENT(IN)  :: AppGrid
    TYPE(LakeGWConnectorType)     :: LakeGWConnector
    INTEGER,INTENT(OUT)           :: iStat

    !Local variables
    CHARACTER(LEN=ModNameLen+31) :: ThisProcedure = ModName // 'AppLake_v50_SetDynamicComponent'
    TYPE(GenericFileType)        :: LakeDataFile
    CHARACTER                    :: ALine*2000,TimeUnitConductance*6,cLakeBudgetFileName*2000
    TYPE(BudgetHeaderType)       :: BudHeader
    REAL(8)                      :: FactK,DummyArray(5),FactL,CLAKE,DLAKE,FactC,FactElev,FactQ,rDummy4(4),rDummy2(2)
    INTEGER                      :: indxLake,ID,indx,iLoc,iNPoints,indxPoint,ErrorCode,iLakeIDs(AppLake%NLakes),iLake
    REAL(8),ALLOCATABLE          :: rLakeElevs(:),rLakeOutflows(:)
    CHARACTER(:),ALLOCATABLE     :: cAbsPathFileName
    LOGICAL                      :: lProcessed(AppLake%NLakes)

    !Initialize
    iStat = 0

    !Return if no file name is specified
    IF (cFileName .EQ. '') RETURN

    !Echo progress
    CALL EchoProgress('Instantiating dynamic component of application lakes')

    !Open lake data file
    CALL LakeDataFile%New(cFileName,InputFile=.TRUE.,iStat=iStat)
    IF (iStat .EQ. -1) RETURN

    !Burn the first line that stores the version number
    CALL LakeDataFile%ReadData(ALine,iStat)
    IF (iStat .EQ. -1) RETURN

    !Allocate rating tables
    ALLOCATE (AppLake%OutflowRatingTables(AppLake%NLakes))

    !Lake budget raw file name
    CALL LakeDataFile%ReadData(cLakeBudgetFileName,iStat)  ;  IF (iStat .EQ. -1) RETURN
    cLakeBudgetFileName = StripTextUntilCharacter(cLakeBudgetFileName,'/')
    CALL CleanSpecialCharacters(cLakeBudgetFileName)
    CALL EstablishAbsolutePathFileName(TRIM(ADJUSTL(cLakeBudgetFileName)),cWorkingDirectory,cAbsPathFileName)
    cLakeBudgetFileName = cAbsPathFileName

    !Final lake elevations output file
    CALL LakeDataFile%ReadData(ALine,iStat)  ;  IF (iStat .EQ. -1) RETURN  ;  ALine = ADJUSTL(StripTextUntilCharacter(ALine,'/'))  ;  CALL CleanSpecialCharacters(ALine)
    IF (ALine .NE. '') THEN
        ALLOCATE (AppLake%FinalElevFile)
        CALL EstablishAbsolutePathFileName(TRIM(ADJUSTL(ALine)),cWorkingDirectory,cAbsPathFileName)
        IF (IsForInquiry) THEN
            CALL AppLake%FinalElevFile%New(FileName=cAbsPathFileName,InputFile=.TRUE.,IsTSFile=.FALSE.,Descriptor='end-of-simulation lake elevations data',iStat=iStat)
        ELSE
            CALL AppLake%FinalElevFile%New(FileName=cAbsPathFileName,InputFile=.FALSE.,IsTSFile=.FALSE.,Descriptor='end-of-simulation lake elevations data',iStat=iStat)
        END IF
    IF (iStat .EQ. -1) RETURN
        AppLake%lFinalElevFile_Defined = .TRUE.
    END IF

    !Read factors
    CALL LakeDataFile%ReadData(FactK,iStat)  ;  IF (iStat .EQ. -1) RETURN
    CALL LakeDataFile%ReadData(ALine,iStat)  ;  IF (iStat .EQ. -1) RETURN
    CALL CleanSpecialCharacters(ALine)
    TimeUnitConductance = ADJUSTL(StripTextUntilCharacter(ALine,'/'))
    CALL LakeDataFile%ReadData(FactL,iStat)  ;  IF (iStat .EQ. -1) RETURN

    !Read lake parameters
    lProcessed = .FALSE.
    iLakeIDs   = AppLake%Lakes%ID
    DO indxLake=1,AppLake%NLakes
        CALL LakeDataFile%ReadData(ALine,iStat)  ;  IF (iStat .EQ. -1) RETURN
        READ (ALine,*) DummyArray

        !Make sure that lake ID number is recognized
        ID = INT(DummyArray(1))
        CALL ConvertID_To_Index(ID,iLakeIDs,iLake)
        IF (iLake .EQ. 0) THEN
            CALL SetLastMessage('Lake ID '//TRIM(IntToText(ID))//' listed for lake parameters is not recognized!',iFatal,ThisProcedure)
            iStat = -1
            RETURN
        END IF

        !Make sure lake data was not entered previously
        IF (lProcessed(iLake)) THEN
            CALL SetLastMessage('Parameters for lake '//TRIM(IntToText(ID))//' are entered more than once!',iFatal,ThisProcedure)
            iStat = -1
            RETURN
        END IF
        lProcessed(iLake) = .TRUE.

        !Process parameters
        CLAKE                            = DummyArray(2)*FactK
        DLAKE                            = DummyArray(3)*FactL
        AppLake%Lakes(iLake)%iColET      = INT(DummyArray(4))
        AppLake%Lakes(iLake)%iColPrecip  = INT(DummyArray(5))
        FactC                            = CLAKE / DLAKE

        !Compile lake-gw connector
        CALL LakeGWConnector%SetConductance(AppGrid,iLake,TimeUnitConductance,FactC,iStat)
        IF (iStat .EQ. -1) RETURN

        !Extract the name of the lake from ALine
        CALL CleanSpecialCharacters(ALine)
        ALine = ADJUSTL(ALine)
        DO indx=1,SIZE(DummyArray)
            iLoc  = FirstLocation(' ',ALine)
            ALine = ADJUSTL(ALine(iLoc+1:))
        END DO
        AppLake%Lakes(iLake)%cName = StripTextUntilCharacter(ADJUSTL(ALine),'/')

    END DO

    !Read lake outflow rating table conversion factors
    CALL LakeDataFile%ReadData(FactElev,iStat)  ;  IF (iStat .EQ. -1) RETURN
    CALL LakeDataFile%ReadData(FactQ,iStat)     ;  IF (iStat .EQ. -1) RETURN
    CALL LakeDataFile%ReadData(ALine,iStat)     ;  IF (iStat .EQ. -1) RETURN
    CALL CleanSpecialCharacters(ALine)
    AppLake%cTimeUnitOutflow = ADJUSTL(StripTextUntilCharacter(ALine,'/'))
    IF (IsTimeIntervalValid(AppLake%cTimeUnitOutflow) .EQ. 0) THEN
        CALL SetLastMessage('Time unit of lake outflow in the rating tables is not recognized!',iFatal,ThisProcedure)
        iStat = -1
        RETURN
    END IF

    !Read rating tables
    lProcessed = .FALSE.
    DO indxLake=1,AppLake%NLakes
        !Read first line
        CALL LakeDataFile%ReadData(rDummy4,iStat)  ;  IF (iStat .EQ. -1) RETURN

        !Make sure lake ID is legit
        ID = INT(rDummy4(1))
        CALL ConvertID_To_Index(ID,iLakeIDs,iLake)
        IF (iLake .EQ. 0) THEN
            CALL SetLastMessage('Lake ID '//TRIM(IntToText(ID))//' listed for rating tables is not recognized!',iFatal,ThisProcedure)
            iStat = -1
            RETURN
        END IF

        !Make sure lake data was not entered previously
        IF (lProcessed(iLake)) THEN
            CALL SetLastMessage('Rating table for lake '//TRIM(IntToText(ID))//' is entered more than once!',iFatal,ThisProcedure)
            iStat = -1
            RETURN
        END IF
        lProcessed(iLake) = .TRUE.

        !Generate rating table
        iNPoints = INT(rDummy4(2))
        DEALLOCATE (rLakeElevs , rLakeOutflows , STAT=ErrorCode)
        ALLOCATE (rLakeElevs(iNPoints) , rLakeOutflows(iNPoints))
        rLakeElevs(1)    = rDummy4(3) * FactElev
        rLakeOutflows(1) = rDummy4(4) * FactQ
        DO indxPoint=2,iNPoints
            CALL LakeDataFile%ReadData(rDummy2,iStat)  ;  IF (iStat .EQ. -1) RETURN
            rLakeElevs(indxPoint)    = rDummy2(1) * FactElev
            rLakeOutflows(indxPoint) = rDummy2(2) * FactQ
        END DO
        CALL AppLake%OutflowRatingTables(iLake)%New(iNPoints,rLakeElevs,rLakeOutflows,iStat)
        IF (iStat .EQ. -1) RETURN

        !Make sure first entry of rating table is not less than the lowest of the lake bottom
        IF (AppLake%OutFlowRatingTables(iLake)%XPoint(1) .LE. AppLake%Lakes(iLake)%RatingTable%XPoint(1)) THEN
            MessageArray(1) = 'The lowest lake elevation that lake outflow starts for lake '//TRIM(IntToText(ID))//' is less than the lowest part of the lake bottom!'
            WRITE (MessageArray(2),'(A,F9.3)')  'Lowest lake bottom elevation  = ',AppLake%Lakes(iLake)%RatingTable%XPoint(1)
            WRITE (MessageArray(3),'(A,F9.3)')  'Elevation when outflow starts = ',AppLake%OutFlowRatingTables(iLake)%XPoint(1)
            CALL SetLastMessage(MessageArray(1:3),iFatal,ThisProcedure)
            iStat = -1
            RETURN
        END IF

        !Make sure maximum lake elevation is not greater than the highest ground surface elevetaion
        IF (AppLake%OutFlowRatingTables(iLake)%XPoint(AppLake%OutFlowRatingTables(iLake)%NPoints) .GT. AppLake%Lakes(iLake)%RatingTable%XPoint(AppLake%Lakes(iLake)%RatingTable%NPoints)) THEN
            MessageArray(1) = 'Maximum lake elevation for lake '//TRIM(IntToText(iLake))//' is greater than the highest ground surface elevation!'
            WRITE (MessageArray(2),'(A,F9.3)')  'Highest ground surface elevation  = ',AppLake%Lakes(iLake)%RatingTable%XPoint(AppLake%Lakes(iLake)%RatingTable%NPoints)
            WRITE (MessageArray(3),'(A,F9.3)')  'Maximum lake elevation            = ',AppLake%OutFlowRatingTables(iLake)%XPoint(AppLake%OutFlowRatingTables(iLake)%NPoints)
            CALL SetLastMessage(MessageArray(1:3),iFatal,ThisProcedure)
            iStat = -1
            RETURN
        END IF

        !Compile maximum lake elevations
        AppLake%Lakes(iLake)%MaxElev = AppLake%OutFlowRatingTables(iLake)%XPoint(AppLake%OutFlowRatingTables(iLake)%NPoints)
    END DO

    !Instantiate the lake budget file
    IF (cLakeBudgetFileName .NE. '') THEN
        ALLOCATE (AppLake%LakeBudRawFile)
        IF (IsForInquiry) THEN
            CALL AppLake%LakeBudRawFile%New(TRIM(cLakeBudgetFileName),iStat)
            IF (iStat .EQ. -1) RETURN
        ELSE
            BudHeader = PrepareLakeBudgetHeader(AppLake%Lakes,NTIME,TimeStep,AppLake%GetVersion())
            CALL AppLake%LakeBudRawFile%New(TRIM(cLakeBudgetFileName),BudHeader,iStat)
            IF (iStat .EQ. -1) RETURN
            CALL BudHeader%Kill()
        END IF
        AppLake%LakeBudRawFile_Defined = .TRUE.
    END IF

    !Initial lake elevations
    CALL ReadInitialLakeElevs(LakeDataFile,AppLake%Lakes,iLakeIDs,iStat)

    !Close file
    CALL LakeDataFile%Kill()

  END SUBROUTINE AppLake_v50_SetDynamicComponent

  ! -------------------------------------------------------------
  ! --- INSTANTIATE COMPLETE LAKE DATA
  ! -------------------------------------------------------------
  SUBROUTINE AppLake_v50_SetAllComponents(AppLake,IsForInquiry,cFileName,cSimWorkingDirectory,TimeStep,NTIME,AppGrid,BinFile,LakeGWConnector,iStat)
    CLASS(AppLake_v50_Type),INTENT(OUT) :: AppLake
    LOGICAL,INTENT(IN)                  :: IsForInquiry
    CHARACTER(LEN=*),INTENT(IN)         :: cFileName,cSimWorkingDirectory
    TYPE(TimeStepType),INTENT(IN)       :: TimeStep
    INTEGER,INTENT(IN)                  :: NTIME
    TYPE(AppGridType),INTENT(IN)        :: AppGrid
    TYPE(GenericFileType)               :: BinFile
    TYPE(LakeGWConnectorType)           :: LakeGWConnector
    INTEGER,INTENT(OUT)                 :: iStat

    !Local variables
    CHARACTER(LEN=ModNameLen+28) :: ThisProcedure = ModName // 'AppLake_v50_SetAllComponents'

    !Initialize
    iStat = 0

    !Read the preprocessed data for lakes
    CALL AppLake%ReadPreprocessedData(BinFile,iStat)
    IF (iStat .EQ. -1) RETURN

    !Return if there are no lakes defined in Pre-Processor
    IF (AppLake%NLakes .EQ. 0) RETURN

    !Set the dynamic part of AppLake
    CALL AppLake%SetDynamicComponent(IsForInquiry,cFileName,cSimWorkingDirectory,TimeStep,NTIME,AppGrid,LakeGWConnector,iStat)
    IF (iStat .EQ. -1) RETURN

    !Make sure that if static part is defined, so is the dynamic part
    IF (AppLake%NLakes .GT. 0) THEN
        IF (cFileName .EQ. '') THEN
            MessageArray(1) = 'For proper simulation of lakes, relevant lake data files must'
            MessageArray(2) = 'be specified when lakes are defined in Pre-Processor.'
            CALL SetLastMessage(MessageArray(1:2),iFatal,ThisProcedure)
            iStat = -1
            RETURN
        END IF
    END IF

  END SUBROUTINE AppLake_v50_SetAllComponents

  ! -------------------------------------------------------------
  ! --- INSTANTIATE COMPLETE LAKE DATA WITHOUT INTERMEDIATE BINARY FILE
  ! -------------------------------------------------------------
  SUBROUTINE AppLake_v50_SetAllComponentsWithoutBinFile(AppLake,IsForInquiry,cPPFileName,cSimFileName,cSimWorkingDirectory,AppGrid,Stratigraphy,TimeStep,NTIME,StrmLakeConnector,LakeGWConnector,iStat)
    CLASS(AppLake_v50_Type),INTENT(OUT)   :: AppLake
    LOGICAL,INTENT(IN)                    :: IsForInquiry
    CHARACTER(LEN=*),INTENT(IN)           :: cPPFileName,cSimFileName,cSimWorkingDirectory
    TYPE(AppGridType),INTENT(IN)          :: AppGrid
    TYPE(StratigraphyType),INTENT(IN)     :: Stratigraphy
    TYPE(TimeStepType),INTENT(IN)         :: TimeStep
    INTEGER,INTENT(IN)                    :: NTIME
    TYPE(StrmLakeConnectorType)           :: StrmLakeConnector
    TYPE(LakeGWConnectorType),INTENT(OUT) :: LakeGWConnector
    INTEGER,INTENT(OUT)                   :: iStat

    !Local variables
    CHARACTER(LEN=ModNameLen+43) :: ThisProcedure = ModName // 'AppLake_v50_SetAllComponentsWithoutBinFile'

    !Initialize
    iStat = 0

    !Instantiate the static components of the AppLake data
    CALL AppLake%SetStaticComponent(cPPFileName,Stratigraphy,AppGrid,StrmLakeConnector,LakeGWConnector,iStat)
    IF (iStat .EQ. -1) RETURN

    !Instantiate the dynamic component of the AppLake data
    CALL AppLake%SetDynamicComponent(IsForInquiry,cSimFileName,cSimWorkingDirectory,TimeStep,NTIME,AppGrid,LakeGWConnector,iStat)
    IF (iStat .EQ. -1) RETURN

    !Make sure that if static part is defined, so is the dynamic part
    IF (AppLake%NLakes .GT. 0) THEN
        IF (.NOT. ALLOCATED(AppLake%OutflowRatingTables)) THEN
            MessageArray(1) = 'For proper simulation of lakes, relevant lake data files must'
            MessageArray(2) = 'be specified when lakes are defined in Pre-Processor.'
            CALL SetLastMessage(MessageArray(1:2),iFatal,ThisProcedure)
            iStat = -1
            RETURN
        END IF
    END IF

  END SUBROUTINE AppLake_v50_SetAllComponentsWithoutBinFile

! ******************************************************************
! ******************************************************************
! ******************************************************************
! ***
! *** DESTRUCTOR
! ***
! ******************************************************************
! ******************************************************************
! ******************************************************************

  ! -------------------------------------------------------------
  ! --- KILL LAKE DATA OBJECT
  ! -------------------------------------------------------------
  SUBROUTINE AppLake_v50_Kill(AppLake)
    CLASS(AppLake_v50_Type) :: AppLake

    !Local variables
    INTEGER                :: ErrorCode,indx
    TYPE(AppLake_v50_Type) :: Dummy

    !Kill rating tables
    IF (ALLOCATED(AppLake%OutflowRatingTables)) THEN
        DO indx=1,AppLake%NLakes
            CALL AppLake%OutflowRatingTables(indx)%Kill()
        END DO
        DEALLOCATE (AppLake%OutflowRatingTables , STAT=ErrorCode)
    END IF

    !Back to defaults
    AppLake%cTimeUnitOutflow = Dummy%cTimeUnitOutflow

  END SUBROUTINE AppLake_v50_Kill

! ******************************************************************
! ******************************************************************
! ******************************************************************
! ***
! *** GETTERS
! ***
! ******************************************************************
! ******************************************************************
! ******************************************************************

  ! -------------------------------------------------------------
  ! --- GET VERSION NUMBER
  ! -------------------------------------------------------------
  FUNCTION AppLake_v50_GetVersion(AppLake) RESULT(cVrs)
    CLASS(AppLake_v50_Type)  :: AppLake
    CHARACTER(:),ALLOCATABLE :: cVrs

    IF (.NOT. AppLake%Version%IsDefined())   &
        AppLake%Version = AppLAke%Version%New(iLenVersion,cVersion,cRevision)

    cVrs = AppLake%Version%GetVersion()

  END FUNCTION AppLake_v50_GetVersion

! ******************************************************************
! ******************************************************************
! ******************************************************************
! ***
! *** DATA READERS
! ***
! ******************************************************************
! ******************************************************************
! ******************************************************************

  ! -------------------------------------------------------------
  ! --- READ TIME SERIES  DATA
  ! -------------------------------------------------------------
  SUBROUTINE AppLake_v50_ReadTSData(AppLake,TimeStep,ET,Precip,iStat)
    CLASS(AppLake_v50_Type)            :: AppLake
    TYPE(TimeStepType),INTENT(IN)      :: TimeStep
    TYPE(ETType),INTENT(IN)            :: ET
    TYPE(PrecipitationType),INTENT(IN) :: Precip
    INTEGER,INTENT(OUT)                :: iStat

    !Initailize
    iStat = 0

    !Lake precipitation
    IF (Precip%IsUpdated()) AppLake%Lakes%PrecipRate = Precip%GetValues(AppLake%Lakes%iColPrecip)

    !Lake potential evapotranspiration
    IF (ET%IsUpdated()) AppLake%Lakes%ETp_Rate = ET%GetValues(AppLake%Lakes%iColET)

  END SUBROUTINE AppLake_v50_ReadTSData

! ******************************************************************
! ******************************************************************
! ******************************************************************
! ***
! *** MISC. METHODS
! ***
! ******************************************************************
! ******************************************************************
! ******************************************************************

  ! -------------------------------------------------------------
  ! --- SIMULATE LAKES
  ! -------------------------------------------------------------
  SUBROUTINE AppLake_v50_Simulate(AppLake,GSElevs,GWHeads,Runoff,ReturnFlow,LakeGWConnector,StrmLakeConnector,Matrix)
    CLASS(AppLake_v50_Type)              :: AppLake
    REAL(8),INTENT(IN)                   :: GSElevs(:),GWHeads(:,:),Runoff(:),ReturnFlow(:)
    TYPE(LakeGWConnectorType),INTENT(IN) :: LakeGWConnector
    TYPE(StrmLakeConnectorType)          :: StrmLakeConnector
    TYPE(MatrixType)                     :: Matrix

    !Local variables
    INTEGER                           :: indxLake,NLakes,iDest,iNodeIDs(1)
    REAL(8),DIMENSION(AppLake%NLakes) :: StrmInflows,LakeGWFlow_AtMaxLakeElev
    REAL(8)                           :: Elev,rOutflow_AtMaxLakeElev,rOutFlow,rUpdateValues(1),rUpdateRHS(AppLake%NLakes),OtherInflow,rOutFlowDeriv
    INTEGER,PARAMETER                 :: iCompIDs(1) = [f_iLakeComp]

    !Initialize
    NLakes                     =  AppLake%NLakes
    AppLake%Lakes%InflowUplake =  0.0
    AppLake%Lakes%Outflow      =  0.0
    CALL StrmLakeConnector%ResetLakeToStrmFlows()

    !Compute inflows from streams
    DO indxLake=1,NLakes
      StrmInflows(indxLake) = StrmLakeConnector%GetFlow(f_iStrmToLakeFlow,indxLake)  &
                            + StrmLakeConnector%GetFlow(f_iBypassToLakeFlow,indxLake)
    END DO

    !Lake-gw interaction at maximum lake elevations
    LakeGWFlow_AtMaxLakeElev= LakeGWConnector%ComputeLakeGWFlow(NLakes,AppLake%Lakes%MaxElev,GWHeads,GSElevs)

    !Actual ET
    CALL AppLake%ComputeLakeETa(GSElevs,StrmInflows)

    !Compile lake equations
    DO indxLake=1,NLakes
        !Initialize
        Elev        = AppLake%Lakes(indxLake)%Elev                                    !Lake elevation
        iNodeIDs(1) = indxLake                                                        !Lake to lake connectivity node
        OtherInflow = StrmInflows(indxLake) + Runoff(indxLake) + ReturnFlow(indxLake) !Inflows into lake

        !Lake storage
        AppLake%Lakes(indxLake)%Storage = MAX(AppLake%Lakes(indxLake)%RatingTable%Evaluate(Elev) , 0.0)

        !Lake outflow and its derivative
        rOutFlow      = 0.0
        rOutflowDeriv = 0.0
        IF (Elev .GE. AppLake%OutflowRatingTables(indxLake)%XPoint(1)) THEN
            IF (Elev .LT. AppLake%Lakes(indxLake)%MaxElev) THEN
                CALL AppLake%OutflowRatingTables(indxLake)%EvaluateAndDerivative(Elev,rOutflow,rOutflowDeriv)
            END IF
        END IF
        rOutflow_AtMaxLakeElev          = RHSLake(AppLake%Lakes(indxLake),AppLake%Lakes(indxLake)%MaxElev,OtherInflow) + LakeGWFlow_AtMaxLakeElev(indxLake) + rOutflow
        rOutflow_AtMaxLakeElev          = -MIN(rOutflow_AtMaxLakeElev , 0.0)
        rOutflow                        = rOutflow + rOutflow_AtMaxLakeElev
        AppLake%Lakes(indxLake)%Outflow = rOutflow

        !RHS vector
        rUpdateRHS(indxLake) = RHSLake(AppLake%Lakes(indxLake),Elev,OtherInflow) + rOutflow

        !Send outflow to destination
        IF (rOutflow .GT. 0.0) THEN
            iDest = AppLake%Lakes(indxLake)%OutflowDest
            SELECT CASE (AppLake%Lakes(indxLake)%OutflowDestType)
                CASE (f_iFlowDest_Lake)
                    AppLake%Lakes(iDest)%InflowUpLake = AppLake%Lakes(iDest)%InflowUpLake + rOutflow
                CASE (f_iFlowDest_StrmNode)
                    CALL StrmLakeConnector%SetFlow(f_iLakeToStrmFlow,indxLake,iDest,rOutflow)
            END SELECT
        END IF

        !Update COEFF matrix
        rUpdateValues(1) = AppLake%Lakes(indxLake)%RatingTable%Derivative(Elev)
        IF (rOutflow .GT. 0.0) THEN
            rUpdateValues(1) = rUpdateValues(1) + rOutflowDeriv
        END IF
        CALL Matrix%UpdateCOEFF(f_iLakeComp,indxLake,1,iCompIDs,iNodeIDs,rUpdateValues)

    END DO

    !Update RHS vector
    CALL Matrix%UpdateRHS(f_iLakeComp,1,rUpdateRHS)

  END SUBROUTINE AppLake_v50_Simulate

  ! -------------------------------------------------------------
  ! --- COMPUTE RIGHT-HAND-SIDE OF A LAKE EQUATION
  ! -------------------------------------------------------------
  FUNCTION RHSLake(Lake,HLake,OtherInflow) RESULT(RHS)
    TYPE(LakeType),INTENT(IN) :: Lake
    REAL(8),INTENT(IN)        :: HLake,OtherInflow
    REAL(8)                   :: RHS

    !Local variables
    REAL(8) :: Storage

    !Compute storage at HLake
    Storage = MAX(Lake%RatingTable%Evaluate(HLake) , 0.0)

    RHS =  Storage                      & !Storage
         - Lake%Storage_P               & !Storage at the previous time step
         - Lake%PrecipRate * Lake%Area  & !Precipitation
         + Lake%ETa                     & !Evaporation
         - OtherInflow                  & !All other inflows to lake
         - Lake%InflowUpLake              !Inflow from upstream lake

  END FUNCTION RHSLake

  ! -------------------------------------------------------------
  ! --- MAKE SURE THAT POINTED TIME-SERIES DATA HAVE ENOUGH COLUMNS
  ! -------------------------------------------------------------
  SUBROUTINE AppLake_v50_CheckExternalTSDataPointers(AppLake,Precip,ET,iStat)
    CLASS(AppLake_v50_Type),INTENT(IN) :: AppLake
    TYPE(PrecipitationType),INTENT(IN) :: Precip
    TYPE(ETType),INTENT(IN)            :: ET
    INTEGER,INTENT(OUT)                :: iStat

    !Local variables
    CHARACTER(Len=ModNameLen+39) :: ThisProcedure = ModName // 'AppLake_v50_CheckExternalTSDataPointers'
    INTEGER                      :: iLake(1),ID

    !Initialize
    iStat = 0

    !Check precip columns
    IF (Precip%GetNDataColumns() .LT. MAXVAL(AppLake%Lakes%iColPrecip)) THEN
        iLake = MAXLOC(AppLake%Lakes%iColPrecip)
        ID    = AppLake%Lakes(iLake(1))%ID
        MessageArray(1) = 'Precipitation data column for lake '//TRIM(IntToText(ID))//' is greater than the'
        MessageArray(2) = 'available data columns in the Precipitation Data file!'
        CALL SetLastMessage(MessageArray(1:2),iFatal,ThisProcedure)
        iStat = -1
        RETURN
    END IF

    !Check ET columns
    IF (ET%GetNDataColumns() .LT. MAXVAL(AppLake%Lakes%iColET)) THEN
        iLake = MAXLOC(AppLake%Lakes%iColET)
        ID    = AppLake%Lakes(iLake(1))%ID
        MessageArray(1) = 'Evapotranspiration data column for lake '//TRIM(IntToText(ID))//' is greater than the'
        MessageArray(2) = 'available data columns in the Evapotranspiration Data file!'
        CALL SetLastMessage(MessageArray(1:2),iFatal,ThisProcedure)
        iStat = -1
        RETURN
    END IF

  END SUBROUTINE AppLake_v50_CheckExternalTSDataPointers

  ! -------------------------------------------------------------
  ! --- CONVERT TIME UNIT OF LAKE RELATED ENTITIES
  ! -------------------------------------------------------------
  SUBROUTINE AppLake_v50_ConvertTimeUnit(AppLake,NewUnit)
    CLASS(AppLake_v50_Type)     :: AppLake
    CHARACTER(LEN=*),INTENT(IN) :: NewUnit

    !Local variables
    INTEGER :: indxLake
    REAL(8) :: Factor

    !Convert rating table flow time unit
    Factor                   = TimeIntervalConversion(NewUnit,AppLake%cTimeUnitOutflow)
    AppLake%cTimeUnitOutflow = NewUnit
    DO indxLake=1,AppLake%NLakes
      AppLake%OutflowRatingTables(indxLake)%YPoint = AppLake%OutflowRatingTables(indxLake)%YPoint * Factor
    END DO

  END SUBROUTINE AppLake_v50_ConvertTimeUnit

  ! -------------------------------------------------------------
  ! --- COMPUTE LAKE EVAPORATION
  ! -------------------------------------------------------------
  SUBROUTINE AppLake_v50_ComputeLakeETa(AppLake,GSElev,StrmInflows)
    CLASS(AppLake_v50_Type) :: AppLake
    REAL(8),INTENT(IN)      :: GSElev(:),StrmInflows(AppLake%NLakes)

    !Local variables
    INTEGER :: indxLake
    REAL(8) :: Area,rInflow,Precip,ETp

    !Iterate over lakes
    DO indxLake=1,AppLake%NLakes
      !Initialize
      Area    = AppLake%Lakes(indxLake)%Area
      rInflow = AppLake%Lakes(indxLake)%InflowUpLake + StrmInflows(indxLake)
      Precip  = AppLake%Lakes(indxLake)%PrecipRate * Area
      ETp     = AppLake%Lakes(indxLake)%ETp_Rate * Area

      !Store ETa in permanent arrays
      AppLake%Lakes(indxLake)%ETa = MIN(AppLake%Lakes(indxLake)%Storage_P + rInflow + Precip , ETp)

    END DO

  END SUBROUTINE AppLake_v50_ComputeLakeETa

END MODULE