module statevec
!$$$  module documentation block
!
! module: statevec            read ensemble members, distribute each
!                             to each task.  Collect updated ensemble
!                             members on root task, write out.
!
! prgmmr: whitaker         org: esrl/psd               date: 2009-02-23
!
! abstract: ensemble IO.
!
! Public Subroutines:
!  read_ensemble: read ensemble members on root, distribute pieces (defined by module loadbal)
!    to each task.
!  write_ensemble: retrieve pieces of updated ensemble from each task on root,
!    write out. Optionally save ensemble mean analysis increment.
!  statevec_cleanup: deallocate allocatable arrays.
!
! Public Variables:
!  nanals: (integer scalar) number of ensemble members (from module params)
!  npts_max: (integer scalar) maximum number of grid points assigned to a task.
!  nlevs: number of analysis vertical levels (from module params).
!  nvars: number of 3d 'non-tracer' variables updated by analysis (from module params).
!  ndim: (nvars + ntrac_update) * nlevs (from module params).
!  nbackgrounds:  number of time levels in background
!  anal_chunk(nanals,npts_max,ndim,nbackgrounds): real array of ensemble perturbations
!   updated on each task.
!  anal_chunk_prior(nanals,npts_max,ndim,nbackgrounds): real array of prior ensemble
!   perturbations.  Before analysis anal_chunk=anal_chunk_prior, after
!   analysis anal_chunk contains posterior perturbations.
!  ensmean_chunk(npts_max,ndim,nbackgrounds): real array containing pieces of ensemble
!   mean to be updated on each task.
!  ensmean_chunk_prior(npts_max,ndim,nbackgrounds): as above, for ensemble mean prior.
!   Before analysis ensmean_chunk=ensmean_chunk_prior, after analysis
!   ensmean_chunk contains posterior ensemble mean.
!
! Modules Used: mpisetup, params, kinds, loadbal, gridio, gridinfo
!
! program history log:
!   2009-02-23  Initial version.
!   2009-11-28  revamped to improve IO speed
!   2015-06-29  add multiple time levels to background
!   2015-01-05  Enabling observation sensitivity computations
!   2015-07-01  todling - add number of surface variables
!
! attributes:
!   language: f95
!
!$$$

use gridio, only: readgriddata, writegriddata, get_weight, &
                  destroy_weight, divide_weight
use mpisetup
use gridinfo, only: lonsgrd, latsgrd, ptop, npts, nvarhumid
use params, only: nlevs,nvars,ndim,nbackgrounds,&
                  nanals,pseudo_rh,massbal_adjust,use_qsatensmean,nsfcvars,do_avk,&
                  fso_flag,evalft,andataname,ft,fso_have_ferr,fso_have_fsen
use kinds, only: r_kind, i_kind, r_double, r_single
use loadbal, only: npts_max,indxproc,numptsperproc
use enkf_obsmod, only: nobstot
implicit none
private
public :: read_ensemble, write_ensemble, statevec_cleanup
real(r_single),public, allocatable, dimension(:,:,:,:) :: anal_chunk, anal_chunk_prior
real(r_single),public, allocatable, dimension(:,:,:) :: ensmean_chunk, ensmean_chunk_prior
real(r_single),public, allocatable, dimension(:,:) :: analmean_chunk, fcerror_chunk
real(r_single),public, allocatable, dimension(:,:,:) :: avkmean_chunk
real(r_single),public, allocatable, dimension(:,:,:) :: grdin
real(r_double),public, allocatable, dimension(:,:,:) :: qsat
integer(i_kind), allocatable, dimension(:) :: scounts, displs, rcounts

contains

subroutine read_ensemble()
! read ensemble members on IO tasks,
! distribute pieces (defined by module loadbal) to each task.
! for now, first nanals tasks are IO tasks.
implicit none
real(r_single), allocatable, dimension(:) :: sendbuf,recvbuf,sendbuf2,recvbuf2
real(r_single), allocatable, dimension(:,:,:) :: grdin2
real(r_double) t1,t2
integer(i_kind) nanal,nn,i,n,nb,nlev
! npts,nlevs,ntrac arrays
integer(i_kind) ierr, np

! must at least nanals tasks allocated.
if (numproc < nanals) then
  print *,'need at least nanals =',nanals,'MPI tasks, exiting ...'
  call mpi_barrier(mpi_comm_world,ierr)
  call mpi_finalize(ierr)
end if
if (npts < numproc) then
  print *,'cannot allocate more than npts =',npts,'MPI tasks, exiting ...'
  call mpi_barrier(mpi_comm_world,ierr)
  call mpi_finalize(ierr)
end if

allocate(scounts(0:numproc-1))
allocate(displs(0:numproc-1))
allocate(rcounts(0:numproc-1))
! only IO tasks send any data.
! scounts is number of data elements to send to processor np.
! rcounts is number of data elements to recv from processor np.
! displs is displacement into send array for data to go to proc np
do np=0,numproc-1
   displs(np) = np*npts_max*ndim
enddo
if (nproc <= nanals-1) then
   scounts = npts_max*ndim
else
   scounts = 0
endif
! displs is also the displacement into recv array for data to go into anal_chunk on
! task np.
do np=0,numproc-1
   if (np <= nanals-1) then
      rcounts(np) = npts_max*ndim
   else
      rcounts(np) = 0
   end if
enddo

! allocate array to hold pieces of state vector on each proc.
allocate(anal_chunk(nanals,npts_max,ndim,nbackgrounds))
if (nproc == 0) print *,'anal_chunk size = ',size(anal_chunk)

if (fso_flag) then
   call get_weight()
   if(nproc <= nanals-1) then
      allocate(grdin2(npts,ndim,nbackgrounds))
   end if
end if

! read in whole state vector on i/o procs - keep in memory
! (needed in write_ensemble)
if (nproc <= nanals-1) then
   allocate(grdin(npts,ndim,nbackgrounds))
   allocate(qsat(npts,nlevs,nbackgrounds))
   nanal = nproc + 1
   t1 = mpi_wtime()
   if (fso_flag) then
      if (fso_have_ferr.or.fso_have_fsen) then
         call readgriddata(nanal,evalft,1,grdin,qsat=qsat)
      else
         call readgriddata(nanal,evalft,1,grdin)
      endif
   else
      call readgriddata(nanal,ft,0,grdin,qsat=qsat)
   endif
   !print *,'min/max qsat',nanal,'=',minval(qsat),maxval(qsat)
   if (use_qsatensmean) then
       ! convert qsat to ensemble mean.
       do nb=1,nbackgrounds
       do nlev=1,nlevs
          call mpi_allreduce(mpi_in_place,qsat(1,nlev,nb),npts,mpi_real8,mpi_sum,mpi_comm_io,ierr)
       enddo
       enddo
       qsat = qsat/real(nanals)
       !print *,'min/max qsat ensmean',nanal,'=',minval(qsat),maxval(qsat)
   endif
   if (nproc == 0) then
     t2 = mpi_wtime()
     print *,'time in readgridata on root',t2-t1,'secs'
     t1 = mpi_wtime()
   end if
   !print *,'min/max ps ens mem',nanal,'=',&
   !         minval(grdin(:,ndim,nbackgrounds/2+1)),maxval(grdin(:,ndim,nbackgrounds/2+1))
   if ((.not.fso_flag) .and. pseudo_rh .and. nvarhumid > 0) then
      do nb=1,nbackgrounds
         ! create normalized humidity analysis variable.
         grdin(:,(nvarhumid-1)*nlevs+1:nvarhumid*nlevs,nb) = &
         grdin(:,(nvarhumid-1)*nlevs+1:nvarhumid*nlevs,nb)/qsat(:,:,nb)
      enddo
   end if
endif
call mpi_barrier(mpi_comm_world, ierr)

allocate(anal_chunk_prior(nanals,npts_max,ndim,nbackgrounds))
allocate(ensmean_chunk(npts_max,ndim,nbackgrounds))
allocate(ensmean_chunk_prior(npts_max,ndim,nbackgrounds))
ensmean_chunk = 0.
if(do_avk) then
   allocate(avkmean_chunk(npts_max,ndim,nbackgrounds))
   avkmean_chunk = 0.
endif
allocate(sendbuf(numproc*npts_max*ndim))
allocate(recvbuf(numproc*npts_max*ndim))

! send and receive buffers.
do nb=1,nbackgrounds ! loop over time levels in background

if (nproc <= nanals-1) then
   ! fill up send buffer.
   do np=1,numproc
     do nn=1,ndim
      do i=1,numptsperproc(np)
       n = ((np-1)*ndim + (nn-1))*npts_max + i
       sendbuf(n) = grdin(indxproc(np,i),nn,nb)
     enddo
    enddo
   enddo
end if
call mpi_alltoallv(sendbuf, scounts, displs, mpi_real4, recvbuf, rcounts, displs,&
                   mpi_real4, mpi_comm_world, ierr)

!==> compute ensemble of first guesses on each task, remove mean from anal.
!$omp parallel do schedule(dynamic,1)  private(nn,i,nanal,n)
do nn=1,ndim
   do i=1,numptsperproc(nproc+1)
      do nanal=1,nanals
         n = ((nanal-1)*ndim + (nn-1))*npts_max + i
         anal_chunk(nanal,i,nn,nb) = recvbuf(n)
      enddo
      ensmean_chunk(i,nn,nb) = sum(anal_chunk(:,i,nn,nb))/float(nanals)
      ensmean_chunk_prior(i,nn,nb) = ensmean_chunk(i,nn,nb)
! remove mean from ensemble.
      do nanal=1,nanals
         anal_chunk(nanal,i,nn,nb) = anal_chunk(nanal,i,nn,nb)-ensmean_chunk(i,nn,nb)
         anal_chunk_prior(nanal,i,nn,nb)=anal_chunk(nanal,i,nn,nb)
      end do
   end do
end do
!$omp end parallel do

enddo ! loop over nbackgrounds
deallocate(sendbuf, recvbuf)

if(fso_flag) then
   ! Get forecast error at the evaluation time and distribute them to all
   ! processors
   allocate(fcerror_chunk(npts_max,ndim))
   allocate(analmean_chunk(npts_max,ndim))
   allocate(sendbuf(numproc*npts_max*ndim))
   allocate(sendbuf2(numproc*npts_max*ndim))
   allocate(recvbuf(npts_max*ndim))
   allocate(recvbuf2(npts_max*ndim))
   if(nproc == 0) then
      if (fso_have_ferr.or.fso_have_fsen) then
         call readgriddata(0,evalft+ft,0,grdin2)
         grdin2 = 0.5_r_kind * grdin2 / real(nanals-1,r_kind)
      else
         ! Forecast from analysis
         call readgriddata(0,evalft,1,grdin2)
         ! Forecast from first guess
         call readgriddata(0,evalft+ft,0,grdin)
         grdin2 = 0.5_r_kind * (grdin2 + grdin)
         ! Analysis at evaluation time
         call readgriddata(0,0,1,grdin,infilename=andataname)
         grdin2 = (grdin2 - grdin) / real(nanals-1,r_kind)
         ! Normalize for surface pressure
         grdin2(:,ndim,nbackgrounds) = grdin2(:,ndim,nbackgrounds)/grdin(:,ndim,nbackgrounds)
      endif
      ! Analysis at initial time
      call readgriddata(0,0,1,grdin)
      do np=1,numproc
         do nn=1,ndim
            do i=1,numptsperproc(np)
               n = ((np-1)*ndim + (nn-1))*npts_max + i
               sendbuf(n) = grdin(indxproc(np,i),nn,nbackgrounds)
               sendbuf2(n) = grdin2(indxproc(np,i),nn,nbackgrounds)
            end do
         end do
      end do
      call mpi_scatter(sendbuf,ndim*npts_max,mpi_real4,recvbuf,ndim*npts_max, &
                        & mpi_real4,0,mpi_comm_world,ierr)
      call mpi_scatter(sendbuf2,ndim*npts_max,mpi_real4,recvbuf2,ndim*npts_max,&
                        & mpi_real4,0,mpi_comm_world,ierr)
   else
       call mpi_scatter(sendbuf,ndim*npts_max,mpi_real4,recvbuf,ndim*npts_max, &
                        & mpi_real4,0,mpi_comm_world,ierr)
       call mpi_scatter(sendbuf2,ndim*npts_max,mpi_real4,recvbuf2,ndim*npts_max,&
                        & mpi_real4,0,mpi_comm_world,ierr)
   end if
!$omp parallel do schedule(dynamic,1)  private(nn,i,n)
   do nn=1,ndim
      do i=1,numptsperproc(nproc+1)
         n = (nn-1)*npts_max + i
         fcerror_chunk(i,nn) = recvbuf2(n)
         analmean_chunk(i,nn) = recvbuf(n)
      end do
   end do
   deallocate(sendbuf,recvbuf,sendbuf2,recvbuf2)
   if(allocated(grdin2)) deallocate(grdin2)
   call divide_weight(analmean_chunk)
   call divide_weight(ensmean_chunk)
end if

if(fso_flag) call destroy_weight()

if (nproc == 0) then
  t2 = mpi_wtime()
  print *,'time to scatter state on root',t2-t1,'secs'
endif

end subroutine read_ensemble

subroutine write_ensemble(no_inflate_flag)
! retrieve pieces of updated ensemble from each task to IO tasks,
! write out each ensemble member to a separate file.
! for now, first nanals tasks are IO tasks.
implicit none
logical, intent(in) :: no_inflate_flag
real(r_single), allocatable, dimension(:) :: sendbuf, recvbuf
real(r_single), allocatable, dimension(:,:,:) :: ensmean
real(r_double) t1,t2
integer(i_kind) nanal,i,nvar
integer(i_kind) ierr, np, n, nn, nb
logical :: fso_output

! all tasks send data, but only IO tasks receive any data.
! scounts is number of data elements to send to processor np.
! rcounts is number of data elements to recv from processor np.
! displs is displacement into send array for data to go to proc np
if (nproc <= nanals-1) then
   rcounts = npts_max*ndim
else
   rcounts = 0
endif
do np=0,numproc-1
   displs(np) = np*npts_max*ndim
   if (np <= nanals-1) then
      scounts(np) = npts_max*ndim
   else
      scounts(np) = 0
   end if
enddo
allocate(recvbuf(numproc*npts_max*ndim))
allocate(sendbuf(numproc*npts_max*ndim))

t1 = mpi_wtime()
do nb=1,nbackgrounds ! loop over time levels in background
  do nn=1,ndim
   do i=1,numptsperproc(nproc+1)
    do nanal=1,nanals
      n = ((nanal-1)*ndim + (nn-1))*npts_max + i
      if (do_avk) then
         sendbuf(n) = avkmean_chunk(i,nn,nb)
      else
         ! add ensemble mean back in.
         sendbuf(n) = anal_chunk(nanal,i,nn,nb)+ensmean_chunk(i,nn,nb)
         ! convert to increment (A-F).
         sendbuf(n) = sendbuf(n)-(anal_chunk_prior(nanal,i,nn,nb)+ensmean_chunk_prior(i,nn,nb))
      endif
    enddo
   enddo
  enddo
  call mpi_alltoallv(sendbuf, scounts, displs, mpi_real4, recvbuf, rcounts, displs,&
                     mpi_real4, mpi_comm_world, ierr)
  if (nproc <= nanals-1) then
     do np=1,numproc
      do nn=1,ndim
       do i=1,numptsperproc(np)
         n = ((np-1)*ndim + (nn-1))*npts_max + i
         grdin(indxproc(np,i),nn,nb) = recvbuf(n)
       enddo
      enddo
     enddo
     !print *,nproc,'min/max ps',minval(grdin(:,ndim)),maxval(grdin(:,ndim))
  end if
enddo ! end loop over background time levels

if (nproc == 0) then
  t2 = mpi_wtime()
  print *,'time to gather state on root',t2-t1,'secs'
endif

deallocate(sendbuf,recvbuf)
if (nproc == 0) then
   allocate(ensmean(npts,ndim,nbackgrounds))
end if
allocate(sendbuf(npts*ndim))
allocate(recvbuf(npts*ndim))
if (nproc == 0) t1 = mpi_wtime()
do nb=1,nbackgrounds
   if (nproc .eq. 0) then
   print *,'time level ',nb
   print *,'--------------'
   endif
   ! gather ens. mean anal. increment on root, print out max/mins.
   n = 0
   do nn=1,ndim
    do i=1,numptsperproc(nproc+1)
      n = n + 1
      ! anal. increment.
      sendbuf(n) = ensmean_chunk(i,nn,nb)-ensmean_chunk_prior(i,nn,nb)
    enddo
   enddo
   do np=0,numproc-1
      scounts(np) = numptsperproc(np+1)*ndim
      n = 0
      do nn=1,np
         n = n + numptsperproc(nn)*ndim
      enddo
      displs(np) = n
   enddo
   call mpi_gatherv(sendbuf, numptsperproc(nproc+1)*ndim, mpi_real4, recvbuf, &
         scounts, displs, mpi_real4, 0, mpi_comm_world, ierr)
   if (nproc == 0) then
      n = 0
      do np=1,numproc
        do nn=1,ndim
         do i=1,numptsperproc(np)
           n = n + 1
           ensmean(indxproc(np,i),nn,nb) = recvbuf(n)
         enddo
        enddo
      enddo
      if (massbal_adjust) then
        print *,'ens. mean anal. increment min/max ps tend', minval(ensmean(:,ndim-1,nb)),maxval(ensmean(:,ndim-1,nb))
      endif
      print *,'ens. mean anal. increment min/max ps', minval(ensmean(:,ndim,nb)),maxval(ensmean(:,ndim,nb))
      do nvar=1,nsfcvars
         print *,'ens. mean anal. increment min/max 2d-var',nvar,minval(ensmean(:,nvars*nlevs+nvar,nb)),maxval(ensmean(:,nvars*nlevs+nvar,nb))
      enddo
      do nvar=1,nvars
         print *,'ens. mean anal. increment min/max var',nvar, &
           minval(ensmean(:,(nvar-1)*nlevs+1:nvar*nlevs,nb)),maxval(ensmean(:,(nvar-1)*nlevs+1:nvar*nlevs,nb))
      enddo
   end if
enddo ! end loop over time levels in background

if (nproc .eq. 0) then
   t2 = mpi_wtime()
   print *,'time to gather ens mean increment on root',t2-t1,'secs'
endif

deallocate(sendbuf,recvbuf)
if (nproc == 0) deallocate(ensmean)

if (nproc <= nanals-1) then
   nanal = nproc + 1
   t1 = mpi_wtime()
   if (pseudo_rh .and. nvarhumid > 0) then
      do nb=1,nbackgrounds
      ! re-scale normalized spfh with sat. sphf of first guess
      grdin(:,(nvarhumid-1)*nlevs+1:nvarhumid*nlevs,nb) = &
      grdin(:,(nvarhumid-1)*nlevs+1:nvarhumid*nlevs,nb)*qsat(:,:,nb)
      enddo
   end if
   call writegriddata(nanal,grdin,no_inflate_flag)
   if (nproc == 0) then
     t2 = mpi_wtime()
     print *,'time in writegriddata on root',t2-t1,'secs'
   endif
end if

end subroutine write_ensemble

subroutine statevec_cleanup()
! deallocate module-level allocatable arrays.
if(do_avk) then
   deallocate(avkmean_chunk)
endif
if (allocated(anal_chunk)) deallocate(anal_chunk)
if (allocated(anal_chunk_prior)) deallocate(anal_chunk_prior)
if (allocated(ensmean_chunk)) deallocate(ensmean_chunk)
if (allocated(ensmean_chunk_prior)) deallocate(ensmean_chunk_prior)
if (allocated(fcerror_chunk)) deallocate(fcerror_chunk)
if (allocated(analmean_chunk)) deallocate(analmean_chunk)
if (nproc <= nanals-1 .and. allocated(grdin)) deallocate(grdin)
if (nproc <= nanals-1 .and. allocated(qsat)) deallocate(qsat)
deallocate(displs,scounts,rcounts)
end subroutine statevec_cleanup

end module statevec


!--------1---------2---------3---------4---------5---------6---------7---------8

MODULE cpmd_variables

  use array_bound_module
  use parallel_module
  use watch_module

!_switch
  integer :: iswitch_md
!_constants
  real(8),parameter :: TOANGS=0.52917724924d+00   ! (a.u./Ang)
  real(8),parameter :: TOMETR=TOANGS*1.0D-10      ! (Ang/m)
  real(8),parameter :: TOKCAL=627.5131018d+00     ! (kcal/mol/a.u.)
  real(8),parameter :: TOJOUL=4.35975D-18         ! (J/a.u.)
  real(8),parameter :: AVOGAD=6.022045d+26        ! (N/mole)
  real(8),parameter :: PLANCK=6.626176D-34        ! h
  real(8),parameter :: CLIGHT=2.99792458d+10      ! (m/s)
  real(8),parameter :: FEMTO=1.0D-15              ! (fs)
  real(8),parameter :: KB=1.380658d-23            ! (J/K)
  real(8),parameter :: FS_TO_AU=41.3413737896d0   ! (a.u./fs)
  real(8),parameter :: AMU=1822.8880d0            ! (atomic mass unit)
  real(8),parameter :: Pi2= 6.283185307179586d0   ! Pi*2
!_for Born-Oppenheimer molecular dynamics
  integer :: nstep
  real(8) :: dt
  real(8) :: deltat
  real(8) :: temp,trange,dsettemp
  real(8) :: omegan
  real(8) :: emass
!  integer,allocatable :: iatom(:)          ! ordering   of nuclei
  real(8),allocatable :: Velocity(:,:)     ! velocity   of nuclei
!_for Car-Parrinello molecualr dynamics
!#ifdef _DRSDFT_
  real(8),allocatable :: psi_v(:,:,:,:) ! velocity   of wavefunction
  real(8),allocatable :: psi_n(:,:,:,:) ! updated    of wavefunction
!#else
!  complex(8),allocatable :: psi_v(:,:,:,:) ! velocity   of wavefunction
!  complex(8),allocatable :: psi_n(:,:,:,:) ! updated    of wavefunction
!#endif
  real(8),allocatable :: zam(:,:)
  real(8),allocatable :: tau(:,:)
  real(8),allocatable :: sig(:,:)
  real(8),allocatable :: gam(:,:)
  real(8),allocatable :: gamn(:,:)
  real(8),allocatable :: scr(:,:)
  real(8),allocatable :: wrk(:,:)
  integer,allocatable :: mstocck(:,:)
  integer :: MBC,MBT
!--- band-parallel
  integer :: MB_0_CPMD, MB_1_CPMD
  integer :: MB_0_SCF, MB_1_SCF
  integer,allocatable :: ir_band_cpmd(:),id_band_cpmd(:)
! massive Nose-Hoover chain
  real(8) :: wt2(7),wt4(7),wt8(7)
  integer, parameter :: nch=4
  integer, parameter :: nche=4
  integer, parameter :: ndc=2
  integer, parameter :: nys=7
  real(8),allocatable :: xmns(:)
  real(8),allocatable :: vmns(:)
  real(8),allocatable :: gmns(:)
  real(8),allocatable :: qmns(:)
  real(8) :: fkt
  real(8) :: fnkt
! ewald
  integer,parameter :: maxkap=10
  real(8),allocatable :: Clm(:),Slm(:)
  real(8),allocatable :: elc(:,:),els(:,:)
  real(8),allocatable :: emc(:,:),ems(:,:)
  real(8),allocatable :: enc(:,:),ens(:,:)
  real(8),allocatable :: Ake(:),Cks(:),Ckc(:)
!_common
  real(8) :: vw(4),pmass(41)
  character*2  :: batm(41)
  data pmass/1.00794d0,4.003d0,6.941d0,9.012d0,10.81d0,&
       12.00d0,14.01d0,16.00d0,19.00d0,20.18d0,&
       22.99d0,24.31d0,26.98d0,28.0855d0,30.97d0,&
       32.07d0,35.45d0,39.95d0,39.10d0,40.08d0,&
       44.96d0,47.87d0,50.94d0,52.00d0,54.94d0,&
       55.84d0,58.93d0,58.69d0,63.55d0,65.39d0,&
       69.72d0,72.61d0,74.92d0,78.96d0,79.90d0,&
       83.80d0,85.45d0,87.62d0,88.91d0,91.22d0,&
       92.91d0/
!_atom
  data batm/'H' ,'He','Li','Be','B' ,&
       'C' ,'N' ,'O' ,'F' ,'Ne',&
       'Na','Mg','Al','Si','P' ,&
       'S' ,'Cl','Ar','K' ,'Ca',&
       'Sc','Ti','V' ,'Cr','Mn',&
       'Fe','Co','Ni','Cu','Zn',&
       'Ga','Ge','As','Se','Br',&
       'Kr','Rb','Sr','Y' ,'Zr',&
       'Nb'/
!_control
  logical :: inivel,lcpmd,lbath,lmeta
!_end
  real(8) :: dtsuz(9)
  real(8) :: gkt(1,1)
  real(8) :: qnospc(nch,1)
  real(8) :: etap1(nch,1)
  real(8) :: fetapv(nch)
  real(8) :: etap1dot(nch,1)
  logical :: lbere,lbathnew,lscale,lscaleele,lquench,lforce_fast,lbathnewe
  logical :: lrestart_p,lrestart_e,linitnose,linitnosee
  real(8) :: ekin1, ekin2, ekinw
!_electron
  real(8) :: qnosee(nche)
  real(8) :: etadot(nche,1)
  real(8) :: etap(nche,1)
  integer :: nedof
  real(8) :: feta(nche+1)
  real(8) :: wnosee,wnose0

  integer :: Ndof
  integer :: MI
!  integer :: myrank
  integer,allocatable :: mkd(:)
  character(30),allocatable :: file_ps(:)
  real(8),allocatable :: asi(:,:),Rion(:,:)
  real(8),allocatable :: aa(:,:)
  real(8),allocatable :: occ(:,:,:)
!  integer :: MSP_0,MSP_1,MBZ_0,MBZ_1,MB_0,MB_1
!  integer,allocatable :: ircnt(:),idisp(:)
!  integer :: nprocs
  real(8),allocatable :: Force(:,:)
!  integer :: MB
  real(8) :: pi
!  real(8),allocatable :: unk(:,:,:,:)
  real(8) :: Etot
  logical :: DISP_SWITCH
  real(8),allocatable :: aaL(:)
  real(8),allocatable :: esp(:,:,:)
  real(8),allocatable :: Vloc(:,:)
  real(8),allocatable :: bb(:,:)
  real(8),allocatable :: Vh(:)
  real(8),allocatable :: Vxc(:,:)
  real(8),allocatable :: Vion(:)
  integer :: Diter,Diter1
  integer :: TYPE_MAIN
  integer :: MBSIZE,NBSIZE
  integer :: NBLK2
  real(8),allocatable :: vtmp2(:,:)
  integer :: NBLK1
  integer :: NBLK
!  integer :: MBZ
  real(8) :: zero
  real(8),allocatable :: utmp2(:,:)
  integer :: TRANSA,TRANSB
  real(8) :: dV
!  integer :: comm_grid
!  integer,allocatable :: id_class(:,:)
!  integer :: np_band
!  integer :: myrank_b
!  integer :: comm_band
!  integer,allocatable :: id_band(:)
!  integer,allocatable :: ir_band(:)
!  integer :: np_grid
!  integer,allocatable :: id_grid(:),ir_grid(:)
!  integer,allocatable :: id_spin(:),ir_spin(:)
!  integer,allocatable :: id_bzsm(:),ir_bzsm(:)
  integer,allocatable :: irlabel(:,:),irdim(:)
  integer,allocatable :: irlabel2n(:,:,:)
!  integer :: myrank_g
  real(8),allocatable :: utmp3(:,:,:),utmp(:)
  integer,allocatable :: LL2(:,:),LL(:,:)
!  integer :: ML
  integer :: ML1,ML2,ML3
  integer :: ML_irreducible
  integer,allocatable :: rga(:,:,:)
  integer :: isymmetry,nsym
  real(8),allocatable :: Rir(:,:,:,:)
  integer :: MBwr1,MBwr2
!  integer :: MB_d
  integer :: nspin
  integer :: SYStype
  character(30) :: FILE_WF2,FILE_WF
!  include 'mpif.h'
!--------------for blue-moon------------------------
!  real(8),allocatable :: ylagr(:),xlagr(:)
!  integer,allocatable :: ipvt(:)
!  real(8),allocatable :: DT2BYM(:),DTB2MI(:)
!  real(8),allocatable :: pm_dim(:)
!  real(8),allocatable :: Rion0(:,:)
!  real(8),allocatable :: fc(:),fv(:)
!  real(8),allocatable :: anorm(:,:)
  logical :: lblue
!  integer :: mcnstr,nodim,ityp
!  integer :: ia(10),ib(10),ic(10)
!  real(8) :: cnpar(2,10)
!  real(8) :: cval(10)
!  integer :: index(10)

  integer :: itime
  integer :: trjstep=1
  integer :: wrtstep=0
  integer :: all_traj=0
  integer :: ctrl_cpmdio=100

END MODULE cpmd_variables


MODULE tramle
  USE oce
  USE dom_oce
  USE phycst
  USE zdfmxl
  USE in_out_manager
  USE iom
  USE lib_mpp
  USE lbclnk
  IMPLICIT NONE
  PRIVATE
  PUBLIC :: tra_mle_trp
  PUBLIC :: tra_mle_init
  LOGICAL, PUBLIC :: ln_mle
  INTEGER :: nn_mle
  INTEGER :: nn_mld_uv
  INTEGER :: nn_conv
  REAL(KIND = wp) :: rn_ce
  REAL(KIND = wp) :: rn_lf
  REAL(KIND = wp) :: rn_time
  REAL(KIND = wp) :: rn_lat
  REAL(KIND = wp) :: rn_rho_c_mle
  REAL(KIND = wp) :: r5_21 = 5.E0 / 21.E0
  REAL(KIND = wp) :: rb_c
  REAL(KIND = wp) :: rc_f
  REAL(KIND = wp), ALLOCATABLE, SAVE, DIMENSION(:, :) :: rfu, rfv
  REAL(KIND = wp), ALLOCATABLE, SAVE, DIMENSION(:, :) :: r1_ft
  CONTAINS
  SUBROUTINE tra_mle_trp(kt, kit000, pu, pv, pw, cdtype)
    INTEGER, INTENT(IN   ) :: kt
    INTEGER, INTENT(IN   ) :: kit000
    CHARACTER(LEN = 3), INTENT(IN   ) :: cdtype
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(INOUT) :: pu
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(INOUT) :: pv
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(INOUT) :: pw
    INTEGER :: ji, jj, jk
    INTEGER :: ii, ij, ik, ikmax
    REAL(KIND = wp) :: zcuw, zmuw, zc
    REAL(KIND = wp) :: zcvw, zmvw
    INTEGER, DIMENSION(jpi, jpj) :: inml_mle
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zpsim_u, zpsim_v, zmld, zbm, zhu, zhv, zn2, zLf_NH, zLf_MH
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: zpsi_uw, zpsi_vw
    !$ACC KERNELS
    inml_mle(:, :) = mbkt(:, :) + 1
    !$ACC END KERNELS
    IF (nla10 > 0) THEN
      !$ACC KERNELS
      DO jk = jpkm1, nlb10, - 1
        DO jj = 1, jpj
          DO ji = 1, jpi
            IF (rhop(ji, jj, jk) > rhop(ji, jj, nla10) + rn_rho_c_mle) inml_mle(ji, jj) = jk
          END DO
        END DO
      END DO
      !$ACC END KERNELS
    END IF
    ikmax = MIN(MAXVAL(inml_mle(:, :)), jpkm1)
    !$ACC KERNELS
    zmld(:, :) = 0._wp
    zbm(:, :) = 0._wp
    zn2(:, :) = 0._wp
    DO jk = 1, ikmax
      DO jj = 1, jpj
        DO ji = 1, jpi
          zc = e3t_n(ji, jj, jk) * REAL(MIN(MAX(0, inml_mle(ji, jj) - jk), 1))
          zmld(ji, jj) = zmld(ji, jj) + zc
          zbm(ji, jj) = zbm(ji, jj) + zc * (rau0 - rhop(ji, jj, jk)) * r1_rau0
          zn2(ji, jj) = zn2(ji, jj) + zc * (rn2(ji, jj, jk) + rn2(ji, jj, jk + 1)) * 0.5_wp
        END DO
      END DO
    END DO
    !$ACC END KERNELS
    SELECT CASE (nn_mld_uv)
    CASE (0)
      !$ACC KERNELS
      DO jj = 1, jpjm1
        DO ji = 1, jpim1
          zhu(ji, jj) = MIN(zmld(ji + 1, jj), zmld(ji, jj))
          zhv(ji, jj) = MIN(zmld(ji, jj + 1), zmld(ji, jj))
        END DO
      END DO
      !$ACC END KERNELS
    CASE (1)
      !$ACC KERNELS
      DO jj = 1, jpjm1
        DO ji = 1, jpim1
          zhu(ji, jj) = (zmld(ji + 1, jj) + zmld(ji, jj)) * 0.5_wp
          zhv(ji, jj) = (zmld(ji, jj + 1) + zmld(ji, jj)) * 0.5_wp
        END DO
      END DO
      !$ACC END KERNELS
    CASE (2)
      !$ACC KERNELS
      DO jj = 1, jpjm1
        DO ji = 1, jpim1
          zhu(ji, jj) = MAX(zmld(ji + 1, jj), zmld(ji, jj))
          zhv(ji, jj) = MAX(zmld(ji, jj + 1), zmld(ji, jj))
        END DO
      END DO
      !$ACC END KERNELS
    END SELECT
    !$ACC KERNELS
    zbm(:, :) = + grav * zbm(:, :) / MAX(e3t_n(:, :, 1), zmld(:, :))
    !$ACC END KERNELS
    IF (nn_mle == 0) THEN
      !$ACC KERNELS
      DO jj = 1, jpjm1
        DO ji = 1, jpim1
          zpsim_u(ji, jj) = rn_ce * zhu(ji, jj) * zhu(ji, jj) * e2_e1u(ji, jj) * (zbm(ji + 1, jj) - zbm(ji, jj)) * MIN(111.E3_wp, e1u(ji, jj)) / (MAX(rn_lf * rfu(ji, jj), SQRT(rb_c * zhu(ji, jj))))
          zpsim_v(ji, jj) = rn_ce * zhv(ji, jj) * zhv(ji, jj) * e1_e2v(ji, jj) * (zbm(ji, jj + 1) - zbm(ji, jj)) * MIN(111.E3_wp, e2v(ji, jj)) / (MAX(rn_lf * rfv(ji, jj), SQRT(rb_c * zhv(ji, jj))))
        END DO
      END DO
      !$ACC END KERNELS
    ELSE IF (nn_mle == 1) THEN
      !$ACC KERNELS
      DO jj = 1, jpjm1
        DO ji = 1, jpim1
          zpsim_u(ji, jj) = rc_f * zhu(ji, jj) * zhu(ji, jj) * e2_e1u(ji, jj) * (zbm(ji + 1, jj) - zbm(ji, jj)) * MIN(111.E3_wp, e1u(ji, jj))
          zpsim_v(ji, jj) = rc_f * zhv(ji, jj) * zhv(ji, jj) * e1_e2v(ji, jj) * (zbm(ji, jj + 1) - zbm(ji, jj)) * MIN(111.E3_wp, e2v(ji, jj))
        END DO
      END DO
      !$ACC END KERNELS
    END IF
    IF (nn_conv == 1) THEN
      !$ACC KERNELS
      DO jj = 1, jpjm1
        DO ji = 1, jpim1
          IF (MIN(zn2(ji, jj), zn2(ji + 1, jj)) < 0._wp) zpsim_u(ji, jj) = 0._wp
          IF (MIN(zn2(ji, jj), zn2(ji, jj + 1)) < 0._wp) zpsim_v(ji, jj) = 0._wp
        END DO
      END DO
      !$ACC END KERNELS
    END IF
    !$ACC KERNELS
    DO jj = 1, jpjm1
      DO ji = 1, jpim1
        zhu(ji, jj) = 1._wp / zhu(ji, jj)
        zhv(ji, jj) = 1._wp / zhv(ji, jj)
      END DO
    END DO
    zpsi_uw(:, :, :) = 0._wp
    zpsi_vw(:, :, :) = 0._wp
    DO jk = 2, ikmax
      DO jj = 1, jpjm1
        DO ji = 1, jpim1
          zcuw = 1._wp - (gdepw_n(ji + 1, jj, jk) + gdepw_n(ji, jj, jk)) * zhu(ji, jj)
          zcvw = 1._wp - (gdepw_n(ji, jj + 1, jk) + gdepw_n(ji, jj, jk)) * zhv(ji, jj)
          zcuw = zcuw * zcuw
          zcvw = zcvw * zcvw
          zmuw = MAX(0._wp, (1._wp - zcuw) * (1._wp + r5_21 * zcuw))
          zmvw = MAX(0._wp, (1._wp - zcvw) * (1._wp + r5_21 * zcvw))
          zpsi_uw(ji, jj, jk) = zpsim_u(ji, jj) * zmuw * umask(ji, jj, jk)
          zpsi_vw(ji, jj, jk) = zpsim_v(ji, jj) * zmvw * vmask(ji, jj, jk)
        END DO
      END DO
    END DO
    DO jk = 1, ikmax
      DO jj = 1, jpjm1
        DO ji = 1, jpim1
          pu(ji, jj, jk) = pu(ji, jj, jk) + (zpsi_uw(ji, jj, jk) - zpsi_uw(ji, jj, jk + 1))
          pv(ji, jj, jk) = pv(ji, jj, jk) + (zpsi_vw(ji, jj, jk) - zpsi_vw(ji, jj, jk + 1))
        END DO
      END DO
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          pw(ji, jj, jk) = pw(ji, jj, jk) - (zpsi_uw(ji, jj, jk) - zpsi_uw(ji - 1, jj, jk) + zpsi_vw(ji, jj, jk) - zpsi_vw(ji, jj - 1, jk))
        END DO
      END DO
    END DO
    !$ACC END KERNELS
    IF (cdtype == 'TRA') THEN
      !$ACC KERNELS
      zLf_NH(:, :) = SQRT(rb_c * zmld(:, :)) * r1_ft(:, :)
      !$ACC END KERNELS
      CALL iom_put("Lf_NHpf", zLf_NH)
      !$ACC KERNELS
      DO jk = 1, ikmax + 1
        zpsi_uw(:, :, jk) = zpsi_uw(:, :, jk) * r1_e2u(:, :)
        zpsi_vw(:, :, jk) = zpsi_vw(:, :, jk) * r1_e1v(:, :)
      END DO
      !$ACC END KERNELS
      CALL iom_put("psiu_mle", zpsi_uw)
      CALL iom_put("psiv_mle", zpsi_vw)
    END IF
  END SUBROUTINE tra_mle_trp
  SUBROUTINE tra_mle_init
    INTEGER :: ji, jj, jk
    INTEGER :: ierr
    INTEGER :: ios
    REAL(KIND = wp) :: z1_t2, zfu, zfv
    NAMELIST /namtra_mle/ ln_mle, nn_mle, rn_ce, rn_lf, rn_time, rn_lat, nn_mld_uv, nn_conv, rn_rho_c_mle
    REWIND(UNIT = numnam_ref)
    READ(numnam_ref, namtra_mle, IOSTAT = ios, ERR = 901)
901 IF (ios /= 0) CALL ctl_nam(ios, 'namtra_mle in reference namelist', lwp)
    REWIND(UNIT = numnam_cfg)
    READ(numnam_cfg, namtra_mle, IOSTAT = ios, ERR = 902)
902 IF (ios > 0) CALL ctl_nam(ios, 'namtra_mle in configuration namelist', lwp)
    IF (lwm) WRITE(numond, namtra_mle)
    IF (lwp) THEN
      WRITE(numout, FMT = *)
      WRITE(numout, FMT = *) 'tra_mle_init : mixed layer eddy (MLE) advection acting on tracers'
      WRITE(numout, FMT = *) '~~~~~~~~~~~~~'
      WRITE(numout, FMT = *) '   Namelist namtra_mle : mixed layer eddy advection applied on tracers'
      WRITE(numout, FMT = *) '      use mixed layer eddy (MLE, i.e. Fox-Kemper param) (T/F)      ln_mle       = ', ln_mle
      WRITE(numout, FMT = *) '         MLE type: =0 standard Fox-Kemper ; =1 new formulation        nn_mle    = ', nn_mle
      WRITE(numout, FMT = *) '         magnitude of the MLE (typical value: 0.06 to 0.08)           rn_ce     = ', rn_ce
      WRITE(numout, FMT = *) '         scale of ML front (ML radius of deformation) (rn_mle=0)      rn_lf     = ', rn_lf, 'm'
      WRITE(numout, FMT = *) '         maximum time scale of MLE                    (rn_mle=0)      rn_time   = ', rn_time, 's'
      WRITE(numout, FMT = *) '         reference latitude (degrees) of MLE coef.    (rn_mle=1)      rn_lat    = ', rn_lat, 'deg'
      WRITE(numout, FMT = *) '         space interp. of MLD at u-(v-)pts (0=min,1=averaged,2=max)   nn_mld_uv = ', nn_mld_uv
      WRITE(numout, FMT = *) '         =1 no MLE in case of convection ; =0 always MLE              nn_conv   = ', nn_conv
      WRITE(numout, FMT = *) '         Density difference used to define ML for FK              rn_rho_c_mle  = ', rn_rho_c_mle
    END IF
    IF (lwp) THEN
      WRITE(numout, FMT = *)
      IF (ln_mle) THEN
        WRITE(numout, FMT = *) '   ==>>>   Mixed Layer Eddy induced transport added to tracer advection'
        IF (nn_mle == 0) WRITE(numout, FMT = *) '              Fox-Kemper et al 2010 formulation'
        IF (nn_mle == 1) WRITE(numout, FMT = *) '              New formulation'
      ELSE
        WRITE(numout, FMT = *) '   ==>>>   Mixed Layer Eddy parametrisation NOT used'
      END IF
    END IF
    IF (ln_mle) THEN
      rb_c = grav * rn_rho_c_mle / rau0
      IF (lwp) WRITE(numout, FMT = *)
      IF (lwp) WRITE(numout, FMT = *) '      ML buoyancy criteria = ', rb_c, ' m/s2 '
      IF (lwp) WRITE(numout, FMT = *) '      associated ML density criteria defined in zdfmxl = ', rho_c, 'kg/m3'
      IF (nn_mle == 0) THEN
        ALLOCATE(rfu(jpi, jpj), rfv(jpi, jpj), STAT = ierr)
        IF (ierr /= 0) CALL ctl_stop('tra_adv_mle_init: failed to allocate arrays')
        !$ACC KERNELS
        z1_t2 = 1._wp / (rn_time * rn_time)
        DO jj = 2, jpj
          DO ji = 2, jpi
            zfu = (ff_f(ji, jj) + ff_f(ji, jj - 1)) * 0.5_wp
            zfv = (ff_f(ji, jj) + ff_f(ji - 1, jj)) * 0.5_wp
            rfu(ji, jj) = SQRT(zfu * zfu + z1_t2)
            rfv(ji, jj) = SQRT(zfv * zfv + z1_t2)
          END DO
        END DO
        !$ACC END KERNELS
        CALL lbc_lnk_multi(rfu, 'U', 1., rfv, 'V', 1.)
      ELSE IF (nn_mle == 1) THEN
        rc_f = rn_ce / (5.E3_wp * 2._wp * omega * SIN(rad * rn_lat))
      END IF
      ALLOCATE(r1_ft(jpi, jpj), STAT = ierr)
      IF (ierr /= 0) CALL ctl_stop('tra_adv_mle_init: failed to allocate r1_ft array')
      !$ACC KERNELS
      z1_t2 = 1._wp / (rn_time * rn_time)
      r1_ft(:, :) = 1._wp / SQRT(ff_t(:, :) * ff_t(:, :) + z1_t2)
      !$ACC END KERNELS
    END IF
  END SUBROUTINE tra_mle_init
END MODULE tramle


c=======================================================================
c SBDART gaseous absorption module
c
c BM extracted code from SBDART version 1.50, September 12, 2002
c The code in depthscl.f required heavy changes to work with libRadtran;
c in particular, only the gaseous absorption things were kept while all
c aerosol, cloud, and Rayleigh scattering stuff was removed.
c=======================================================================
      subroutine depthscl(kdist, kd, nk, nz, wl, dtausc,
     &     gwk, dtauk, dtaugc,
     &     wt, dtau)
      IMPLICIT NONE

c input:
c   kdist   k-distribution mode index
c           -1  read k-distribution dtauk, gwk from LOUTF
c            0  tau set to -log(transmission_vertical_path)
c               slant optical depth used when tau_scat < 1 and wl < 4
c            1  no renormalization of lowtran k-distribution tau
c            2  corrected to solar beam slant path transmission
c            3  corrected to solar beam slant path transmission when
c               tau_scat < 1 and wl < 4
c
c  kd      k-distribution index
c  nk      number of k-distribution passes
c  nz      number of vertical layers
c  wl      wavelength
c  dtausc  scattering optical depth increment
c  gwk     k-distribution weights
c  dtauk   k-distribution optical depths for absorption by molecular lines
c  dtaugc  gas continuum optical depth
c
c output:
c  dtau   atmospheric optical depth increment

      INCLUDE 'sbtaugas.inc'
      integer kd, nk, nz, kdist, i, iw

      integer mk                        ! number of lowtran k-dist terms
      parameter (mk = 3)

      double precision dtausc(mxly),
     &   dtau(mxly), wt, dtaug(mxly), afac, tglv, tgls, tsc,
     &   ramp, wl, gwk(mxkd), dtauk(mxly,mxkd), dtaugc(mxly)

      doubleprecision d1, d2, d3, d4, d5
      integer j1
                                ! get gas optical depth

      wt = gwk(kd)
      if (kdist .eq. (-1)) then                  ! tau from LOUTF
         do j1 = 1, nz
            dtaug(j1) = dtauk(j1,kd)
         end do
      else if (kdist.eq.0 .or. nk.eq.1) then    ! tau=-log(transmission)
         wt = 1.
         tsc = 0.
         tglv = 0.
         tgls = 0.
         do i = 1, nz
            tglv = tglv + dtauk(i,1)             ! vertical path
            tgls = tgls + dtauk(i,1+3)           ! amu0 * slant path
            tsc = tsc + dtausc(i)
            afac = 1.
            if (tglv .gt. .001) afac = tgls/tglv
            call depthscl_rolloff (wl, tsc, ramp)
            afac = afac*ramp + 1. - ramp
            dtaug(i) = dtaugc(i) + dtauk(i,1)*afac
         end do
      else if (kdist .eq. 1) then                ! uncorrected
         do j1 = 1, nz
            dtaug(j1) = dtaugc(j1) + dtauk(j1,kd)
         end do
      else if (kdist .eq. 2) then ! corrected to slant path transmission
         do j1 = 1, nz
            dtaug(j1) = dtaugc(j1) + dtauk(j1,kd+3)
         end do
      else                                       ! ramp to uncorrected
         tsc = 0.
         do i = 1, nz
            tsc = tsc + dtausc(i)
            call depthscl_rolloff (wl, tsc, ramp)
            dtaug(i)=dtaugc(i)+dtauk(i,kd)*(1.-ramp)+dtauk(i,kd+3)*ramp
         end do
      endif
                                ! zero out optical depth in sub-surface
      do i = 1, nz
         dtau(i) = dtaug(i) + dtausc(i)
      end do

      return
      end
c-----------------------------------------------------------------------
      subroutine depthscl_rolloff(wl, tsc, ramp)
c purpose: compute roll-off factor for transition from full slant-path
c          correction to uncorrected vertical optical depths.
c
c input:
c  wl      wavelength
c  tsc     scattering optical depth
c output:
c  ramp    roll-off factor (drops to zero when either the scattering
c          optical depth is large, or the wavelength exceeds wlhi)

      INCLUDE 'sbtaugas.inc'

      double precision wl, tsc, ramp
      double precision wllo, wlhi      ! wavelength roll-off upper limit
      parameter (wllo = 3.9, wlhi = 4.1)
      doubleprecision d1, d2, d3, d4, d5
      integer j1

      ramp = (wlhi - wl)/(wlhi - wllo)
      ramp = max(min(one,ramp),zero)
      ramp = ramp*exp(1. - max(tsc,one))
      return

      end


C    Copyright(C) 2014-2017 National Technology & Engineering Solutions of
C    Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    Redistribution and use in source and binary forms, with or without
C    modification, are permitted provided that the following conditions are
C    met:
C
C    * Redistributions of source code must retain the above copyright
C       notice, this list of conditions and the following disclaimer.
C
C    * Redistributions in binary form must reproduce the above
C      copyright notice, this list of conditions and the following
C      disclaimer in the documentation and/or other materials provided
C      with the distribution.
C
C    * Neither the name of NTESS nor the names of its
C      contributors may be used to endorse or promote products derived
C      from this software without specific prior written permission.
C
C    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C    A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C    OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C    SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C    LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C    DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C    THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C    (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C    OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
C

C $Id: closel.f,v 1.2 1991/03/21 15:44:25 gdsjaar Exp $
C $Log: closel.f,v $
C Revision 1.2  1991/03/21 15:44:25  gdsjaar
C Changed all 3.14159... to atan2(0.0, -1.0)
C
c Revision 1.1.1.1  1990/11/30  11:05:01  gdsjaar
c FASTQ Version 2.0X
c
c Revision 1.1  90/11/30  11:04:59  gdsjaar
c Initial revision
c
C
CC* FILE: [.MAIN]CLOSEL.FOR
CC* MODIFIED BY: TED BLACKER
CC* MODIFICATION DATE: 7/6/90
CC* MODIFICATION: COMPLETED HEADER INFORMATION
C
      SUBROUTINE CLOSEL (MP, ML, N, COOR, ILINE, LTYPE, LCON, LINKP,
     &   LINKL, X, Y, BIFIND, IFIND, ADDCEN, XCHOLD, YCHOLD)
C***********************************************************************
C
C  SUBROUTINE CLOSEL = FINDS CLOSEST PERPENDICULAR BISECTED LINE
C
C***********************************************************************
C
C  SUBROUTINE CALLED BY:
C     BISECT   =
C
C***********************************************************************
C
C  SUBROUTINES CALLED:
C     DLPARA = DETERMINES LINE PARAMETERS FROM TWO POINTS
C
C***********************************************************************
C
      DIMENSION COOR(2, MP), ILINE(ML), LCON(3, ML), LTYPE(ML), N(29)
      DIMENSION LINKL(2, ML), LINKP(2, MP)
C
      LOGICAL BIFIND, BAD, ADDLNK, ADDCEN, ERR
C
      PI = ATAN2(0.0, -1.0)
      TWOPI = PI + PI
C
C  FIND THE CLOSEST LINE ABOVE THE POINT INPUT
C
      BIFIND = .FALSE.
      ADDLNK = .FALSE.
      IFIND = 0
      DIST = 100000.
      DO 100 I = 1, N(19)
         CALL LTSORT (ML, LINKL, I, II, ADDLNK)
         IF (II .GT. 0) THEN
            KT = LTYPE(II)
            CALL LINEPR (ML, MP, LINKP, LCON, II, I1, I2, I3, J1, J2,
     &         J3)
            IF ((J1 .GT. 0) .AND. (J2 .GT. 0)) THEN
               IF (KT .EQ. 1) THEN
C
C  GET THE PARAMETERS FOR THE LINE
C
                  CALL DLPARA (COOR(1, J1), COOR(2, J1), COOR(1, J2),
     &               COOR(2, J2), XM1, B1, BAD)
C
C  GET DISTANCE FOR VERTICAL LINE
C
                  IF (BAD) THEN
                     DTRY = ABS(COOR(1, J1) - X)
                     XTRY = COOR(1, J1)
                     YTRY = Y
C
C  GET DISTANCE FOR HORIZONTAL LINE
C
                  ELSE IF (ABS(XM1) .LT. .000001) THEN
                     DTRY = ABS(COOR(2, J1) - Y)
                     XTRY = X
                     YTRY = COOR(2, J1)
C
C  GET PERPENDICULAR DISTANCE TO ARBITRARY LINE
C
                  ELSE
                     XM2 = -1./XM1
                     B2 = Y - (XM2*X)
                     XTRY = (B2 - B1)/(XM1 - XM2)
                     YTRY = (XM1*XTRY) + B1
                     DTRY = SQRT((X - XTRY)**2 + (Y - YTRY)**2)
                  END IF
                  IF (DTRY .LE. DIST) THEN
                     X1 = MIN(COOR(1, J1), COOR(1, J2))
                     X2 = MAX(COOR(1, J1), COOR(1, J2))
                     Y1 = MIN(COOR(2, J1), COOR(2, J2))
                     Y2 = MAX(COOR(2, J1), COOR(2, J2))
                     IF ((XTRY .GE. X1) .AND. (XTRY .LE. X2) .AND.
     &                  (YTRY .GE. Y1) .AND. (YTRY .LE. Y2)) THEN
                        DIST = DTRY
                        XHOLD = XTRY
                        YHOLD = YTRY
                        IFIND = I
                        BIFIND = .TRUE.
                     END IF
                  END IF
C
C  CHECK DISTANCES TO CIRCULAR ARCS
C
               ELSE IF ((KT .EQ. 3).OR.(KT .EQ. 4).OR.(KT .EQ. 6)) THEN
C
C  FIRST GET THETA1, THETA2, THETAT, R1, R2, AND RTRY
C
                  CALL ARCPAR (MP, KT, ILINE(II), COOR, LINKP, J1, J2,
     &               J3, I3, XCEN, YCEN, THETA1, THETA2, TANG, R1, R2,
     &               ERR, ICCW, ICW, XK, XA)
C
                  IF ((Y .EQ. YCEN) .AND. (X .EQ. XCEN)) THEN
                     RTRY = 0.
                     THETAT = (THETA1 + THETA2)*.5
                  ELSE
                     THETAT = ATAN2(Y - YCEN, X - XCEN)
                     RTRY = SQRT( ((X - XCEN)**2)  +  ((Y - YCEN)**2))
                  END IF
C
C  SEE IF THE POINT ANGLE IS WITHIN THE BEGINNING AND ENDING ANGLES
C
                  IF ( ((THETAT .LE. THETA2) .AND. (THETAT .GE. THETA1))
     &               .OR. ((THETAT + TWOPI .LE. THETA2) .AND.
     &               (THETAT + TWOPI .GE. THETA1)) ) THEN
C
C  CALCULATE THE ARC RADIUS AT THAT ANGLE
C
                     RADIUS = XA*EXP(XK*THETAT)
                     DTRY = ABS(RADIUS - RTRY)
C
C  CHECK TO SEE IF THE ARC IS THE CLOSEST
C
                     IF (DTRY .LE. DIST) THEN
                        DIST = DTRY
                        XHOLD = XCEN + COS(THETAT)*RADIUS
                        YHOLD = YCEN + SIN(THETAT)*RADIUS
                        IFIND = I
                        IF ((KT .EQ. 4).OR.(KT .EQ. 6)) THEN
                           ADDCEN = .TRUE.
                           XCHOLD = XCEN
                           YCHOLD = YCEN
                        ELSE
                           ADDCEN = .FALSE.
                        END IF
                        BIFIND = .TRUE.
                     END IF
                  END IF
               END IF
            END IF
         END IF
  100 CONTINUE
      X = XHOLD
      Y = YHOLD
C
      RETURN
      END


	SUBROUTINE PC_DFLV  ( noutpm, outprm, chrflg, cmpflg, ncomp,
     +			      iret )
C************************************************************************
C* PC_DFLV								*
C*									*
C* This subroutine defines the output level parameters which will	*
C* be returned when either PC_CMLV or PC_CMVR is called.  The		*
C* output values will be computed from the parameters in the 		*
C* data set.  PC_INIT must be called before PC_DFLV.  The returned	*
C* values of CMPFLG indicate whether the parameters are computable.	*
C* NCOMP is the number of computable parameters found by this		*
C* subroutine.								*
C*									*
C* PC_DFLV  ( NOUTPM, OUTPRM, CHRFLG, CMPFLG, NCOMP, IRET )		*
C*									*
C* Input parameters:							*
C*	NOUTPM		INTEGER		Number of output parameters	*
C*	OUTPRM (NOUTPM)	CHAR*4		Output parameters		*
C*									*
C* Output parameters:							*
C*	CHRFLG (NOUTPM)	LOGICAL		Character data flag 		*
C*	CMPFLG (NOUTPM)	LOGICAL		Computable data flag		*
C*	NCOMP		INTEGER		Number of computable parms	*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 -4 = PC_INIT not called	*
C*					 -5 = invalid # of parms	*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 9/84						*
C* M. desJardins/GSFC	10/86	Modified meaning of CMPFLG		*
C* M. desJardins/GSFC	11/87	Changed character computations		*
C* M. desJardins/GSFC	 9/88	Cleaned up				*
C* M. desJardins/GSFC	 7/89	Initialize chrflg and scmflg		*
C* M. desJardins/GSFC	11/89	Added conditions			*
C* M. desJardins/GSFC	 7/90	Add layer quantities			*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'GMBDTA.CMN'
	INCLUDE 	'pccmn.cmn'
C*
	LOGICAL		chrflg(*), cmpflg(*)
	CHARACTER*(*)	outprm (*)
C-------------------------------------------------------------------------
	ncomp = 0
C
C*	Turn off the level condition flag.
C
	levcnd = .false.
C
C*	Check for errors in input values.
C
	IF  ( .not. dsflg )  THEN
	    iret = -4
	  ELSE IF ( ( noutpm .lt. 1 ) .or. ( noutpm .gt. MAXPRM ) ) THEN
	    iret = -5
	  ELSE
	    iret = 0
	ENDIF
	IF  ( iret .lt. 0 )  RETURN
C
C*	Initialize the computable and character type flags.
C
	DO  i = 1, noutpm
	    cmpflg (i) = .false.
	    chrflg (i) = .false.
	END DO
C
C*	Set up the conversion from data set parameters to output parameters
C*	using index = 1 into the tables. Return if no parameters can be
C*	computed.
C
	ncomp = 0
	index = 1
	CALL PC_METH  ( index, jdsprm, dsparm, noutpm, outprm, cmpflg,
     +			ncomp, ier )
	IF  ( ier .lt. 0 )  THEN
	    iret = ier
	    RETURN
	END IF
C
C*	Check to see if any integrated parameters are requested.
C
	CALL PC_SING  ( noutpm, outprm, cmpflg, ncomp, ier )
C
C*	Check to see if any layer quantities are requested.
C
	CALL PC_SLYR  ( noutpm, outprm, cmpflg, ncomp, ier )
C
C*	Set the character data flags using the flags stored in common.
C*	Store the computable flags in common.
C
	DO  i = 1, noutpm
	    qcmp (i) = cmpflg (i)
	    IF  ( cmpflg (i) )  chrflg (i) = qchr (i)
	ENDDO
C
C*	If interpolation flags are on, set up the interpolation tables.
C
	IF  ( jntflg  .and.  inton  .and.  ( jcord .ne. 0 ) ) THEN
	    index1 = 2
	    index2 = 3
	    CALL  PC_SINT  ( noutpm, outprm, cmpflg, index1, index2,
     +			     ier )
	  ELSE
	    doint = .false.
	ENDIF
C*
	RETURN
	END


module GwfInterfaceModelModule
  use KindModule, only: I4B, DP
  use ConstantsModule, only: DZERO
  use NumericalModelModule, only: NumericalModelType, GetNumericalModelFromList
  use GwfModule, only: GwfModelType
  use GridConnectionModule
  use BaseDisModule
  use GwfDisuModule
  use GwfNpfModule
  use GwfNpfOptionsModule
  use GwfNpfGridDataModule
  use GwfOcModule
  implicit none
  private

  !> The GWF Interface Model is a utility to calculate the solution's
  !! exchange coefficients from the interface between a GWF model and
  !! its GWF neighbors. The interface model itself will not be part
  !! of the solution, it is not being solved.
  !! Patching (a part of the) discretizations of two GWF models in a
  !! general way, e.g. DIS+DIS with refinement, requires the resulting
  !< discretization to be of type DISU.
  type, public, extends(GwfModelType) :: GwfInterfaceModelType
    class(GridConnectionType), pointer    :: gridConnection => null() !< The grid connection class will provide the connections
                                                                      !! object for the interface grid
    class(GwfModelType), private, pointer :: owner => null()          !< the real GWF model for which the exchange coefficients
                                                                      !! are calculated with this interface model
  contains
    procedure, pass(this) :: construct
    procedure, pass(this) :: createModel
    procedure, pass(this) :: defineModel
    procedure, pass(this) :: allocateAndReadModel

    ! override
    procedure :: model_da => deallocateModel

    ! private
    procedure, private, pass(this) :: buildDiscretization
    procedure, private, pass(this) :: setNpfOptions
    procedure, private, pass(this) :: setNpfGridData
  end type

contains

  !> Construction and minimal initialization
  !<
  subroutine construct(this, name, iout)
    use MemoryHelperModule, only: create_mem_path
    class(GwfInterfaceModelType), intent(inout) :: this !< the interface model
    character(len=*), intent(in)  :: name               !< the interface model's name
    integer(I4B), intent(in) :: iout                    !< the output unit, to be passed
                                                        !! to the packages as well

    this%memoryPath = create_mem_path(name)
    call this%allocate_scalars(name)

    ! set default model options
    this%inewton = 0

    this%iout = iout
    ! we need this dummy value
    this%innpf = 999

  end subroutine construct

  ! set up the interface model, analogously to what happens in gwf_cr
  subroutine createModel(this, gridConn)
    use MemoryManagerModule, only: mem_allocate
    use Xt3dModule, only: xt3d_cr
    class(GwfInterfaceModelType), intent(inout) :: this
    class(GridConnectionType), pointer, intent(in) :: gridConn
    ! local
    class(NumericalModelType), pointer :: numMod

    this%gridConnection => gridConn
    numMod => this%gridConnection%model
    select type (numMod)
      class is (GwfModelType)
        this%owner => numMod
      end select

    this%inewton = this%owner%inewton
    this%inewtonur = this%owner%inewtonur

    ! create discretization and packages
    call this%buildDiscretization()
    call npf_cr(this%npf, this%name, this%innpf, this%iout)
    call xt3d_cr(this%xt3d, this%name, this%innpf, this%iout)
    ! continue as in gwf_cr...

  end subroutine createModel

  subroutine defineModel(this, satomega)
    class(GwfInterfaceModelType), intent(inout) :: this
    real(DP) :: satomega
    ! local
    type(GwfNpfOptionsType) :: npfOptions

    this%moffset = 0
    this%npf%satomega = satomega

    ! define NPF package
    call npfOptions%construct()
    call this%setNpfOptions(npfOptions)
    call this%npf%npf_df(this%dis, this%xt3d, 0, npfOptions)
    call npfOptions%destroy()

    this%neq = this%dis%nodes
    this%nja = this%dis%nja
    this%ia  => this%dis%con%ia
    this%ja  => this%dis%con%ja

    call this%allocate_arrays()

  end subroutine defineModel

  subroutine allocateAndReadModel(this)
    class(GwfInterfaceModelType), target, intent(inout) :: this
    ! local
    type(GwfNpfGridDataType) :: npfGridData

    call npfGridData%construct(this%dis%nodes)
    call this%setNpfGridData(npfGridData)
    call this%npf%npf_ar(this%ic, this%ibound, this%x, npfGridData)
    call npfGridData%destroy()

  end subroutine allocateAndReadModel

  subroutine buildDiscretization(this)
    use ConnectionsModule
    use SparseModule, only: sparsematrix
    class(GwfInterfaceModelType), intent(inout) :: this
    ! local
    integer(I4B) :: icell, nrOfCells, idx
    type(NumericalModelType), pointer :: model
    class(DisBaseType), pointer :: disbase
    class(GwfDisuType), pointer :: disu
    real(DP) :: x,y

    ! create disu
    call disu_cr(this%dis, this%name, -1, this%iout)
    disbase => this%dis
    select type(disbase)
    type is(GwfDisuType)
      disu => disbase
    end select

    ! the following is similar to dis_df, we should refactor this
    ! set nodes, nvertices skipped for as long as possible
    nrOfCells = this%gridConnection%nrOfCells
    this%dis%nodes = nrOfCells
    this%dis%nodesuser = nrOfCells
    this%dis%nja = this%gridConnection%connections%nja

    call this%dis%allocate_arrays()
    ! these are otherwise allocated in dis%read_dimensions
    call disu%allocate_arrays_mem()

    ! fill data
    do icell = 1, nrOfCells
      idx = this%gridConnection%idxToGlobal(icell)%index
      model => this%gridConnection%idxToGlobal(icell)%model

      this%dis%top(icell) = model%dis%top(idx)
      this%dis%bot(icell) = model%dis%bot(idx)
      this%dis%area(icell) = model%dis%area(idx)
    end do

    ! grid connections follow from GridConnection:
    this%dis%con => this%gridConnection%connections
    this%dis%njas =  this%dis%con%njas

    ! copy cell x,y
    do icell = 1, nrOfCells
      idx = this%gridConnection%idxToGlobal(icell)%index
      model => this%gridConnection%idxToGlobal(icell)%model
      call model%dis%get_cellxy(idx, x, y)
      ! we need to have the origins in here explicitly since
      ! we are merging grids with possibly different origins
      ! TODO_MJR: how 'bout rotation?
      disu%cellxy(1,icell) = x + model%dis%xorigin
      disu%cellxy(2,icell) = y + model%dis%yorigin
    end do

    ! TODO_MJR:
    ! create or copy vertices, can we avoid it somehow???
    ! if not, it will look like this:
    !
    ! 1. determine total nr. of verts
    ! 2. allocate vertices list
    ! 3. create sparse
    ! 4. get vertex data per cell, add functions to base
    ! 5. add vertex (x,y) to list and connectivity to sparse
    ! 6. generate ia/ja from sparse

  end subroutine buildDiscretization

  subroutine deallocateModel(this)
  use MemoryManagerModule, only: mem_deallocate
    class(GwfInterfaceModelType) :: this

    ! -- Internal flow packages deallocate
    call this%dis%dis_da()
    call this%npf%npf_da()
    call this%xt3d%xt3d_da()
    !
    ! -- Internal package objects
    deallocate(this%dis)
    deallocate(this%npf)
    deallocate(this%xt3d)
    !
    ! -- Scalars
    call mem_deallocate(this%inic)
    call mem_deallocate(this%inoc)
    call mem_deallocate(this%inobs)
    call mem_deallocate(this%innpf)
    call mem_deallocate(this%inbuy)
    call mem_deallocate(this%insto)
    call mem_deallocate(this%incsub)
    call mem_deallocate(this%inmvr)
    call mem_deallocate(this%inhfb)
    call mem_deallocate(this%ingnc)
    call mem_deallocate(this%iss)
    call mem_deallocate(this%inewtonur)
    !
    ! -- NumericalModelType
    call this%NumericalModelType%model_da()

  end subroutine

  subroutine setNpfOptions(this, npfOptions)
    class(GwfInterfaceModelType) :: this
    type(GwfNpfOptionsType) :: npfOptions

    ! for now, assuming full homogeneity, so just take
    ! the options from the owning model's npf package
    npfOptions%icellavg = this%owner%npf%icellavg
    npfOptions%ithickstrt = this%owner%npf%ithickstrt
    npfOptions%iperched = this%owner%npf%iperched
    npfOptions%ivarcv = this%owner%npf%ivarcv
    npfOptions%idewatcv = this%owner%npf%idewatcv
    npfOptions%irewet = this%owner%npf%irewet
    npfOptions%wetfct = this%owner%npf%wetfct
    npfOptions%iwetit = this%owner%npf%iwetit
    npfOptions%ihdwet = this%owner%npf%ihdwet
    npfOptions%ixt3d = this%owner%npf%ixt3d

  end subroutine setNpfOptions

  !> @brief Loop over the interface grid and fill the structure
  !! with NPF grid data, copied from the models that participate
  !! in this interface
  !<
  subroutine setNpfGridData(this, npfGridData)
    class(GwfInterfaceModelType) :: this    !< the interface model
    type(GwfNpfGridDataType) :: npfGridData !< grid data to be set
    ! local
    integer(I4B) :: icell, idx
    class(*), pointer :: objPtr
    class(GwfModelType), pointer :: gwfModel

    ! TODO_MJR: deal with inhomogeneity, for now, we assume
    ! that we can just take the owning model's settings...
    npfGridData%ik22 = this%owner%npf%ik22
    npfGridData%ik33 =  this%owner%npf%ik33
    npfGridData%iwetdry = this%owner%npf%iwetdry
    npfGridData%iangle1 = this%owner%npf%iangle1
    npfGridData%iangle2 = this%owner%npf%iangle2
    npfGridData%iangle3 = this%owner%npf%iangle3

    do icell = 1, this%gridConnection%nrOfCells
      idx = this%gridConnection%idxToGlobal(icell)%index
      objPtr => this%gridConnection%idxToGlobal(icell)%model
      gwfModel => CastAsGwfModelClass(objPtr)

      npfGridData%icelltype(icell) = gwfModel%npf%icelltype(idx)
      npfGridData%k11(icell) = gwfModel%npf%k11(idx)
      if (npfGridData%ik22 == 1) npfGridData%k22(icell) = gwfModel%npf%k22(idx)
      if (npfGridData%ik33 == 1) npfGridData%k33(icell) = gwfModel%npf%k33(idx)
      if (npfGridData%iwetdry == 1) npfGridData%wetdry(icell) = gwfModel%npf%wetdry(idx)
      if (npfGridData%iangle1 == 1) npfGridData%angle1(icell) = gwfModel%npf%angle1(idx)
      if (npfGridData%iangle2 == 1) npfGridData%angle2(icell) = gwfModel%npf%angle2(idx)
      if (npfGridData%iangle3 == 1) npfGridData%angle3(icell) = gwfModel%npf%angle3(idx)

    end do

  end subroutine setNpfGridData

  function CastAsGwfModelClass(obj) result (res)
    implicit none
    class(*), pointer, intent(inout) :: obj
    class(GwfModelType), pointer :: res

    res => null()
    if (.not. associated(obj)) return

    select type (obj)
    class is (GwfModelType)
      res => obj
    end select
    return
  end function CastAsGwfModelClass

  function CastAsGwfInterfaceModelClass(obj) result (res)
    implicit none
    class(*), pointer, intent(inout) :: obj
    class(GwfInterfaceModelType), pointer :: res

    res => null()
    if (.not. associated(obj)) return

    select type (obj)
    class is (GwfInterfaceModelType)
      res => obj
    end select
    return
  end function CastAsGwfInterfaceModelClass

end module GwfInterfaceModelModule