! HND XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
! HND X
! HND X   TurboGAP
! HND X
! HND X   TurboGAP is copyright (c) 2019-2021, Miguel A. Caro and others
! HND X
! HND X   TurboGAP is published and distributed under the
! HND X      Academic Software License v1.0 (ASL)
! HND X
! HND X   This file, gap.f90, is copyright (c) 2019-2021, Miguel A. Caro
! HND X
! HND X   TurboGAP is distributed in the hope that it will be useful for non-commercial
! HND X   academic research, but WITHOUT ANY WARRANTY; without even the implied
! HND X   warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
! HND X   ASL for more details.
! HND X
! HND X   You should have received a copy of the ASL along with this program
! HND X   (e.g. in a LICENSE.md file); if not, you can write to the original
! HND X   licensor, Miguel Caro (mcaroba@gmail.com). The ASL is also published at
! HND X   http://github.com/gabor1/ASL
! HND X
! HND X   When using this software, please cite the following reference:
! HND X
! HND X   Miguel A. Caro. Phys. Rev. B 100, 024112 (2019)
! HND X
! HND XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

module gap

  use splines

  contains

  subroutine get_soap_energy_and_forces(soap, soap_der, alphas, delta, zeta0, e0, Qs, &
                                        n_neigh, neighbors_list, xyz, do_forces, do_timing, &
                                        energies, forces, virial)
!   **********************************************
!   soap(1:n_soap, 1:n_sites)

    implicit none

    real*8, intent(in) :: soap(:,:), soap_der(:,:,:), alphas(:), delta, Qs(:,:), e0, zeta0, xyz(:,:)
    real*8, intent(out) :: energies(:), forces(:,:), virial(1:3,1:3)
    integer, intent(in) :: n_neigh(:), neighbors_list(:)
    logical, intent(in) :: do_forces, do_timing
    real*8, allocatable :: kernels(:,:), kernels_der(:,:), Qss(:,:), Qs_copy(:,:), this_Qss(:), &
                           kernels_copy(:,:)
    real*8 :: time1, time2, time3, energies_time, forces_time, zeta, this_force(1:3)
    integer :: n_sites, n_sparse, n_soap, i, j, k, l, j2, zeta_int, n_sites0, k1, k2
    logical :: is_zeta_int = .false.
!    integer, allocatable :: neighbors_beg(:), neighbors_end(:)

    if( dabs(zeta0-dfloat(int(zeta0))) < 1.d-5 )then
      is_zeta_int = .true.
      zeta_int = int(zeta0)
      zeta = dfloat(zeta_int)
    else
      zeta = zeta0
    end if

!   Energies
    if( do_timing )then
      call cpu_time(time1)
      time3 = time1
    end if
    n_sparse = size(alphas)
    n_soap = size(soap, 1)
    n_sites = size(soap, 2)
    n_sites0 = size(forces, 2)

    allocate( kernels(1:n_sites, 1:n_sparse) )
    kernels = 0.d0
    allocate( kernels_copy(1:n_sites, 1:n_sparse) )
    call dgemm( "t", "n", n_sites, n_sparse, n_soap, 1.d0, soap, n_soap, Qs, n_soap, 0.d0, &
              kernels, n_sites)
!   We copy the kernels because it makes the matmul() operation (WHICH SHOULD BY THE WAY BE WRITTEN
!   USING LAPACK ROUTINES) a lot faster
    if( is_zeta_int )then
      kernels_copy = kernels**zeta_int
      energies = matmul(kernels_copy, alphas)
    else
      kernels_copy = kernels**zeta
      energies = matmul(kernels_copy, alphas)
    end if
    energies = delta**2 * energies + e0
    if( do_timing )then
      call cpu_time(time2)
      energies_time = time2 - time1
    end if

!   Forces
    if( do_forces )then
      if( do_timing )then
        call cpu_time(time1)
      end if
      allocate( kernels_der(1:n_sites, 1:n_sparse) )
      allocate( Qss(1:n_sites, 1:n_soap) )
      Qss = 0.d0
      allocate( Qs_copy(1:n_soap, 1:n_sparse) )
      allocate(this_Qss(1:n_soap))

      Qs_copy = Qs

      if( is_zeta_int )then
        kernels_der = kernels**(zeta_int-1)
      else
        kernels_der = kernels**(zeta-1.d0)
      end if
      if( n_sites < n_soap )then
        do i = 1, n_sites
          kernels_der(i,:) = kernels_der(i,:)*alphas(:)
        end do
      else
        do i = 1, n_soap
          Qs_copy(i,:) = Qs(i,:)*alphas(:)
        end do
      end if

      call dgemm("n", "t", n_sites, n_soap, n_sparse, -zeta*delta**2, kernels_der, n_sites, &
                 Qs_copy, n_soap, 0.d0, Qss, n_sites)

! EXPERIMENTAL CODE
!      call cpu_time(time1)
!      allocate( neighbors_beg(1:n_sites) )
!      allocate( neighbors_end(1:n_sites) )
!      l = 0
!      do i = 1, n_sites
!        neighbors_beg(i) = l + 1
!        do j = 1, n_neigh(i)
!          l = l + 1
!        end do
!        neighbors_end(i) = l
!      end do
! END EXPERIMENTAL CODE

      virial = 0.d0
      forces = 0.d0
!!$OMP parallel do private(i,j,l,j2,this_Qss)
      l = 0
      do i = 1, n_sites
        this_Qss = Qss(i,1:n_soap)
        do j = 1, n_neigh(i)
          l = l + 1
!         do l = neighbors_beg(i), neighbors_end(i)
          j2 = mod(neighbors_list(l)-1, n_sites0) + 1
          do k = 1, 3
            this_force(k) = dot_product(this_Qss, soap_der(k,:,l))
            forces(k, j2) = forces(k, j2) + this_force(k)
          end do
!         This is a many body potential, so there's no factor of 1/2 here
!          virial = virial + dot_product( this_force(1:3), xyz(1:3,l) )
          do k1 = 1, 3
            do k2 =1, 3
              virial(k1, k2) = virial(k1, k2) + 0.5d0 * (this_force(k1)*xyz(k2,l) + this_force(k2)*xyz(k1,l))
            end do
          end do
        end do
      end do
!!$OMP end parallel do

! EXPERIMENTAL CODE
!      deallocate( neighbors_beg, neighbors_end )
!      call cpu_time(time2)
!      write(*,*) time2-time1
! END EXPERIMENTAL CODE

      if( do_timing )then
        call cpu_time(time2)
        forces_time = time2 - time1
      end if
    end if

!   Wrap it up
    deallocate(kernels, kernels_copy)
    if( do_forces )then
      deallocate(kernels_der, Qs_copy, Qss, this_Qss)
    end if

    if( do_timing )then
      call cpu_time(time2)
      write(*,*)'                                       |'
      write(*,*)'Prediction timings (SOAP):             |'
      write(*,*)'                                       |'
      write(*,'(A, F7.3, A)') '  *) Energy prediction: ', energies_time, ' seconds |'
      if( do_forces )then
        write(*,'(A, F7.3, A)') '  *) Forces prediction: ', forces_time, ' seconds |'
      end if
      write(*,'(A, F8.3, A)') '  *) Total prediction: ', time2-time3, ' seconds |'
      write(*,*)'                                       |'
      write(*,*)'.......................................|'
    end if

  end subroutine

  subroutine get_2b_energy_and_forces(rjs, xyz, alphas, cutoff, rcut, buffer, delta, sigma, e0, Qs, &
                                      n_neigh, do_forces, do_timing, species, neighbor_species, &
                                      species1, species2, species_types, energies, forces, virial )

    implicit none

!   Input variables
    real*8, intent(in) :: rjs(:), xyz(:,:), alphas(:), cutoff(:), delta, sigma, e0, Qs(:), rcut, buffer
    integer, intent(in) :: n_neigh(:), species(:), neighbor_species(:)
    character*8, intent(in) :: species_types(:), species1, species2
    logical, intent(in) :: do_forces, do_timing

!   Output variables
    real*8, intent(out) :: energies(:), forces(:,:), virial(1:3,1:3)

!   Internal variables
    real*8 :: time1, time2, fcut, pi, dfcut, this_force(1:3)
    integer :: n_sparse, i, j, k, n_sites, n_atom_pairs, s, sp1, sp2, n_sites0, k1, k2

    if( do_timing )then
      call cpu_time(time1)
    end if

    pi = dacos(-1.d0)

    n_sparse = size(alphas)
    n_sites = size(n_neigh)
    n_atom_pairs = size(rjs)
    n_sites0 = size(forces, 2)

!   Map species to index
    do i = 1, size(species_types)
      if( species1 == species_types(i) )then
        sp1 = i
        exit
      end if
    end do
    do i = 1, size(species_types)
      if( species2 == species_types(i) )then
        sp2 = i
        exit
      end if
    end do

!   Energy calculation
    energies = e0
    k = 0
    do i = 1, n_sites
      if( species(i) /= sp1 .and. species(i) /= sp2 )then
        k = k + n_neigh(i)
        cycle
      end if
      k = k + 1
      do j = 2, n_neigh(i)
        k = k + 1
        if( (species(i) == sp1 .and. neighbor_species(k) == sp2) .or. &
            (species(i) == sp2 .and. neighbor_species(k) == sp1) )then
          continue
        else
          cycle
        end if
        if( rjs(k) < rcut )then
          if( rjs(k) < rcut - buffer )then
            fcut = 1.d0
          else
            fcut = ( dcos( pi*(rjs(k) - rcut + buffer) / buffer ) + 1.d0 ) / 2.d0
          end if
          do s = 1, n_sparse
            energies(i) = energies(i) + delta**2 * alphas(s) * cutoff(s) * fcut * &
                          dexp(-0.5d0 * (rjs(k) - Qs(s))**2 / sigma**2)
          end do
        end if
      end do
    end do

!   Force calculation
    if( do_forces )then
      forces = 0.d0
      virial = 0.d0
      k = 0
      do i = 1, n_sites
        if( species(i) /= sp1 .and. species(i) /= sp2 )then
          k = k + n_neigh(i)
          cycle
        end if
        k = k + 1
        do j = 2, n_neigh(i)
          k = k + 1
          if( (species(i) == sp1 .and. neighbor_species(k) == sp2) .or. &
              (species(i) == sp2 .and. neighbor_species(k) == sp1) )then
            continue
          else
            cycle
          end if
          if( rjs(k) < rcut )then
            if( rjs(k) < rcut - buffer )then
              fcut = 1.d0
              dfcut = 0.d0
            else
              fcut = ( dcos( pi*(rjs(k) - rcut + buffer) / buffer ) + 1.d0 ) / 2.d0
              dfcut = pi / 2.d0 / buffer * dsin( pi*(rjs(k) - rcut + buffer) / buffer )
            end if
            do s = 1, n_sparse
              this_force(1:3) = - 2.d0 * delta**2 * alphas(s) * cutoff(s) * &
                              dexp(-0.5d0 * (rjs(k) - Qs(s))**2 / sigma**2) * &
                              xyz(1:3, k) / rjs(k) * ( (rjs(k) - Qs(s)) / sigma**2 * fcut + dfcut )
              forces(1:3,i) = forces(1:3,i) + this_force(1:3)
!              virial = virial - dot_product( this_force(1:3), xyz(1:3,k) )
              do k1 = 1, 3
                do k2 =1, 3
                  virial(k1, k2) = virial(k1, k2) - 0.5d0 * (this_force(k1)*xyz(k2,k) + this_force(k2)*xyz(k1,k))
                end do
              end do
            end do
          end if
        end do
      end do
!     Half contribution to the virial for pair potentials
      virial = 0.5d0 * virial
    end if

    if( do_timing )then
      call cpu_time(time2)
      write(*,*)'                                       |'
      write(*,*)'Prediction timings (2b):               |'
      write(*,*)'                                       |'
      write(*,'(A, F8.3, A)') '  *) Total prediction: ', time2-time1, ' seconds |'
      write(*,*)'                                       |'
      write(*,*)'.......................................|'
    end if

  end subroutine

  subroutine get_core_pot_energy_and_forces(rjs, xyz, x, V, yp1, ypn, dVdx2, n_neigh, do_forces, do_timing, species, &
                                            neighbor_species, species1, species2, species_types, energies, forces, &
                                            virial )

    implicit none

!   Input variables
    real*8, intent(in) :: rjs(:), xyz(:,:), x(:), V(:), yp1, ypn, dVdx2(:)
    integer, intent(in) :: n_neigh(:), species(:), neighbor_species(:)
    character*8, intent(in) :: species_types(:), species1, species2
    logical, intent(in) :: do_forces, do_timing

!   Output variables
    real*8, intent(out) :: energies(:), forces(:,:), virial(1:3,1:3)

!   Internal variables
!   There are two ways of doing the core_pot interpolation; most efficient probably depends on
!   whether a small subset or big subset of the total number of atom pairs has a core potential
!   term associated to it. The current implementation is fast going over pairs, but slow computing
!   the splines. This will give the best performance for systems with many atom types
    real*8 :: V_int(1:1), dV_int(1:1), this_force(1:3)
!    real*8, allocatable :: V_int(:), dV_int(:)
    real*8 :: time1, time2, rcut
    integer :: n_sparse, i, j, k, n_sites, n_atom_pairs, s, sp1, sp2, n_sites0, k1, k2

    if( do_timing )then
      call cpu_time(time1)
    end if

    n_sparse = size(x)
    n_sites = size(n_neigh)
    n_atom_pairs = size(rjs)
    n_sites0 = size(forces, 2)

    rcut = maxval(x)

!   Whether we do arrays or not depends on use case. Maybe we can improve the code in the future
!   to make some choices leading to faster execution (i.e., figure out when it pays off to use
!   arrays, or use masks and index assignments to avoid unecessary computations with arrays)
!    allocate( V_int(1:n_atom_pairs) )
!    if( do_forces )then
!      allocate( dV_int(1:n_atom_pairs) )
!    end if

!   Map species to index
    do i = 1, size(species_types)
      if( species1 == species_types(i) )then
        sp1 = i
        exit
      end if
    end do
    do i = 1, size(species_types)
      if( species2 == species_types(i) )then
        sp2 = i
        exit
      end if
    end do

!   Energy calculation
    energies = 0.d0
    k = 0
    do i = 1, n_sites
      if( species(i) /= sp1 .and. species(i) /= sp2 )then
        k = k + n_neigh(i)
        cycle
      end if
      k = k + 1
      do j = 2, n_neigh(i)
        k = k + 1
        if( (species(i) == sp1 .and. neighbor_species(k) == sp2) .or. &
            (species(i) == sp2 .and. neighbor_species(k) == sp1) )then
          continue
        else
          cycle
        end if
        if( rjs(k) < rcut )then
          V_int = spline(x, V, dVdx2, yp1, ypn, rjs(k:k), rcut)
          energies(i) = energies(i) + 0.5d0 * V_int(1)
        end if
      end do
    end do

!   Force calculation
    if( do_forces )then
      forces = 0.d0
      virial = 0.d0
      k = 0
      do i = 1, n_sites
        if( species(i) /= sp1 .and. species(i) /= sp2 )then
          k = k + n_neigh(i)
          cycle
        end if
        k = k + 1
        do j = 2, n_neigh(i)
          k = k + 1
          if( (species(i) == sp1 .and. neighbor_species(k) == sp2) .or. &
              (species(i) == sp2 .and. neighbor_species(k) == sp1) )then
            continue
          else
            cycle
          end if
          if( rjs(k) < rcut )then
            dV_int = spline_der(x, V, dVdx2, yp1, ypn, rjs(k:k), rcut)
            this_force(1:3) = dV_int(1) * xyz(1:3, k) / rjs(k)
            forces(1:3,i) = forces(1:3,i) + this_force(1:3)
!            virial = virial - dot_product( this_force(1:3), xyz(1:3, k) )
            do k1 = 1, 3
              do k2 =1, 3
                virial(k1, k2) = virial(k1, k2) - 0.5d0 * (this_force(k1)*xyz(k2,k) + this_force(k2)*xyz(k1,k))
              end do
            end do
          end if
        end do
      end do
!     Half contribution to the virial for pair potentials
      virial = 0.5d0 * virial
    end if

    if( do_timing )then
      call cpu_time(time2)
      write(*,*)'                                       |'
      write(*,*)'Prediction timings (core_pot):         |'
      write(*,*)'                                       |'
      write(*,'(A, F8.3, A)') '  *) Total prediction: ', time2-time1, ' seconds |'
      write(*,*)'                                       |'
      write(*,*)'.......................................|'
    end if

  end subroutine

!**************************************************************************
  subroutine get_3b_energy_and_forces( rjs, xyz, alphas, cutoff, rcut, buffer, delta, sigma, e0, Qs, &
                                       n_neigh, neighbors_list, do_forces, do_timing, kernel_type, &
                                       species, neighbor_species, species_center, species1, species2, &
                                       species_types, energies, forces, virial )

    implicit none

!   Input variables
    real*8, intent(in) :: rjs(:), xyz(:,:), alphas(:), cutoff(:), rcut, buffer, delta, sigma(:), e0, Qs(:,:)
    integer, intent(in) :: n_neigh(:), neighbors_list(:), species(:), neighbor_species(:)
    logical, intent(in) :: do_timing, do_forces
    character*3, intent(in) :: kernel_type
    character*8, intent(in) :: species_center, species1, species2, species_types(:)

!   Output variables
    real*8, intent(out) :: energies(:), forces(:,:), virial(1:3,1:3)

!   Internal variables
    real*8 :: time1, time2, fcut, pi, r12, r13, r23, xyz12(1:3), xyz13(1:3), &
              xyz23(1:3), q(1:3), fcut12, fcut13, dfcut12(1:3), dfcut13(1:3), &
              force1(1:3), force2(1:3), force3(1:3), dfcut(1:3), &
              xyz12_red(1:3), xyz13_red(1:3), xyz23_red(1:3), this_force(1:3)
    real*8, allocatable :: r(:), drdq(:,:), kernel(:), drdx1(:,:), drdx2(:,:), drdx3(:,:), pref(:), &
                           kernel_der(:)
    integer :: n_sparse, i, j, k, k2, n_sites, n_atom_pairs, s, j2, i3, j3, k3, l, sp0, sp1, sp2, n_sites0, k1, k4

    if( do_timing )then
      call cpu_time(time1)
    end if

    pi = dacos(-1.d0)

    n_sparse = size(alphas)
    n_sites = size(n_neigh)
    n_atom_pairs = size(rjs)
    n_sites0 = size(forces, 2)

!   Map species to index
    do i = 1, size(species_types)
      if( species_center == species_types(i) )then
        sp0 = i
        exit
      end if
    end do
    do i = 1, size(species_types)
      if( species1 == species_types(i) )then
        sp1 = i
        exit
      end if
    end do
    do i = 1, size(species_types)
      if( species2 == species_types(i) )then
        sp2 = i
        exit
      end if
    end do

    allocate( r(1:n_sparse) )
    allocate( kernel(1:n_sparse) )
    allocate( pref(1:n_sparse) )
    if( do_forces )then
      allocate( drdq(1:n_sparse, 1:3) )
      allocate( drdx1(1:n_sparse, 1:3) )
      allocate( drdx2(1:n_sparse, 1:3) )
      allocate( drdx3(1:n_sparse, 1:3) )
      if( kernel_type == "pol" )then
        allocate( kernel_der(1:n_sparse) )
      end if
    end if

!   NOTE: these loops can be made between 2 and 3 times faster by summing over triplets instead of
!   over sites, however it may be a better strategy with parallelization in mind to sum over sites
!   (or maybe not...)

    pref(1:n_sparse) = 2.d0 * delta**2 * alphas(1:n_sparse) * cutoff(1:n_sparse)

!   Energy and force calculation
    energies = e0
    if( do_forces )then
      forces = 0.d0
      virial = 0.d0
    end if
    k = 0
    do i = 1, n_sites
      if( species(i) /= sp0 )then
        k = k + n_neigh(i)
        cycle
      end if
      k = k + 1
!      i3 = neighbors_list(k)
      i3 = mod(neighbors_list(k)-1, n_sites0) + 1
      do j = 2, n_neigh(i)
        k = k + 1
        r12 = rjs(k)
        if( (neighbor_species(k) /= sp1 .and. neighbor_species(k) /= sp2) .or. r12 > rcut )then
          cycle
        end if
!        j3 = neighbors_list(k)
        j3 = mod(neighbors_list(k)-1, n_sites0) + 1
        xyz12 = xyz(1:3, k)
        xyz12_red = xyz12 / r12
        k2 = k
        do j2 = j+1, n_neigh(i)
          k2 = k2 + 1
          r13 = rjs(k2)
          if( ( (neighbor_species(k) == sp1 .and. neighbor_species(k2) == sp2) .or. &
              (neighbor_species(k) == sp2 .and. neighbor_species(k2) == sp1) ) .and. r13 < rcut )then
            continue
          else
            cycle
          end if
!          k3 = neighbors_list(k2)
          k3 = mod(neighbors_list(k2)-1, n_sites0) + 1
          xyz13 = xyz(1:3, k2)
          xyz13_red = xyz13 / r13
          xyz23 = xyz13 - xyz12
          r23 = dsqrt(sum(xyz23**2))
          xyz23_red = xyz23 / r23
!         It would be nice that if r23 < rcut, we only evaluate the expression if k3 > i3 and j3 > i3,
!         however that gets messy because the cutoff functions are not the same for each of the 3
!         evaluations of the triplet, i.e., atom 1 sees two cutoff functions, atom 2 sees two *different*
!         cutoff functions and 3 sees another 2 differetn cutoff functions. I actually tried and it
!         reduced the calculation time by about 40% for the large random C system with a 3 Angstrom cutoff
          if( r12 < rcut .and. r13 < rcut )then
            if( r12 < rcut - buffer )then
              fcut12 = 1.d0
              dfcut12(1:3) = 0.d0
            else
              fcut12 = ( dcos( pi*(r12 - rcut + buffer) / buffer ) + 1.d0 ) / 2.d0
              dfcut12(1:3) = dsin( pi*(r12 - rcut + buffer) / buffer ) / 2.d0 * pi / buffer * xyz12_red(1:3)
            end if
            if( r13 < rcut - buffer )then
              fcut13 = 1.d0
              dfcut13(1:3) = 0.d0
            else
              fcut13 = ( dcos( pi*(r13 - rcut + buffer) / buffer ) + 1.d0 ) / 2.d0
              dfcut13(1:3) = dsin( pi*(r13 - rcut + buffer) / buffer ) / 2.d0 * pi / buffer * xyz13_red(1:3)
            end if
            fcut = fcut12 * fcut13
            dfcut(1:3) = fcut12 * dfcut13(1:3) + fcut13 * dfcut12(1:3)
!           This builds the actual descriptor
            q = [ r12+r13, (r12-r13)**2, r23 ]
!           This gets the Euclidean distance between q and all the qs
            r(1:n_sparse) = (q(1) - Qs(1:n_sparse, 1))**2 / sigma(1)**2
            r(1:n_sparse) = r(1:n_sparse) + (q(2) - Qs(1:n_sparse, 2))**2 / sigma(2)**2
            r(1:n_sparse) = r(1:n_sparse) + (q(3) - Qs(1:n_sparse, 3))**2 / sigma(3)**2
            r(1:n_sparse) = dsqrt(r(1:n_sparse))
!           This gets the derivatives of the distances wrt the descriptors (the 1/r factor is not included)
            if( do_forces )then
              drdq(1:n_sparse, 1) = (q(1) - Qs(1:n_sparse, 1)) / sigma(1)**2
              drdq(1:n_sparse, 2) = (q(2) - Qs(1:n_sparse, 2)) / sigma(2)**2
              drdq(1:n_sparse, 3) = (q(3) - Qs(1:n_sparse, 3)) / sigma(3)**2
            end if
!           Evaluate the kernels
            if( kernel_type == "exp" )then
!             This kernel already contains the prefactor
              kernel(1:n_sparse) = pref(1:n_sparse) * dexp(-0.5d0 * r(1:n_sparse)**2)
              energies(i) = energies(i) + fcut * sum( kernel(1:n_sparse) )
              if( do_forces )then
                force1 = 0.d0
                force2 = 0.d0
                force3 = 0.d0
                do l = 1, 3
!                 For atom 1
                  drdx1(1:n_sparse, l) = drdq(1:n_sparse, 1) * ( xyz12_red(l) + xyz13_red(l) ) &
                                         + drdq(1:n_sparse, 2) * 2.d0 * (r12-r13) * ( xyz12_red(l) - xyz13_red(l) )
!                 For atom 2
                  drdx2(1:n_sparse, l) = - drdq(1:n_sparse, 1) * xyz12_red(l) &
                                         - drdq(1:n_sparse, 2) * 2.d0 * (r12-r13) * xyz12_red(l) &
                                         + drdq(1:n_sparse, 3) * xyz23_red(l)
!                 For atom 3
                  drdx3(1:n_sparse, l) = - drdq(1:n_sparse, 1) * xyz13_red(l) &
                                         - drdq(1:n_sparse, 2) * 2.d0 * (r13-r12) * xyz13_red(l) &
                                         - drdq(1:n_sparse, 3) * xyz23_red(l)
                  force1(l) = - sum( kernel(1:n_sparse) * (dfcut(l) + fcut*drdx1(1:n_sparse, l)) )
                  force2(l) = - sum( kernel(1:n_sparse) * (-fcut13 * dfcut12(l) + fcut*drdx2(1:n_sparse, l)) )
                  force3(l) = - sum( kernel(1:n_sparse) * (-fcut12 * dfcut13(l) + fcut*drdx3(1:n_sparse, l)) )
                end do
                forces(1:3, i3) = forces(1:3, i3) + force1(1:3)
                forces(1:3, j3) = forces(1:3, j3) + force2(1:3)
                forces(1:3, k3) = forces(1:3, k3) + force3(1:3)
!               force1 acting on i3 does not contribute to the virial
!                virial = virial + dot_product( force2(1:3), xyz12(1:3) )
!                virial = virial + dot_product( force3(1:3), xyz13(1:3) )
                do k1 = 1, 3
                  do k4 =1, 3
                    virial(k1, k4) = virial(k1, k4) + 0.5d0 * (force2(k1)*xyz12(k4) + force2(k4)*xyz12(k1))
                    virial(k1, k4) = virial(k1, k4) + 0.5d0 * (force3(k1)*xyz13(k4) + force3(k4)*xyz13(k1))
                  end do
                end do
              end if
            else if( kernel_type == "pol" )then
!             This kernel already contains the prefactor
              kernel(1:n_sparse) = pref(1:n_sparse) * cov_pp(r(1:n_sparse), 3, 1)
              energies(i) = energies(i) + fcut * sum( kernel(1:n_sparse) )
              if( do_forces )then
                force1 = 0.d0
                force2 = 0.d0
                force3 = 0.d0
!               This derivative contains the 1/r term
                kernel_der(1:n_sparse) = pref(1:n_sparse) * cov_pp_der(r(1:n_sparse), 3, 1)
                do l = 1, 3
!                 For atom 1
                  drdx1(1:n_sparse, l) = drdq(1:n_sparse, 1) * ( xyz12_red(l) + xyz13_red(l) ) &
                                         + drdq(1:n_sparse, 2) * 2.d0 * (r12-r13) * ( xyz12_red(l) - xyz13_red(l) )
!                 For atom 2
                  drdx2(1:n_sparse, l) = - drdq(1:n_sparse, 1) * xyz12_red(l) &
                                         - drdq(1:n_sparse, 2) * 2.d0 * (r12-r13) * xyz12_red(l) &
                                         + drdq(1:n_sparse, 3) * xyz23_red(l)
!                 For atom 3
                  drdx3(1:n_sparse, l) = - drdq(1:n_sparse, 1) * xyz13_red(l) &
                                         - drdq(1:n_sparse, 2) * 2.d0 * (r13-r12) * xyz13_red(l) &
                                         - drdq(1:n_sparse, 3) * xyz23_red(l)
                  force1(l) = - sum( kernel(1:n_sparse) * dfcut(l) &
                                     - kernel_der(1:n_sparse) * fcut*drdx1(1:n_sparse, l) )
                  force2(l) = - sum( - kernel(1:n_sparse) * fcut13 * dfcut12(l) &
                                     - kernel_der(1:n_sparse) * fcut*drdx2(1:n_sparse, l) )
                  force3(l) = - sum( - kernel(1:n_sparse) * fcut12 * dfcut13(l) &
                                     - kernel_der(1:n_sparse) * fcut*drdx3(1:n_sparse, l) )
                end do
                forces(1:3, i3) = forces(1:3, i3) + force1(1:3)
                forces(1:3, j3) = forces(1:3, j3) + force2(1:3)
                forces(1:3, k3) = forces(1:3, k3) + force3(1:3)
!               force1 acting on i3 does not contribute to the virial
!                virial = virial + dot_product( force2(1:3), xyz12(1:3) )
!                virial = virial + dot_product( force3(1:3), xyz13(1:3) )
                do k1 = 1, 3
                  do k4 =1, 3
                    virial(k1, k4) = virial(k1, k4) + 0.5d0 * (force2(k1)*xyz12(k4) + force2(k4)*xyz12(k1))
                    virial(k1, k4) = virial(k1, k4) + 0.5d0 * (force3(k1)*xyz13(k4) + force3(k4)*xyz13(k1))
                 end do
               end do
              end if
            end if
          end if
        end do
      end do
    end do

    deallocate( kernel, pref, r )
    if( do_forces )then
      deallocate( drdq, drdx1, drdx2, drdx3 )
      if( kernel_type == "pol" )then
        deallocate( kernel_der )
      end if
    end if

    if( do_timing )then
      call cpu_time(time2)
      write(*,*)'                                       |'
      write(*,*)'Prediction timings (3b):               |'
      write(*,*)'                                       |'
      write(*,'(A, F8.3, A)') '  *) Total prediction: ', time2-time1, ' seconds |'
      write(*,*)'                                       |'
      write(*,*)'.......................................|'
    end if

  end subroutine
!**************************************************************************

!**************************************************************************
!
! This is two functions
!
  function cov_pp(r, d, q) result(cov)

    implicit none

    real*8, intent(in) :: r(:)
    integer, intent(in) :: d, q
    real*8, dimension(1:size(r)) :: cov

    real*8 :: j
    integer :: j_int, i

    j_int = d/2 + q + 1
    j = dfloat(j_int)

    if( d == 3 .and. q == 1 )then
      do i = 1, size(r)
        if( r(i) >= 1.d0 )then
          cov(i) = 0.d0
        else if( r(i) <= 0.d0 )then
          cov(i) = 1.d0
        else
          cov(i) = (1.d0 - r(i))**(j_int+1) * ((j+1.d0)*r(i) + 1.d0)
        end if
      end do
    else
      write(*,*) "ERROR: This combination of input parameters is not currently supported for cov_pp!"
      stop
    end if

  end function
  function cov_pp_der(r, d, q) result(cov_der)

    implicit none

    real*8, intent(in) :: r(:)
    integer, intent(in) :: d, q
    real*8, dimension(1:size(r)) :: cov_der

    real*8 :: j
    integer :: j_int, i

    j_int = d/2 + q + 1
    j = dfloat(j_int)

    if( d == 3 .and. q == 1 )then
      do i = 1, size(r)
        if( r(i) >= 1.d0 .or. r(i) <= 0.d0)then
          cov_der(i) = 0.d0
        else
!         This expression contains the 1/r factor
          cov_der(i) = ( -(j+1.d0) * (1.d0 - r(i))**j_int * ((j+1.d0)*r(i) + 1.d0) + &
                         (1.d0 - r(i))**(j_int+1) * (j + 1.d0) ) / r(i)
        end if
      end do
    else
      write(*,*) "ERROR: This combination of input parameters is not currently supported for cov_pp!"
      stop
    end if

  end function
!**************************************************************************

end module gap


      integer function pvCcache(p1sq,p2sq,p3sq,m1s,m2s,m3s)
      implicit none
      include 'pvCnames.f'
      include 'TRclear.f'
      include 'TRonshellcutoff.f'
      include 'pvRespectmaxcindex.f'
      include 'pvforcerecalc.f'
      include 'pvCitry.f'
      double precision para(Pcc),p1sq,p2sq,p3sq,m1s,m2s,m3s
      integer j,jtable,Ntrue
      logical,save::maxcindexrespected(Ncmax)
      double precision,save:: tableC(Pcc,Ncmax)
      integer,save:: Nstore=0
!$omp threadprivate(tableC,Nstore,maxcindexrespected)

C--set the number of stored values to zero
      if (clear(3)) then
      clear(3)=.false.
      Nstore=0
      endif
      if (Nstore .ge. Ncmax) then
      print *
      print *, 'pvCcache:Nstore .ge. Ncmax'
      print *, 'pvCcache:Nstore,Ncmax',Nstore,Ncmax
      print *, 'Either adjust Ncmax in Cnames.f and recompile'
      print *, 'or call clearcache to clear the cache.'
      stop
      endif
      para(1)=p1sq
      para(2)=p2sq
      para(3)=p3sq
      para(4)=m1s
      para(5)=m2s
      para(6)=m3s
C if parameter set is found, set pvCcache equal to the starting
C value
      if (Nstore .eq. 0) go to 20
      do jtable=1,Nstore
      Ntrue=0
        do j=1,Pcc
        if (abs(para(j)-tableC(j,jtable)) .lt. 1d-8) Ntrue=Ntrue+1
        enddo
        if (Ntrue .eq. Pcc) then
          pvCcache=(jtable-1)*Ncc
          if    (((maxcindexrespected(jtable) .eqv. .true.)
     &     .and. (pvRespectmaxCindex .eqv. .false.))
     &           .or. (pvforcerecalc)) then
c--- although integral is cached, ranks higher than those
c--- set by pvmaxcindex are required so recalculate
            call pvCfill(p1sq,p2sq,p3sq,m1s,m2s,m3s,pvCcache)
            maxcindexrespected(jtable)=.false.
          endif
          return
        endif
      enddo

C    if parameter set is not found, the values are
C    not in the cache, so we have to calculate them
C    and put them in the cache starting at pvCcache
 20   pvCcache=Nstore*Ncc
      pvCitry(pvCcache)=-1 ! label tensor as unchecked
      Nstore=Nstore+1
      do j=1,Pcc
        if(abs(para(j)) .lt. onshellcutoff) para(j)=0d0
      enddo
      do j=1,Pcc
      tableC(j,Nstore)=para(j)
      enddo
c      call pvCfill(p1sq,p2sq,p3sq,m1s,m2s,m3s,pvCcache)
      call pvCfill(para(1),para(2),para(3),para(4),para(5),para(6),
     &             pvCcache)
      maxcindexrespected(Nstore)=pvRespectmaxcindex
      return
      end


MODULE common_oceanmodel
!=======================================================================
!
! [PURPOSE:] Common Information for HYCOM
!
! [HISTORY:]
!   10/15/2004 Takemasa Miyoshi  created
!   01/23/2009 Takemasa Miyoshi  modified
!   04/26/2011 Steve Penny, converted to OCEAN for use with MOM4
!   01/18/2015 Steve Penny converted for use with MOM6
!   06/08/2015 Steve Penny converted for use with HYCOM
!
!=======================================================================
  USE common
  USE params_model, ONLY: nlon, nlat, nlev, nv3d, nv2d
  USE params_letkf, ONLY: DO_ALTIMETRY, DO_DRIFTERS, DO_SLA
  USE vars_model,   ONLY: lon, lat, lev, lon2d, lat2d, lon0, lonf, lat0, latf, wrapgap, dx, dy, kmt, kmt0, phi0
  USE vars_model,   ONLY: pmsk,umsk,vmsk
  USE hycom_io,     ONLY: read_blkdat
  USE hycom_io,     ONLY: get_hycom_depth,get_hycom_sample
  USE params_model, ONLY: SSHclm_file
  USE vars_model,   ONLY: SSHclm_m

  IMPLICIT NONE

  PUBLIC :: set_common_oceanmodel, read_diag, read_restart, write_restart
  PUBLIC :: read_grd, write_grd
  PUBLIC :: ensmean_grd

  PRIVATE

CONTAINS

SUBROUTINE set_common_oceanmodel
!===============================================================================
! Initialize the module
!===============================================================================
  USE netcdf
  USE params_model, ONLY: gridfile, gridfile1, gridfile2, gridfile3, ncundef
  USE vars_model,   ONLY: area_t
  USE vars_model,   ONLY: fcori, fcori2d
  !USE vars_model,   ONLY: pmsk, umsk, vmsk
  USE params_model, ONLY: initialize_params_model
  USE vars_model,   ONLY: initialize_vars_model

  IMPLICIT NONE

  INTEGER :: i,j,k
  INTEGER :: ncid,ncid2,ncid3,istat,varid,dimid
  LOGICAL :: ex

  ! For temporary dx and dy computations:
  REAL(r_size) :: dlon, dlat, d1, d2, d3

  REAL(r_size),SAVE :: sample_t(nlon,nlat,nlev)      !(OCEAN)(HYCOM)
  REAL(r_sngl),ALLOCATABLE :: sigma(:)               !(HYCOM) reference density levels, will be assigned to lev()

  ! For debugging:
  LOGICAL :: dodebug = .true.

  WRITE(6,'(A)') 'Hello from set_common_oceanmodel'
  CALL initialize_params_model ! (checks to make sure it is initialized)
  CALL initialize_vars_model   ! (checks to make sure it is initialized)

  !STEVE: needed to index the observations, because HYCOM does not have a regular grid above 45ºN
  !       Instead, HYCOM has a 2D-field for the representation of the lon/lat coordinate.
  !       This requires an update to the lon and lat arrays to lon2d and lat2d, with subsequent
  !       updates in letkf_local.f90 and letkf_obs.f90. These are primarily used to sort and store
  !       observation locations for later lookup at the localization phase.

  !
  ! Lon, Lat, f, orography
  !
!STEVE: this part adapted from ROMS, update for MOM4 (and later MOM6) netcdf files:
!STEVE: GOAL: to utilize all netcdf grid data to completely define the grid and all grid-dependent operations
  INQUIRE(FILE=trim("regional.grid.a"),EXIST=ex)
  IF(.not. ex) THEN
    WRITE(6,*) "The file does not exist: ", "regional.grid.a"
    WRITE(6,*) "Exiting common_hycom.f90..."
    STOP(2)
  ENDIF
  call get_hycom_depth(phi0,lat2d,lon2d,dx,dy)
  WRITE(6,'(A)') '  >> accessing file: ', "regional.grid.a"
  WRITE(6,*) "lon2d(1,1) = ", lon2d(1,1)
  WRITE(6,*) "lon2d(nlon,nlat) = ", lon2d(nlon,nlat)
  WRITE(6,*) "lat2d(1,1) = ", lat2d(1,1)
  WRITE(6,*) "lat2d(nlon,nlat) = ", lat2d(nlon,nlat)

  lat=lat2d(2,:)
  lon=lon2d(:,2)

  !-----------------------------------------------------------------------------
  ! Get the reference density levels:
  !-----------------------------------------------------------------------------
  CALL read_blkdat(gridfile1,sigma)
  lev = sigma
  WRITE(6,*) "lev(1) = ", lev(1)
  WRITE(6,*) "lev(nlev) = ", lev(nlev)

  !-----------------------------------------------------------------------------
  !(HYCOM) Sample temperature to make kmt field (2d land-sea depth mask)
  !-----------------------------------------------------------------------------

  ! JILI read HYCOM sample to get mask, which is needed by HYCOM output
  CALL get_hycom_sample(sample_t,pmsk,umsk,vmsk)

  WRITE(6,*) "sample_t(1,1,1) = ", sample_t(1,1,1)
  WRITE(6,*) "sample_t(nlon,nlat,nlev) = ", sample_t(nlon,nlat,nlev)

  if (.false. .and. dodebug) then
  WRITE(6,*) "========================================="
  WRITE(6,*) "STEVE: debugging for HYCOM input grid..."
  WRITE(6,*) "lon = ", lon
  WRITE(6,*) "lat = ", lat
  WRITE(6,*) "lon2d(:,1) = ", lon2d(:,1)
  WRITE(6,*) "lon2d(1,:) = ", lon2d(1,:)
  WRITE(6,*) "lat2d(:,1) = ", lat2d(:,1)
  WRITE(6,*) "lat2d(1,:) = ", lat2d(1,:)
  WRITE(6,*) "MAXVAL(lat2d) = ", MAXVAL(lat2d)
  WRITE(6,*) "done lon/lat."
  WRITE(6,*) "========================================="
  endif

  !
  ! dx and dy
  !

  if (.true.) then !STEVE: for HYCOM: this is TEMPORARY, better if it's read in
    WRITE(6,*) "Computing area_t..."
!    dx=0.0
!    dy=0.0
    area_t=dx*dy
  endif

! WRITE(6,*) "Using dx and dy from netcdf file: ", gridfile3
  WRITE(6,*) "dx(1,1) = ", dx(1,1)
  WRITE(6,*) "dx(nlon,nlat) = ", dx(nlon,nlat)
  WRITE(6,*) "dy(1,1) = ", dy(1,1)
  WRITE(6,*) "dy(nlon,nlat) = ", dy(nlon,nlat)
  WRITE(6,*) "area_t(1,1) = ", area_t(1,1)
  WRITE(6,*) "area_t(nlon,nlat) = ", area_t(nlon,nlat)

  !
  ! kmt data
  !
  !STEVE:MOM6: sum(h>0) (from MOM.res.nc) to find ocean layer depth, where depth > 0 (from ocean_togog.nc)
  !STEVE:HYCOM: this needs to correspond to the reference model layers,
  !             for now, it does not since the layers have been interpolated
  !             from 32 layer to 40 depths in the netcdf files.

  WRITE(6,*) "phi0(1,1) = ", phi0(1,1)
  WRITE(6,*) "phi0(nlon,nlat) = ", phi0(nlon,nlat)

  ! Find the 'kmt' value for the depth of the ocean grid cells (phi0)
  ! sum the layer thicknesses where depth > 0
  kmt=0
!  do k=nlev,1,-1
    do j=1,nlat
      do i=1,nlon
!       if (height(i,j,k) > 0 .and. wet(i,j) > 0 .and. kmt(i,j) == 0 ) then
!        if (kmt(i,j) == 0 .and. sample_t(i,j,k) < ncundef-2 ) then
! JILI change undef to a smaller number
! JILI kmt=0 for land and nlev for ocean
!        if (kmt(i,j) == 0 .and. sample_t(i,j,k) < 100000.0 ) then
!!         phi0(i,j) = sum(height(i,j,1:k))
!          kmt(i,j) = k
         if (phi0(i,j) > 100000.0) then
            kmt(i,j)=0
         else
            kmt(i,j)=nlev
         endif
      enddo
    enddo
!  enddo
  !kmt=nlev
  kmt0 = REAL(kmt,r_size)

  !
  ! Corioris parameter
  !
  fcori(:) = 2.0d0 * r_omega * sin(lat(:)*pi/180.0d0)
  do j=1,nlon
    do i=1,nlat
      fcori2d(i,j) = 2.0d0 * r_omega * sin(lat2d(i,j)*pi/180.0d0)
    enddo
  enddo

  ! STEVE: for (more) generalized (longitude) grid:
  lon0 = lon(1)
  lonf = lon(nlon)
  lat0 = lat(1)
  latf = lat(nlat)
  !STEVE: for MOM4p1:
  wrapgap = 360.0d0 - abs(modulo(lon0,360.0)) - abs(modulo(lonf,360.0))

  if (dodebug) then
    WRITE(6,*) "common_hycom.f90::set_common_hycom:: lon0,lonf,lat0,latf = ", lon0,lonf,lat0,latf
  endif

END SUBROUTINE set_common_oceanmodel

!STEVE: ISSUE: need to update for HYCOM
SUBROUTINE read_etaclm
!===============================================================================
! Read in (e.g.) 1993-1999 model climatology to subtract as done by AVISO
!===============================================================================
  USE netcdf

  IMPLICIT NONE

  REAL(r_sngl) :: buf4(nlon,nlat)
  INTEGER :: i,j
  INTEGER :: ncid, varid

  ! read the model SSH climatology netcdf file
  ! read into: SSHclm_m
  CALL check( NF90_OPEN(SSHclm_file,NF90_NOWRITE,ncid) )
  WRITE(6,*) "read_etaclm:: just opened file ", SSHclm_file

  buf4=0.0
  CALL check( NF90_INQ_VARID(ncid,'ssh',varid) )
  CALL check( NF90_GET_VAR(ncid,varid,buf4) )
  DO j=1,nlat
    DO i=1,nlon
      !STEVE: Hopefully reading in meters here... (data might be in cm)
      SSHclm_m(i,j) = REAL(buf4(i,j),r_size)
    END DO
  END DO

  CALL check( NF90_CLOSE(ncid) )

END SUBROUTINE read_etaclm

!STEVE: add this:
SUBROUTINE read_diag(infile,v3d,v2d,prec_in)
!===============================================================================
! Read a archive/restart file in binary format extracted from hycom ab-format
!===============================================================================
  !STEVE: This subroutine reads the hourly/daily diagnostic files produced by HYCOM
  !       The t,s,u,v,(ssh) fields are read in from the ab archive files so that the o-f data can be computed
  !       by the obsop.f90 program prior to running letkf.f90, so the diagnostic files do not have
  !       to be touched during letkf runtime.
  USE netcdf
  USE hycom_io, ONLY: read_hycom, hycom_undef,hycom_eps,get_hycom
  USE params_model, ONLY: base,base_a,base_b
  USE params_model, ONLY: iv3d_u, iv3d_v, iv3d_t, iv3d_s, iv3d_h

  IMPLICIT NONE

  CHARACTER(*), INTENT(IN) :: infile
  REAL(r_size),ALLOCATABLE,DIMENSION(:,:,:,:),INTENT(OUT) :: v3d !(nlon,nlat,nlev,nv3d)
  REAL(r_size),ALLOCATABLE,DIMENSION(:,:,:),  INTENT(OUT) :: v2d !(nlon,nlat,nv2d)
  INTEGER, INTENT(IN), OPTIONAL :: prec_in ! precision, 1=single, 2=double
  INTEGER :: prec
  REAL(r_sngl), ALLOCATABLE, DIMENSION(:,:,:) :: buf4 !(nlon,nlat,nlev)
  REAL(r_size), ALLOCATABLE, DIMENSION(:,:,:) :: buf8 !(nlon,nlat,nlev)
  INTEGER :: i,j,k
  INTEGER :: ncid,istat,varid
  INTEGER :: iunit,iolen,n,irec
  LOGICAL, PARAMETER :: dodebug = .true.
  CHARACTER(slen) :: varname, binfile,infile_a,infile_b

  ALLOCATE(v3d(nlon,nlat,nlev,nv3d))
  ALLOCATE(v2d(nlon,nlat,nv2d))

  ALLOCATE(buf8(nlon,nlat,nlev))

  ! Check for input argument for precision
  if (PRESENT(prec_in)) then
    prec = prec_in
  else
    prec = 1 ! default is 1
  endif

  ! Use specified precision
  if (prec == 1) then
    WRITE(6,*) "read_diag::  single precision requested, but option not available at this time."
    WRITE(6,*) "read_diag::  using double precision read..."
  elseif (prec == 2) then
    WRITE(6,*) "read_diag::  using double precision read..."
  else
    WRITE(6,*) "read_diag:: unsupported option, prec = ", prec
    STOP
  endif

  ! STEVE: this is provided externally at the moment
  binfile = trim(infile)//trim(base)
  infile_a = trim(infile)//trim(base_a)
  infile_b = trim(infile)//trim(base_b)

  if (dodebug) WRITE(6,*) "read_diag:: Pre-read_hycom: Reading file: ", trim(binfile)
! JILI Read HYCOM a and b files
  CALL get_hycom(infile_a,infile_b,v3d,v2d)

  if (dodebug) WRITE(6,*) "read_diag:: Post-read_hycom: Just read file: ", trim(binfile)

  if (dodebug) then
    WRITE(6,*) "read_diag:: Post-read_hycom"
    buf8 = v3d(:,:,:,iv3d_t)
    where (abs(buf8-hycom_undef) < hycom_eps) buf8 = 0.0d0
    WRITE(6,*) "MAXVAL(v3d(:,:,1,iv3d_t)) = ", MAXVAL(buf8(:,:,1))
    WRITE(6,*) "MINVAL(v3d(:,:,1,iv3d_t)) = ", MINVAL(buf8(:,:,1))

    buf8 = v3d(:,:,:,iv3d_s)
    where (abs(buf8-hycom_undef) < hycom_eps) buf8 = 0.0d0
    WRITE(6,*) "MAXVAL(v3d(:,:,1,iv3d_s)) = ", MAXVAL(buf8(:,:,1))
    WRITE(6,*) "MINVAL(v3d(:,:,1,iv3d_s)) = ", MINVAL(buf8(:,:,1))

    buf8 = v3d(:,:,:,iv3d_u)
    where (abs(buf8-hycom_undef) < hycom_eps) buf8 = 0.0d0
    WRITE(6,*) "MAXVAL(v3d(:,:,1,iv3d_u)) = ", MAXVAL(buf8(:,:,1))
    WRITE(6,*) "MINVAL(v3d(:,:,1,iv3d_u)) = ", MINVAL(buf8(:,:,1))

    buf8 = v3d(:,:,:,iv3d_v)
    where (abs(buf8-hycom_undef) < hycom_eps) buf8 = 0.0d0
    WRITE(6,*) "MAXVAL(v3d(:,:,1,iv3d_v)) = ", MAXVAL(buf8(:,:,1))
    WRITE(6,*) "MINVAL(v3d(:,:,1,iv3d_v)) = ", MINVAL(buf8(:,:,1))

    buf8 = v3d(:,:,:,iv3d_h)
    where (abs(buf8-hycom_undef) < hycom_eps) buf8 = 0.0d0
    WRITE(6,*) "MAXVAL(v3d(:,:,1,iv3d_h)) = ", MAXVAL(buf8(:,:,1))
    WRITE(6,*) "MINVAL(v3d(:,:,1,iv3d_h)) = ", MINVAL(buf8(:,:,1))
    WRITE(6,*)
  endif

  DEALLOCATE(buf8)

END SUBROUTINE read_diag

!-----------------------------------------------------------------------
!-- Read a restart file at the analysis time  --------------------------
SUBROUTINE read_restart(infile,v3d,v2d,prec_in)
  !STEVE: This subroutine reads the HYCOM restart file.
  !       The t,s,u,v,(ssh) fields are read in from a file so that the transform can be applied to them.
  !       It is assumed that the o-f data have already been computed by the obsope.f90 program prior
  !       to running letkf.f90, so the archive (diagnostic) files should not have to be touched during letkf runtime.
  USE netcdf
  USE params_model, ONLY: iv3d_u, iv3d_v, iv3d_t, iv3d_s, iv3d_h

  IMPLICIT NONE

  CHARACTER(*),INTENT(IN) :: infile
  REAL(r_sngl),ALLOCATABLE,DIMENSION(:,:,:,:),INTENT(OUT) :: v3d !(nlon,nlat,nlev,nv3d)
  REAL(r_sngl),ALLOCATABLE,DIMENSION(:,:,:),  INTENT(OUT) :: v2d !(nlon,nlat,nv2d)
  INTEGER, INTENT(IN), OPTIONAL :: prec_in ! precision, 1=single, 2=double
  INTEGER :: prec
  REAL(r_size), ALLOCATABLE :: v3d8(:,:,:,:)
  REAL(r_size), ALLOCATABLE :: v2d8(:,:,:)

  ! Check for input argument for precision
  if (PRESENT(prec_in)) then
    prec = prec_in
  else
    prec = 2 ! default is 2
  endif

! !STEVE: for now, only use the HYCOM archive format. The output ab file will be converted to a restart file externally.
  ALLOCATE(v3d(nlon,nlat,nlev,nv3d),v2d(nlon,nlat,nv2d))
  ALLOCATE(v3d8(nlon,nlat,nlev,nv3d),v2d8(nlon,nlat,nv2d))
  CALL read_diag(infile,v3d8,v2d8,prec) !WARNING - default for read_diag may be prec=1
  v3d = REAL(v3d8,r_sngl)
  v2d = REAL(v2d8,r_sngl)
  DEALLOCATE(v3d8,v2d8)

END SUBROUTINE read_restart

!-----------------------------------------------------------------------
subroutine check(status)
  USE netcdf
  IMPLICIT NONE
  integer, intent (in) :: status
  if(status /= nf90_noerr) then
    print *, trim(nf90_strerror(status))
    stop "Stopped"
  end if
end subroutine check

!-----------------------------------------------------------------------
! Write a set of MOM6 restart files to initialize the next model run
!-----------------------------------------------------------------------
SUBROUTINE write_restart(outfile,v3d,v2d)
  !STEVE: This writes out the analysis to a pre-existing template netcdf file.
  !       IN THE FUTURE: output directly as a HYCOM restart file
  USE netcdf
  USE hycom_io, ONLY: write_hycom, hycom_undef,put_hycom
  USE vars_model, ONLY:pmsk,umsk,vmsk
  !USE params_model, ONLY: base, base_a,base_b,do_physlimit,nlev,nlat,nlon
  USE params_model

  IMPLICIT NONE
!  INCLUDE 'netcdf.inc'
  CHARACTER(*),INTENT(IN) :: outfile
  !REAL(r_sngl),DIMENSION(:,:,:,:),INTENT(IN) :: v3d !(nlon,nlat,nlev,nv3d)
  !REAL(r_sngl),DIMENSION(:,:,:),  INTENT(IN) :: v2d !(nlon,nlat,nv2d)
  REAL(r_sngl),DIMENSION(:,:,:,:) :: v3d !(nlon,nlat,nlev,nv3d)
  REAL(r_sngl),DIMENSION(:,:,:)   :: v2d !(nlon,nlat,nv2d)

  INTEGER :: ncid,istat,varid
  INTEGER :: m,k,j,i !STEVE: for debugging
  CHARACTER(slen) :: binfile,infile_a,infile_b
  CHARACTER(3) :: MEM3

  ! STEVE: this is provided externally at the moment
  binfile = trim(outfile)//trim(base)
  infile_a = "gs01"//outfile(5:7)//trim(base_a)
  infile_b = "gs01"//outfile(5:7)//trim(base_b)

  ! STEVE: for safety, clean up the variables for output:
  ! JILI for land grids, also set variables to undef
  ! JILI a potential probelm: bottom layers large spread-need to be very careful
  if (do_physlimit) then
  do k=1,nlev
    do j=1,nlat
      do i=1,nlon
        if (v3d(i,j,k,iv3d_t) < min_t) then
          WRITE(6,*) "WARNING: Bad temp value in analysis output:"
          WRITE(6,*) "v3d(",i,",",j,",",k,") = ", v3d(i,j,k,iv3d_t)
          v3d(i,j,k,iv3d_t) = min_t
        endif

        if (v3d(i,j,k,iv3d_t) > max_t) then
          WRITE(6,*) "WARNING: Bad temp value in analysis output:"
          WRITE(6,*) "v3d(",i,",",j,",",k,") = ", v3d(i,j,k,iv3d_t)
          v3d(i,j,k,iv3d_t) = max_t
        endif

        if (v3d(i,j,k,iv3d_s) < min_s) then
          WRITE(6,*) "WARNING: Bad salt value in analysis output:"
          WRITE(6,*) "v3d(",i,",",j,",",k,") = ", v3d(i,j,k,iv3d_s)
          v3d(i,j,k,iv3d_s) = min_s
        endif

        if (v3d(i,j,k,iv3d_s) > max_s) then
          WRITE(6,*) "WARNING: Bad salt value in analysis output:"
          WRITE(6,*) "v3d(",i,",",j,",",k,") = ", v3d(i,j,k,iv3d_s)
          v3d(i,j,k,iv3d_s) = max_s
        endif

        if (v3d(i,j,k,iv3d_u) < min_uv) then
          WRITE(6,*) "WARNING: Bad u-vel value in analysis output:"
          WRITE(6,*) "v3d(",i,",",j,",",k,") = ", v3d(i,j,k,iv3d_u)
          v3d(i,j,k,iv3d_u) = min_uv
        endif

        if (v3d(i,j,k,iv3d_u) > max_uv) then
          WRITE(6,*) "WARNING: Bad u-vel value in analysis output:"
          WRITE(6,*) "v3d(",i,",",j,",",k,") = ", v3d(i,j,k,iv3d_u)
          v3d(i,j,k,iv3d_u) = max_uv
        endif

        if (v3d(i,j,k,iv3d_v) < min_uv) then
          WRITE(6,*) "WARNING: Bad v-vel value in analysis output:"
          WRITE(6,*) "v3d(",i,",",j,",",k,") = ", v3d(i,j,k,iv3d_v)
          v3d(i,j,k,iv3d_v) = min_uv
        endif

        if (v3d(i,j,k,iv3d_v) > max_uv) then
          WRITE(6,*) "WARNING: Bad v-vel value in analysis output:"
          WRITE(6,*) "v3d(",i,",",j,",",k,") = ", v3d(i,j,k,iv3d_v)
          v3d(i,j,k,iv3d_v) = max_uv
        endif

      enddo
    enddo
  enddo

  endif

  WRITE(6,*) "common_hycom.f90::write_restart:: writing file: ", trim(binfile)

  WRITE(6,*) "common_hycom.f90::write_restart:: calling write_hycom..."
  !JILI HYCOM archive file output
  CALL put_hycom(infile_a,infile_b,v3d,v2d)
  WRITE(6,*) "common_hycom.f90::write_restart:: Finished calling write_hycom."

END SUBROUTINE write_restart

!-----------------------------------------------------------------------
!-- Read a grid file ---------------------------------------------------

!-----------------------------------------------------------------------
! Read a grid file with single precision
!-----------------------------------------------------------------------
SUBROUTINE read_grd(filename,v3d,v2d)
  ! STEVE: binary native format for outputting ensemble mean and spread
  !        (may want to change to HYCOM ab archive format in the future)
  USE params_model, ONLY: nij0
  IMPLICIT NONE
  CHARACTER(*),INTENT(IN) :: filename
  REAL(r_sngl),ALLOCATABLE,DIMENSION(:,:,:,:), INTENT(OUT) :: v3d !(nlon,nlat,nlev,nv3d)
  REAL(r_sngl),ALLOCATABLE,DIMENSION(:,:,:),   INTENT(OUT) :: v2d !(nlon,nlat,nv2d)
  INTEGER :: iunit,iolen
  INTEGER :: i,j,k,n,irec

  ALLOCATE(v3d(nlon,nlat,nlev,nv3d),v2d(nlon,nlat,nv2d))

  iunit=11
  INQUIRE(IOLENGTH=iolen) iolen
  OPEN(iunit,FILE=filename,FORM='unformatted',ACCESS='direct',RECL=nij0*iolen)

  irec=1
  DO n=1,nv3d
    DO k=1,nlev
      READ(iunit,REC=irec) ((v3d(i,j,k,n),i=1,nlon),j=1,nlat)
      irec = irec + 1
    END DO
  END DO

  DO n=1,nv2d
    READ(iunit,REC=irec) ((v2d(i,j,n),i=1,nlon),j=1,nlat)
    irec = irec + 1
  END DO

  CLOSE(iunit)

END SUBROUTINE read_grd

!-----------------------------------------------------------------------
! Write a grid file in single precision
!-----------------------------------------------------------------------
SUBROUTINE write_grd(filename,v3d,v2d)
  ! STEVE: binary native format for outputting ensemble mean and spread
  !        (may want to change to HYCOM ab archive format in the future)
  USE params_model, ONLY: nij0
  IMPLICIT NONE
  CHARACTER(*),INTENT(IN) :: filename
  REAL(r_sngl),DIMENSION(:,:,:,:), INTENT(IN) :: v3d !(nlon,nlat,nlev,nv3d)
  REAL(r_sngl),DIMENSION(:,:,:),   INTENT(IN) :: v2d !(nlon,nlat,nv2d)
  INTEGER :: iunit,iolen
  INTEGER :: i,j,k,n,irec
  LOGICAL, PARAMETER :: dodebug=.false.

  if (dodebug) print *, "write_grd4:: open filename = ",filename
  iunit=55
  INQUIRE(IOLENGTH=iolen) iolen
  if (dodebug) print *, "write_grd4:: nij0,iolength = ", nij0,iolen
  OPEN(iunit,FILE=filename,FORM='unformatted',ACCESS='direct',RECL=nij0*iolen)

  irec=1
  DO n=1,nv3d
    DO k=1,nlev
      if (dodebug) print *, "write_grd4:: n,k,irec = ",n,k,irec
      WRITE(iunit,REC=irec) ((v3d(i,j,k,n),i=1,nlon),j=1,nlat)
      irec = irec + 1
    END DO
  END DO

  DO n=1,nv2d
    if (dodebug) print *, "write_grd4:: n,irec = ",n,irec
    WRITE(iunit,REC=irec) ((v2d(i,j,n),i=1,nlon),j=1,nlat)
    irec = irec + 1
  END DO

  CLOSE(iunit)

END SUBROUTINE write_grd

SUBROUTINE ensmean_grd(member,nij,v3d,v2d,v3dm,v2dm)
!-----------------------------------------------------------------------
! Ensemble manipulations
!-----------------------------------------------------------------------
  use hycom_io, ONLY: hycom_undef,hycom_eps
  IMPLICIT NONE
  INTEGER,INTENT(IN) :: member
  INTEGER,INTENT(IN) :: nij
  REAL(r_size),INTENT(IN) :: v3d(nij,nlev,member,nv3d)
  REAL(r_size),INTENT(IN) :: v2d(nij,member,nv2d)
  REAL(r_size),INTENT(OUT) :: v3dm(nij,nlev,nv3d)
  REAL(r_size),INTENT(OUT) :: v2dm(nij,nv2d)
  INTEGER :: cnt3d(nij,nlev,nv3d)
  INTEGER :: cnt2d(nij,nv2d)
  INTEGER :: i,k,m,n

! ALLOCATE(v3dm(nij,nlev,nv3d),v2dm(nij,nv2d))

  !STEVE: For HYCOM, we have to check whether the member point
  !       is undefined, because some members can differ in the
  !       grid definition.

  cnt3d = 0
  v3dm  = 0.0d0
  do n=1,nv3d
    do k=1,nlev
      do i=1,nij
        do m=1,member
          if (abs(v3d(i,k,m,n)-hycom_undef) > hycom_eps )  then
            v3dm(i,k,n) = v3dm(i,k,n) + v3d(i,k,m,n)
            cnt3d(i,k,n) = cnt3d(i,k,n) + 1
          endif
        enddo
        v3dm(i,k,n) = v3dm(i,k,n) / REAL(cnt3d(i,k,n),r_size)
      enddo
    enddo
  enddo

  cnt2d = 0
  v2dm = 0.0d0
  do n=1,nv2d
    do i=1,nij
      do m=1,member
        if (abs(v2d(i,m,n)-hycom_undef) > hycom_eps )  then
          v2dm(i,n) = v2dm(i,n) + v2d(i,m,n)
          cnt2d(i,n) = cnt2d(i,n) + 1
        endif
      enddo
      v2dm(i,n) = v2dm(i,n) / REAL(cnt2d(i,n),r_size)
    enddo
  enddo

END SUBROUTINE ensmean_grd

END MODULE common_oceanmodel


	SUBROUTINE IM_LUTF2  ( REF, iret )
C************************************************************************
C* IM_LUTF2
C*
C Modified from GEMPAK original for NIDS only optimization. Store       *
C color map hard-coded here                                             *
C*									*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'IMGDEF.CMN'
	logical REF
C*
	integer red(16,2)/    0,   0,   1,   0,   0,  0 ,   0, 255,
     +			    231, 255, 255, 214, 192, 255, 153, 255,  !Ref
     +                        0,  50,   0,   0,   0,   0,  90, 180,
     +			    118, 200, 255, 255, 230, 250, 250,   0/  !Vel
	integer green(16,2)/  0, 236, 160,   0, 255, 200, 144, 255,
     +		  	    192, 144,   0,   0,   0,   0,  85, 255,  !Ref
     +                        0,   0, 128, 224, 251, 187, 143, 190,
     +			    118, 200, 255, 200, 100,   0,   0,   0/  !Vel
	integer blue(16,2)/   0, 236, 246, 246,   0,   0,   0,   0,
     +			      0,   0,   0,   0,   0, 255, 201, 255,  !Ref
     +                        0, 150, 255, 255, 144,   0,  90, 180,
     +			     50,   0,   0,  50,   0,  50, 200,   0/  !Vel

	PARAMETER	(MAXCOL = 256)
	INTEGER		icolrs (MAXCOL)
	INTEGER		irgun (MAXCOL), iggun (MAXCOL), ibgun (MAXCOL),
     +			ir (MAXCOL), ig (MAXCOL), ib (MAXCOL)
C------------------------------------------------------------------------
	iret = 0
C
C*      Check if IM_SIMG was called for seting up the navigation.
C
	IF  ( ( imbank .lt. 1 ) .or. ( imbank .gt. 2 ) )  RETURN
C
C*      Get the number of colors for this color bank
C
	CALL GQCLRS ( imbank, ncolr, iret )
	IF ( (iret .ne. 0) .or. (ncolr.eq.1) ) return

	j = 1
	if ( .not. REF ) j = 2

	do i=1,16
	   irgun(i) = red(i,j)
	   iggun(i) = green(i,j)
	   ibgun(i) = blue(i,j)
	end do
	numcol = 16

        ratio = FLOAT (numcol - 1) / (ncolr - 1)
        DO i = 1, ncolr
	   index = ((i-1) * ratio + .5) + 1
    	   icolrs (i) = i - 1
	   ir (i) = irgun (index)
	   ig (i) = iggun (index)
	   ib (i) = ibgun (index)
        END DO
	CALL GSBRGB ( imbank, ncolr, icolrs, ir, ig, ib, iret )
	RETURN
	END


      SUBROUTINE INITBIN4
C
C M.R. MORTON    02 JUN 1999
C CHANGE RECORD
C INITIALIZES BINARY FILE FOR EFDC OUTPUT.  PLACES CONTROL
C PARAMETERS FOR POST-PROCESSOR IN HEADER SECTION OF BINARY
C FILE WQSDTS.BIN FOR BENTHIC FLUX RATES.
C
      USE GLOBAL

      REAL,SAVE,ALLOCATABLE,DIMENSION(:)::XLON
      REAL,SAVE,ALLOCATABLE,DIMENSION(:)::YLAT
      LOGICAL FEXIST,IS1OPEN,IS2OPEN
      CHARACTER*20 WQNAME(30)
      CHARACTER*10 WQUNITS(30)
      CHARACTER*3  WQCODE(30)

      IF(.NOT.ALLOCATED(XLON))THEN
		ALLOCATE(XLON(LCM))
		ALLOCATE(YLAT(LCM))
	    XLON=0.0
	    YLAT=0.0
	ENDIF
C
C THE FOLLOWING PARAMETERS ARE SPECIFIED IN EFDC.INP AND WQ3DSD.INP:
C KCSD     = NUMBER OF VERTICAL LAYERS (FORCED TO 1 FOR BENTHIC FLUX FIL
C ISMTSDT  = NUMBER OF TIME STEPS PER DATA DUMP OF BENTHIC FLUXES
C DT       = TIME STEP OF EFDC MODEL IN SECONDS
C LA       = NUMBER OF ACTIVE CELLS + 1 IN MODEL
C TBEGAN   = BEGINNING TIME OF RUN IN DAYS
C THE PARAMETER NPARM MUST BE CHANGED IF THE OUTPUT DATA
C IS CHANGED IN SUBROUTINE WSMTSBIN:
C NPARM   = NUMBER OF PARAMETERS WRITTEN TO BINARY FILE
C NREC4   = NUMBER OF RECORDS WRITTEN TO BINARY FILE (ONE RECORD
C           IS A COMPLETE DATA DUMP FOR TIME INTERVAL IWQDIUDT)
C
      NPARM = 8
      NCELLS = LA-1
      NREC4 = 0
      TEND = TBEGIN
      KCSD = 1
      MAXRECL4 = 32
      IF(NPARM .GE. 8)THEN
        MAXRECL4 = NPARM*4
      ENDIF
C
C THE FOLLOWING WATER QUALITY NAMES, UNITS, AND 3-CHARACTER CODES
C SHOULD BE MODIFIED TO MATCH THE PARAMETERS WRITTEN TO THE BINARY
C FILE IN SUBROUTINE WSMTSBIN.  THE CHARACTER STRINGS MUST BE
C EXACTLY THE LENGTH SPECIFIED BELOW IN ORDER FOR THE POST-PROCESSOR
C TO WORK CORRECTLY.
C BE SURE WQNAME STRINGS ARE EXACTLY 20-CHARACTERS LONG:
C------------------'         1         2'
C------------------'12345678901234567890'
C
      WQNAME( 1) = 'SOD_BENTHIC_FLUX    '
      WQNAME( 2) = 'NH4_BENTHIC_FLUX    '
      WQNAME( 3) = 'NO3_BENTHIC_FLUX    '
      WQNAME( 4) = 'PO4D_BENTHIC_FLUX   '
      WQNAME( 5) = 'SAD_BENTHIC_FLUX    '
      WQNAME( 6) = 'COD_BENTHIC_FLUX    '
      WQNAME( 7) = 'SEDIMENT_TEMPERATURE'
      WQNAME( 8) = 'BENTHIC_STRESS      '
C
C BE SURE WQUNITS STRINGS ARE EXACTLY 10-CHARACTERS LONG:
C-------------------'         1'
C-------------------'1234567890'
C
      WQUNITS( 1) = 'G/M2/DAY  '
      WQUNITS( 2) = 'G/M2/DAY  '
      WQUNITS( 3) = 'G/M2/DAY  '
      WQUNITS( 4) = 'G/M2/DAY  '
      WQUNITS( 5) = 'G/M2/DAY  '
      WQUNITS( 6) = 'G/M2/DAY  '
      WQUNITS( 7) = 'DEGC      '
      WQUNITS( 8) = 'DAYS      '
C
C BE SURE WQCODE STRINGS ARE EXACTLY 3-CHARACTERS LONG:
C------------------'123'
C
      WQCODE( 1) = 'SOD'
      WQCODE( 2) = 'FNH'
      WQCODE( 3) = 'FNO'
      WQCODE( 4) = 'FP4'
      WQCODE( 5) = 'FSA'
      WQCODE( 6) = 'FCO'
      WQCODE( 7) = 'SMT'
      WQCODE( 8) = 'BST'
C
C IF WQSDTS.BIN ALREADY EXISTS, OPEN FOR APPENDING HERE.
C
      IF(ISSDBIN .EQ. 2)THEN
        IO = 1
    5   IO = IO+1
        IF(IO .GT. 99)THEN
      WRITE(0,*) ' NO AVAILABLE IO UNITS ... IO > 99'
      STOP ' EFDC HALTED IN SUBROUTINE INITBIN4'
      ENDIF
        INQUIRE(UNIT=IO, OPENED=IS2OPEN)
        IF(IS2OPEN) GOTO 5
        INQUIRE(FILE='WQSDTS.BIN', EXIST=FEXIST)
        IF(FEXIST)THEN
          OPEN(UNIT=IO, FILE='WQSDTS.BIN', ACCESS='DIRECT',
     &        FORM='UNFORMATTED', STATUS='UNKNOWN', RECL=MAXRECL4)
      WRITE(0,*) 'OLD FILE WQSDTS.BIN FOUND...OPENING FOR APPEND'
          READ(IO, REC=1) NREC4, TBEGAN, TEND, DT, ISMTSDT, NPARM,
     &        NCELLS, KCSD
          NR6 = 1 + NPARM*3 + NCELLS*4 + (NCELLS*KCSD+1)*NREC4 + 1
          CLOSE(IO)
        ELSE
          ISSDBIN=1
        ENDIF
      ENDIF
C
C IF WQSDTS.BIN ALREADY EXISTS, DELETE IT HERE.
C
      IF(ISSDBIN .EQ. 1)THEN
        TBEGAN = TBEGIN
        IO = 1
   10   IO = IO+1
        IF(IO .GT. 99)THEN
      WRITE(0,*) ' NO AVAILABLE IO UNITS ... IO > 99'
      STOP ' EFDC HALTED IN SUBROUTINE INITBIN4'
      ENDIF
        INQUIRE(UNIT=IO, OPENED=IS2OPEN)
        IF(IS2OPEN) GOTO 10
        INQUIRE(FILE='WQSDTS.BIN', EXIST=FEXIST)
        IF(FEXIST)THEN
          OPEN(UNIT=IO, FILE='WQSDTS.BIN')
          CLOSE(UNIT=IO, STATUS='DELETE')
      WRITE(0,*) 'OLD FILE WQSDTS.BIN DELETED...'
      ENDIF
        OPEN(UNIT=IO, FILE='WQSDTS.BIN', ACCESS='DIRECT',
     &      FORM='UNFORMATTED', STATUS='UNKNOWN', RECL=MAXRECL4)
C
C WRITE CONTROL PARAMETERS FOR POST-PROCESSOR TO HEADER
C SECTION OF THE WQSDTS.BIN BINARY FILE:
C
        WRITE(IO) NREC4, TBEGAN, TEND, DT, ISMTSDT, NPARM, NCELLS, KCSD
        DO I=1,NPARM
          WRITE(IO) WQNAME(I)
        ENDDO
        DO I=1,NPARM
          WRITE(IO) WQUNITS(I)
        ENDDO
        DO I=1,NPARM
          WRITE(IO) WQCODE(I)
        ENDDO
C
C WRITE CELL I,J MAPPING REFERENCE TO HEADER SECTION OF BINARY FILE:
C
        DO L=2,LA
          WRITE(IO) IL(L)
        ENDDO
        DO L=2,LA
          WRITE(IO) JL(L)
        ENDDO
C
C **  READ IN XLON AND YLAT OR UTME AND UTMN OF CELL CENTERS OF
C **  CURVILINEAR PORTION OF THE GRID FROM FILE LXLY.INP:
C
        IO1 = 0
   20   IO1 = IO1+1
        IF(IO1 .GT. 99)THEN
      WRITE(0,*) ' NO AVAILABLE IO UNITS ... IO1 > 99'
      STOP ' EFDC HALTED IN SUBROUTINE INITBIN4'
      ENDIF
        INQUIRE(UNIT=IO1, OPENED=IS1OPEN)
        IF(IS1OPEN) GOTO 20
        OPEN(IO1,FILE='LXLY.INP',STATUS='UNKNOWN')
        DO NS=1,4
          READ(IO1,1111)
        ENDDO
 1111 FORMAT(80X)
        DO LL=1,LVC
          READ(IO1,*) I,J,XUTME,YUTMN
          L=LIJ(I,J)
          XLON(L)=XUTME
          YLAT(L)=YUTMN
        ENDDO
        CLOSE(IO1)
C
C WRITE XLON AND YLAT OF CELL CENTERS TO HEADER SECTION OF
C BINARY OUTPUT FILE:
C
        DO L=2,LA
          WRITE(IO) XLON(L)
        ENDDO
        DO L=2,LA
          WRITE(IO) YLAT(L)
        ENDDO
        INQUIRE(UNIT=IO, NEXTREC=NR6)
        CLOSE(IO)
      ENDIF
      RETURN
      END


C     =================
      SUBROUTINE BEAMFIL
C     =================
C     This routine fills general event quantities such as
C     run and event number, the year the data was taken
c     (or simulated) and the beam energies.
C
C     A.Quadt, May 1997.
C     ----------------------------------------------------

      IMPLICIT NONE

#include "partap.inc"
#include "zrevt.inc"
#include "zdskey.inc"
#include "fmckin.inc"
#include "o4sbor.inc"
c#include "ctrlcm.inc"
#include "common.inc"

      INTEGER EVT_COUNTER, I
      SAVE    EVT_COUNTER
      DATA    EVT_COUNTER / 0 /
      REAL    DEF_EE,DEF_EP

C ---------------------
C --- Beam energies ---
C ---------------------
      IF (YEAR.EQ.1993) THEN
          DEF_EE = 26.667
          DEF_EP = 819.92
      ELSEIF (YEAR.EQ.1994) THEN
          DEF_EE = 27.584
          DEF_EP = 819.901
      ELSEIF (YEAR.EQ.1995) THEN
          DEF_EE = 27.584
          DEF_EP = 819.901
      ELSEIF (YEAR.EQ.1996) THEN
          DEF_EE = 27.584
          DEF_EP = 819.901
      ELSEIF (YEAR.EQ.1997) THEN
          DEF_EE = 27.584
          DEF_EP = 819.901
      ENDIF

      IF (.not.montecarlo) THEN

        IF (COUTAB(O4SBOR).GT.0) THEN
          CALL FETTAB(O4SBOR,ID,1)
          EE     = O4SBOR_Momnz
          EP     = O4SBOR_Mompz
          DEF_EE = EE
          DEF_EP = EP
        ELSE
          EE     = DEF_EE
          EP     = DEF_EP
        ENDIF

      ELSE

        IF (COUTAB(FMCKIN).GT.0) THEN
          CALL FETTAB(FMCKIN,ID,1)     ! fetch initial electron energy
          EE     = FMCKIN_P(4)
          CALL FETTAB(FMCKIN,ID,2)     ! fetch initial proton energy
          EP     = FMCKIN_P(4)
          DEF_EE = EE
          DEF_EP = EP
        ELSE
          EE     = DEF_EE
          EP     = DEF_EP
        ENDIF

      ENDIF

      RETURN
      END


subroutine sldale_turnon(a)
   !-----------------------------------------------------------------------
   !> This routine sets the mesh to ALE. The displacement and velocity pointers
   !! of the mesh are also initialized.
   !-----------------------------------------------------------------------
   use typre
   use Mod_sldAlemov
   implicit none

   class(sldAlemovProblem)  :: a
   integer(ip):: npoin,ipoin,idime,ndime,nelem,ielem,nboun,auxsize

   call a%Mesh%GetNelem(nelem)
   call a%Mesh%GetNboun(nboun)
   call a%Mesh%GetNdime(ndime)
   call a%Mesh%GetNpoin(npoin)

   !We trick the module to believe its normal
   call a%solid%SetMesh(a%Mesh)

   call a%solid%SetParallelLibrary(a%ParallelLibrary)
   call a%solid%Mesh%SetParallelLibrary(a%ParallelLibrary)

   a%solid%LinearSystem => a%LinearSystem

   !set up solid as linear
   a%solid%sld_model='LINEA'
   a%solid%sld_type ='LINEA'
   a%solid%kfl_linea= 0

   a%solid%kfl_printPrincipalStresses=a%kfl_printPrincipalStresses
   a%solid%kfl_isSlave     = .true.
   a%solid%kfl_printStress = .true.
   a%solid%kfl_printStrain = .true.

   !set up DOF!
   call a%solid%SetNdofn
   call a%solid%SetNdofbc

   a%solid%kfl_tsche_2nd_datafile= 'NONE '
   a%solid%kfl_tsche_2nd_current = 'NONE '
   call a%solid%memall

   call a%Mesh%GetNpoin(npoin)

   !allocate basic vectors
   call a%solid%Memor%alloc(nboun,a%solid%kfl_bours,'kfl_bours','sldale_turnon')
   call a%solid%Memor%alloc(npoin,a%solid%kfl_fixrs,'kfl_fixrs','sldale_turnon')
   call a%solid%Memor%alloc(nboun,a%solid%kfl_fixbo,'kfl_fixbo','sldale_turnon')
   call a%solid%Memor%alloc(a%solid%ndofbc,npoin,a%solid%kfl_fixno,'kfl_fixno','sldale_turnon')
   call a%solid%Memor%alloc(a%solid%ndofbc,npoin,2,a%solid%bvess,'bvess','sldale_turnon')
   call a%solid%Memor%alloc(a%solid%ndofn,npoin,a%solid%unkno,'unkno','sldale_turnon')

   auxsize=size(a%bvnat,1)
   call a%solid%Memor%alloc(auxsize,a%solid%bvnat                  ,'bvnat'    ,'sldale_turnon')
   call a%solid%Memor%alloc(npoin  ,a%solid%kfl_funno              ,'kfl_funno','sldale_turnon')
   call a%solid%Memor%alloc(nboun  ,a%solid%kfl_funbo              ,'kfl_funbo','sldale_turnon')
   call a%solid%Memor%alloc(10     ,2            ,a%solid%kfl_funty,'kfl_funty','sldale_turnon')
   call a%solid%Memor%alloc(10     ,a%solid%funpa                  ,'funpa'    ,'sldale_turnon')

   call a%solid%SpecificTurnon

end subroutine sldale_turnon


!> The module eosdata contains the definitions of the equation of state, mixing
!> rule and the interaction parameters.

module eos_container
  use compdata
  use eos_parameters
  use cubic_eos
  use thermopack_var
  use saftvrmie_containers, only: saftvrmie_eos
  use lj_splined, only: ljs_bh_eos, ljs_wca_eos, ljx_ux_eos_constructor
  use pc_saft_nonassoc, only: PCSAFT_eos
  use extcsp, only: extcsp_eos

contains

  !----------------------------------------------------------------------
  !> Selection of equation of state and allocation of container classes
  !! \param eosstr The equation of state as a character string e.g 'SRK' og 'PR'
  !!
  !! The character strings are case-insensitive
  !!
  !! \author Morten Hammer
  subroutine allocate_eos(nc, eosstr)
    use eosdata
    !$ use omp_lib, only: omp_get_max_threads
    implicit none
    integer, intent (in) :: nc
    character (len=*), intent (in) :: eosstr
    ! Locals
    integer :: idx_db, eos_index, eos_subindex, i, istat, neos
    idx_db = get_eos_db_idx(eosstr)
    if (idx_db < 0) then
      call stoperror('unknown eos')
    endif
    eos_index = eos_label_db(idx_db)%eos_idx
    eos_subindex = eos_label_db(idx_db)%eos_subidx
    if (allocated(p_active_model%eos)) then
      do i=1,size(p_active_model%eos)
        if (associated(p_active_model%eos(i)%p_eos)) then
          call p_active_model%eos(i)%p_eos%dealloc()
          deallocate(p_active_model%eos(i)%p_eos, stat=istat)
          if (istat /= 0) call stoperror("Not able to deallocate p_active_model%eos(i)%p_eos")
        endif
      enddo
      deallocate(p_active_model%eos, stat=istat)
      if (istat /= 0) call stoperror("Not able to deallocate p_active_model%eos")
    endif
    if (allocated(p_active_model%cubic_eos_alternative)) then
      do i=1,size(p_active_model%cubic_eos_alternative)
        if (associated(p_active_model%cubic_eos_alternative(i)%p_eos)) then
          call p_active_model%cubic_eos_alternative(i)%p_eos%dealloc()
          deallocate(p_active_model%cubic_eos_alternative(i)%p_eos, stat=istat)
          if (istat /= 0) call stoperror("Not able to deallocate p_active_model&cubic_eos_alternative(i)%p_eos")
        endif
      enddo
      deallocate(p_active_model%cubic_eos_alternative, stat=istat)
      if (istat /= 0) call stoperror("Not able to deallocate p_active_model%cubic_eos_alternative")
    endif

    ! Set container data
    p_active_model%need_alternative_eos = eos_label_db(idx_db)%need_alternative_eos
    p_active_model%label = eos_label_db(idx_db)%label
    p_active_model%eosidx = eos_index

    ! Number of threads
    neos = 1
    !$ neos = omp_get_max_threads()
    allocate(p_active_model%eos(neos), stat=istat)
    if (istat /= 0) call stoperror("Not able to allocate p_active_model%eos")
    if (eos_label_db(idx_db)%need_alternative_eos) then
      allocate(p_active_model%cubic_eos_alternative(neos), stat=istat)
      if (istat /= 0) call stoperror("Not able to allocate p_active_model%cubic_eos_alternative")
    endif
    do i=1,neos
      p_active_model%eos(i)%p_eos => allocate_p_eos(nc, eos_index, eos_subindex, eosstr)
      !call p_active_model%eos(i)%p_eos%allocate_and_init(nc,eosstr)
      if (istat /= 0) call stoperror("Not able to allocate p_active_model%eos(i)")
      p_active_model%eos(i)%p_eos%eosid = eosstr
      p_active_model%eos(i)%p_eos%eosidx = eos_index
      p_active_model%eos(i)%p_eos%subeosidx = eos_subindex
      if (eos_label_db(idx_db)%need_alternative_eos) then
        allocate(p_active_model%cubic_eos_alternative(i)%p_eos, &
             source=cubic_eos_constructor(nc, "SRK"), stat=istat)
        if (istat /= 0) call stoperror("Not able to allocate p_active_model%cubic_eos_alternative")
        p_active_model%cubic_eos_alternative(i)%p_eos%eosid = "SRK"
        p_active_model%cubic_eos_alternative(i)%p_eos%eosidx = eosCubic
        p_active_model%cubic_eos_alternative(i)%p_eos%subeosidx = cbSRK
        !p_active_model%cubic_eos_alternative(i)%p_eos%allocate_and_init(nc,"SRK")
      endif
   enddo

  end subroutine allocate_eos

  function allocate_p_eos(nc, eos_index, eos_subindex, eosstr) result(p_eos)
    use pets, only: pets_eos_constructor
    integer, intent (in) :: nc
    integer, intent (in) :: eos_index, eos_subindex
    character (len=*), intent (in) :: eosstr
    class(base_eos_param), pointer :: p_eos
    ! Locals
    integer :: istat
    select case(eos_index)
    case(eosCubic)
      allocate(p_eos, &
           source=cubic_eos_constructor(nc, eosstr), stat=istat)
    case(eosLK)
      allocate(p_eos, &
           source=lk_eos_constructor(nc, eosstr), stat=istat)
    case(eosCSP)
      allocate(extcsp_eos :: p_eos, stat=istat)
    case(eosCPA)
       allocate(p_eos, source=cpa_eos_constructor(nc, eosstr), stat=istat)
    case(eosPC_SAFT)
      allocate(PCSAFT_eos :: p_eos, stat=istat)
      call p_eos%allocate_and_init(nc,eosstr)
    case(eos_single)
      allocate(p_eos, &
           source=single_eos_constructor(nc, eosstr), stat=istat)
    case(eosPT)
      select case(eos_subindex)
      case(eosSAFT_VR_MIE)
        allocate(saftvrmie_eos :: p_eos, stat=istat)
      case(eosLJS_BH)
        allocate(ljs_bh_eos :: p_eos, stat=istat)
      case(eosLJS_WCA)
        allocate(ljs_wca_eos :: p_eos, stat=istat)
      case(eosLJS_UV, eosLJS_UF, eosLJ_UF)
        allocate(p_eos, source=ljx_ux_eos_constructor(eosstr), stat=istat)
      case default
        istat = 1
      end select
    case(eosPeTS)
      allocate(p_eos, &
           source=pets_eos_constructor(nc, eosstr), stat=istat)
    case(meosNist_mix)
      allocate(p_eos, &
           source=meos_mix_constructor(nc, eosstr), stat=istat)
    case default
      istat = 1
    end select
    if (istat /= 0 .or. .not. associated(p_eos)) then
      call stoperror("Not able to allocate p_eos")
    endif
  end function allocate_p_eos

  subroutine assign_thermo_model(eos_c1, eos_c2)
    class(thermo_model), intent(inout) :: eos_c1
    class(thermo_model), intent(in) :: eos_c2
    ! Locals
    eos_c1%nph = eos_c2%nph
    eos_c1%nc = eos_c2%nc
    eos_c1%EoSlib = eos_c2%EoSlib
    eos_c1%label = eos_c2%label

    eos_c1%eosidx = eos_c2%eosidx
    !eos_c1%subeosidx = eos_c2%subeosidx
    !eos_c1%volumeShiftId = eos_c2%volumeShiftId

    eos_c1%need_alternative_eos = eos_c2%need_alternative_eos

    ! From tpvar
    !eos_c1%nce = eos_c2%nce
    eos_c1%apparent = eos_c2%apparent

    eos_c1%comps = eos_c2%comps

    if (allocated(eos_c2%eos)) then
      if (allocated(eos_c1%eos)) then
        do i=1,size(eos_c1%eos)
          if (associated(eos_c1%eos(i)%p_eos)) then
            deallocate(eos_c1%eos(i)%p_eos, stat=istat)
            if (istat /= 0) call stoperror("Not able to deallocate eos_c1%model_eos(i)%eos")
          endif
        enddo
        allocate(eos_c1%eos(size(eos_c2%eos)), stat=istat)
        if (istat /= 0) call stoperror("Not able to allocate eos_c1%model_eos")
        do i=1,size(eos_c1%eos)
          eos_c1%eos(i)%p_eos => allocate_p_eos(nc, eos_c2%eos(1)%p_eos%eosidx, &
               eos_c2%eos(1)%p_eos%subeosidx, eos_c2%eos(1)%p_eos%eosid)
          if (istat /= 0) call stoperror("Not able to allocate eos_c1%model_eos(i)%eos")
          eos_c1%eos(i)%p_eos = eos_c2%eos(i)%p_eos
        enddo
      endif
    endif

    if (allocated(eos_c2%cubic_eos_alternative)) then
      if (allocated(eos_c1%cubic_eos_alternative)) then
        do i=1,size(eos_c1%cubic_eos_alternative)
          if (associated(eos_c1%cubic_eos_alternative(i)%p_eos)) then
            deallocate(eos_c1%cubic_eos_alternative(i)%p_eos, stat=istat)
            if (istat /= 0) call stoperror("Not able to deallocate eos_c1%cubic_eos_alternative(i)%eos")
          endif
        enddo
        allocate(eos_c1%cubic_eos_alternative(size(eos_c2%cubic_eos_alternative)), stat=istat)
        if (istat /= 0) call stoperror("Not able to allocate eos_c1%cubic_eos_alternative")
        do i=1,size(eos_c1%cubic_eos_alternative)
          eos_c1%cubic_eos_alternative(i)%p_eos => allocate_p_eos(nc, &
               eos_c2%cubic_eos_alternative(1)%p_eos%eosidx, &
               eos_c2%cubic_eos_alternative(1)%p_eos%subeosidx, &
               eos_c2%cubic_eos_alternative(1)%p_eos%eosid)
          eos_c1%cubic_eos_alternative(i)%p_eos = eos_c2%cubic_eos_alternative(i)%p_eos
        enddo
      endif
    endif

  end subroutine assign_thermo_model

end module eos_container

subroutine update_global_variables_form_active_thermo_model()
  use thermopack_var, only: nc, nph, complist, apparent, nce, &
       ncsym, numAssocSites, get_active_thermo_model, &
       thermo_model
  use saftvrmie_containers, only: saftvrmie_eos, saftvrmie_param, svrm_opt
  use lj_splined, only: ljs_wca_eos
  implicit none
  type(thermo_model), pointer :: act_mod_ptr
  act_mod_ptr => get_active_thermo_model()
  nc = act_mod_ptr%nc
  nph = act_mod_ptr%nph
  complist => act_mod_ptr%complist
  apparent => act_mod_ptr%apparent
  if (associated(apparent)) then
    nce = apparent%nce
    ncsym = apparent%ncsym
  else
    nce = nc
    ncsym = nc
  endif
  numAssocSites = 0
  saftvrmie_param => NULL()
  svrm_opt => NULL()
  if (allocated(act_mod_ptr%eos)) then
    if (associated(act_mod_ptr%eos(1)%p_eos%assoc)) then
      numAssocSites = act_mod_ptr%eos(1)%p_eos%assoc%numAssocSites
    endif
    select type (p_eos => act_mod_ptr%eos(1)%p_eos)
    class is (saftvrmie_eos)
      saftvrmie_param => p_eos%saftvrmie_param
      svrm_opt => p_eos%svrm_opt
    class is (ljs_wca_eos)
      svrm_opt => p_eos%svrm_opt
    end select
  endif
end subroutine update_global_variables_form_active_thermo_model

subroutine print_globals()
  use thermopack_var, only: nc, nph, complist, apparent, nce, &
       ncsym, numAssocSites
  implicit none
  integer :: i
  print *,"nph",nph
  print *,"nc",nc
  print *,"nce",nce
  print *,"ncsym",ncsym
  print *,"numAssocSites",numAssocSites
  print *,"complist:"
  do i=1,nc
    print *," ",trim(complist(i))
  enddo
  print *,"associated(apparent)",associated(apparent)
end subroutine print_globals


	SUBROUTINE MA_STBL ( lunstb, iret )
C************************************************************************
C* MA_STBL                                                             	*
C*                                                                     	*
C* This subroutine gets the CMAN station, Great Lakes fixed buoy, and  	*
C* Coast Guard table data.  These data contain the elevations of the	*
C* Great Lakes buoys and the lat/lon and elevation of the CMAN and	*
C* Coast Guard stations.    						*
C*                                                                     	*
C* MA_STBL  ( LUNSTB, IRET )                                           	*
C*                                                                     	*
C* Input parameters:							*
C*      LUNSTB         INTEGER           Station table LUN		*
C*									*
C* Output parameters:                                                 	*
C*      IRET           INTEGER           Return code                   	*
C*                                         0 = normal return            *
C*									*
C**									*
C* Log:							               	*
C* R. Hollern/NCEP       6/96                                          	*
C* K. Tyle/GSC		 4/97	Cleaned up				*
C* D. Kidwell/NCEP	 4/97	Fixed return code               	*
C* R. Hollern/NCEP       3/99   Added table size check          	*
C* T. Piper/GSC	 	 3/99	Corrected prolog			*
C* D. Kidwell/NCEP	 4/99	Corrected prologue			*
C* S. Jacobs/NCEP	12/99	Changed size of tbchrs 14->20		*
C* F. J. Yen/NCEP	 4/01	Increased MTBLSZ for adding C. G. data	*
C* D. Kidwell/NCEP	 4/05	Moved MTBLSZ to macmn.cmn               *
C************************************************************************
        INCLUDE  	'macmn.cmn'
C*
        CHARACTER   	stnnam*32, tbchrs*20, stid*8, stat*2, coun*2
C-----------------------------------------------------------------------
        iret = 0
        i    = 0
        jstn = 0
	jret = 0
C
        DO WHILE ( jret .eq. 0 .and. jstn .le. MTBLSZ )
C
C*	    Read the next record from the GEMPAK station table.
C
            CALL TB_RSTN ( lunstb, stid, stnnam, istnm, stat, coun,
     +                     slat, slon, selv, ispri, tbchrs, jret )
C
            IF ( jret .eq. -1 ) RETURN
C
            jstn 	  = jstn + 1
            jstnid (jstn) = stid
            elev   (jstn) = selv
            ylat   (jstn) = slat
            ylong  (jstn) = slon
        END DO
C*
        RETURN
        END


      MODULE GwfUzfModule

        CHARACTER(LEN=64) :: Version_uzf
        REAL,PARAMETER :: CLOSEZERO=1.0E-15
        DOUBLE PRECISION,PARAMETER :: NEARZERO=1.0D-30
        DOUBLE PRECISION,PARAMETER :: ZEROD15=1.0D-15, ZEROD9=1.0D-09
        DOUBLE PRECISION,PARAMETER :: ZEROD6=1.0D-06
        DOUBLE PRECISION,PARAMETER :: ZEROD7=1.0D-07,ZEROD5=1.0D-05
        INTEGER         ,PARAMETER :: IRUNBIG = 10000
        INTEGER,SAVE,POINTER :: NUMCELLS, TOTCELLS, Iseepsupress, IPRCNT
        INTEGER,SAVE,POINTER :: ITHTIFLG, ITHTRFLG
        logical, save, pointer :: NeedUzfWaterMover
        DOUBLE PRECISION,SAVE :: THETAB, FLUXB, FLUXHLD2
        DOUBLE PRECISION,SAVE,DIMENSION(:),POINTER :: CHECKTIME
        INTEGER,SAVE,DIMENSION(:),POINTER :: MORE
        INTEGER,SAVE,DIMENSION(:,:),POINTER :: LAYNUM
        INTEGER,SAVE,POINTER   ::NUZTOP, IUZFOPT, IRUNFLG, IETFLG, IUZM
        INTEGER,SAVE,POINTER   ::IUZFCB1, IUZFCB2, NTRAIL, NWAV, NSETS
        INTEGER,SAVE,POINTER   ::IUZFB22, IUZFB11
        INTEGER,SAVE,POINTER   ::NUZGAG, NUZGAGAR, NUZCL, NUZRW, IGSFLOW
        INTEGER,SAVE,POINTER   ::RTSOLUTE, IETBUD
        INTEGER,SAVE,  DIMENSION(:),    POINTER :: ITRLSTH
        INTEGER,SAVE,  DIMENSION(:,:),  POINTER :: IRUNBND, IUZFBND
        INTEGER,SAVE,  DIMENSION(:,:),  POINTER :: IUZLIST, NWAVST
        INTEGER,SAVE,  DIMENSION(:,:),  POINTER :: IUZHOLD
        INTEGER,SAVE,  DIMENSION(:,:),  POINTER :: LTRLST, ITRLST
        INTEGER,SAVE,  DIMENSION(:),  POINTER :: LTRLIT, ITRLIT
        double precision,   SAVE,POINTER   ::TOTRUNOFF, SURFDEP
        REAL,   SAVE,  DIMENSION(:),    POINTER :: FBINS
        double precision,   SAVE,  DIMENSION(:,:),  POINTER :: SEEPOUT,
     &      EXCESPP, VKS
        REAL,   SAVE,  DIMENSION(:,:),  POINTER :: AIR_ENTRY, H_ROOT
        REAL,   SAVE,  DIMENSION(:,:),  POINTER :: REJ_INF
        REAL,   SAVE,  DIMENSION(:,:),  POINTER :: TO_CFP
        double precision, SAVE, DIMENSION(:,:), POINTER :: EPS, THTS,
     &      THTI, THTR
        double precision, SAVE, DIMENSION(:,:), POINTER :: PETRATE,
     &      ROOTDPTH
        double precision, SAVE, DIMENSION(:,:), POINTER :: WCWILT, FINF
        REAL,   SAVE,  DIMENSION(:,:),  POINTER :: UZFETOUT, GWET
        REAL,   SAVE,  DIMENSION(:,:),  POINTER :: FNETEXFIL, CUMGWET
        DOUBLE PRECISION, SAVE, DIMENSION(:),  POINTER :: CUMUZVOL
        DOUBLE PRECISION, SAVE, DIMENSION(:),  POINTER :: UZTSRAT
        DOUBLE PRECISION, SAVE, DIMENSION(:,:),POINTER :: UZFLWT, UZSTOR
        DOUBLE PRECISION, SAVE, DIMENSION(:,:),POINTER :: UZDPST, UZTHST
        DOUBLE PRECISION, SAVE, DIMENSION(:),POINTER :: UZDPIT, UZTHIT
        DOUBLE PRECISION, SAVE, DIMENSION(:,:),POINTER :: UZSPST, UZFLST
        DOUBLE PRECISION, SAVE, DIMENSION(:),POINTER :: UZSPIT, UZFLIT
        DOUBLE PRECISION, SAVE, DIMENSION(:,:),POINTER :: DELSTOR
        DOUBLE PRECISION, SAVE, DIMENSION(:,:),POINTER :: UZOLSFLX
        DOUBLE PRECISION, SAVE, DIMENSION(:,:),POINTER :: HLDUZF
        DOUBLE PRECISION, SAVE, DIMENSION(:,:),POINTER :: RTSOLWC
        DOUBLE PRECISION, SAVE, DIMENSION(:,:),POINTER :: RTSOLFL
        DOUBLE PRECISION, SAVE, DIMENSION(:,:),POINTER :: RTSOLDS
        DOUBLE PRECISION, SAVE, DIMENSION(:,:,:),POINTER :: UZTOTBAL
        DOUBLE PRECISION, SAVE, DIMENSION(:,:,:),POINTER :: GRIDSTOR
        DOUBLE PRECISION, SAVE, DIMENSION(:,:,:),POINTER :: GRIDET
      TYPE GWFUZFTYPE
        INTEGER,     POINTER   ::NUZTOP, IUZFOPT, IRUNFLG, IETFLG, IUZM
        INTEGER,     POINTER   ::IUZFCB1, IUZFCB2, NTRAIL, NWAV, NSETS
        INTEGER,     POINTER   ::IUZFB22, IUZFB11
        INTEGER,     POINTER   ::NUZGAG, NUZGAGAR, NUZCL, NUZRW, IGSFLOW
        INTEGER,     POINTER   ::RTSOLUTE, IETBUD
        INTEGER,     POINTER   ::NUMCELLS, TOTCELLS, Iseepsupress,IPRCNT
        INTEGER,     POINTER   ::ITHTIFLG, ITHTRFLG
        logical, pointer :: NeedUzfWaterMover
        DOUBLE PRECISION,DIMENSION(:),  POINTER :: CHECKTIME
        INTEGER,DIMENSION(:),POINTER :: MORE
        INTEGER,DIMENSION(:,:),POINTER :: LAYNUM
        INTEGER,       DIMENSION(:),    POINTER :: ITRLSTH
        INTEGER,       DIMENSION(:,:),  POINTER :: IRUNBND, IUZFBND
        INTEGER,       DIMENSION(:,:),  POINTER :: IUZLIST, NWAVST
        INTEGER,       DIMENSION(:,:),  POINTER :: IUZHOLD
        INTEGER,       DIMENSION(:,:),  POINTER :: LTRLST, ITRLST
        INTEGER,       DIMENSION(:),  POINTER :: LTRLIT, ITRLIT
        double precision,               POINTER ::TOTRUNOFF, SURFDEP
        REAL,          DIMENSION(:),    POINTER :: FBINS
        double precision, DIMENSION(:,:), POINTER :: SEEPOUT, EXCESPP,
     &      VKS
        REAL,          DIMENSION(:,:),  POINTER :: AIR_ENTRY, H_ROOT
        REAL,          DIMENSION(:,:),  POINTER :: REJ_INF
        REAL,          DIMENSION(:,:),  POINTER :: TO_CFP
        double precision, DIMENSION(:,:), POINTER :: EPS, THTS, THTI,
     &      THTR
        double precision, DIMENSION(:,:),  POINTER :: PETRATE, ROOTDPTH
        double precision, DIMENSION(:,:),  POINTER :: WCWILT, FINF
        REAL,          DIMENSION(:,:),  POINTER :: UZFETOUT, GWET
        REAL,          DIMENSION(:,:),  POINTER :: FNETEXFIL, CUMGWET
        DOUBLE PRECISION,       DIMENSION(:),  POINTER :: CUMUZVOL
        DOUBLE PRECISION,       DIMENSION(:),  POINTER :: UZTSRAT
        DOUBLE PRECISION,       DIMENSION(:,:),POINTER :: UZFLWT, UZSTOR
        DOUBLE PRECISION,       DIMENSION(:,:),POINTER :: UZDPST, UZTHST
        DOUBLE PRECISION,       DIMENSION(:),POINTER :: UZDPIT, UZTHIT
        DOUBLE PRECISION,       DIMENSION(:,:),POINTER :: UZSPST, UZFLST
        DOUBLE PRECISION,       DIMENSION(:),POINTER :: UZSPIT, UZFLIT
        DOUBLE PRECISION,       DIMENSION(:,:),POINTER :: DELSTOR
        DOUBLE PRECISION,       DIMENSION(:,:),POINTER :: UZOLSFLX
        DOUBLE PRECISION,       DIMENSION(:,:),POINTER :: HLDUZF
        DOUBLE PRECISION,       DIMENSION(:,:),POINTER :: RTSOLWC
        DOUBLE PRECISION,       DIMENSION(:,:),POINTER :: RTSOLFL
        DOUBLE PRECISION,       DIMENSION(:,:),POINTER :: RTSOLDS
        DOUBLE PRECISION,       DIMENSION(:,:,:),POINTER :: UZTOTBAL
        DOUBLE PRECISION,       DIMENSION(:,:,:),POINTER :: GRIDSTOR
        DOUBLE PRECISION,       DIMENSION(:,:,:),POINTER :: GRIDET
      END TYPE
      TYPE(GWFUZFTYPE), SAVE:: GWFUZFDAT(10)

      contains

C-------SUBROUTINE GWF2UZF1DA
      SUBROUTINE GWF2UZF1DA(Igrid)
C    Deallocate UZF DATA.
C     ------------------------------------------------------------------
C     ARGUMENTS
C     ------------------------------------------------------------------
      INTEGER Igrid
C     ------------------------------------------------------------------
      DEALLOCATE (GWFUZFDAT(Igrid)%MORE)
      DEALLOCATE (GWFUZFDAT(Igrid)%CHECKTIME)
      DEALLOCATE (GWFUZFDAT(Igrid)%LAYNUM)
      DEALLOCATE (GWFUZFDAT(Igrid)%NUZTOP)
      DEALLOCATE (GWFUZFDAT(Igrid)%IUZFOPT)
      DEALLOCATE (GWFUZFDAT(Igrid)%IRUNFLG)
      DEALLOCATE (GWFUZFDAT(Igrid)%IETFLG)
      DEALLOCATE (GWFUZFDAT(Igrid)%IUZM)
      DEALLOCATE (GWFUZFDAT(Igrid)%IUZFCB1)
      DEALLOCATE (GWFUZFDAT(Igrid)%IUZFCB2)
      DEALLOCATE (GWFUZFDAT(Igrid)%IUZFB22)
      DEALLOCATE (GWFUZFDAT(Igrid)%IUZFB11)
      DEALLOCATE (GWFUZFDAT(Igrid)%NTRAIL)
      DEALLOCATE (GWFUZFDAT(Igrid)%NWAV)
      DEALLOCATE (GWFUZFDAT(Igrid)%NSETS)
      DEALLOCATE (GWFUZFDAT(Igrid)%IGSFLOW)
      DEALLOCATE (GWFUZFDAT(Igrid)%NUZGAG)
      DEALLOCATE (GWFUZFDAT(Igrid)%NUZGAGAR)
      DEALLOCATE (GWFUZFDAT(Igrid)%NUZCL)
      DEALLOCATE (GWFUZFDAT(Igrid)%NUZRW)
      DEALLOCATE (GWFUZFDAT(Igrid)%ITRLSTH)
      DEALLOCATE (GWFUZFDAT(Igrid)%IRUNBND)
      DEALLOCATE (GWFUZFDAT(Igrid)%IUZFBND)
      DEALLOCATE (GWFUZFDAT(Igrid)%IUZLIST)
      DEALLOCATE (GWFUZFDAT(Igrid)%NWAVST)
      DEALLOCATE (GWFUZFDAT(Igrid)%IUZHOLD)
      DEALLOCATE (GWFUZFDAT(Igrid)%LTRLIT)
      DEALLOCATE (GWFUZFDAT(Igrid)%LTRLST)
      DEALLOCATE (GWFUZFDAT(Igrid)%ITRLIT)
      DEALLOCATE (GWFUZFDAT(Igrid)%ITRLST)
      DEALLOCATE (GWFUZFDAT(Igrid)%TOTRUNOFF)
      DEALLOCATE (GWFUZFDAT(Igrid)%FBINS)
      DEALLOCATE (GWFUZFDAT(Igrid)%SEEPOUT)
      DEALLOCATE (GWFUZFDAT(Igrid)%AIR_ENTRY)
      DEALLOCATE (GWFUZFDAT(Igrid)%EXCESPP)
      DEALLOCATE (GWFUZFDAT(Igrid)%VKS)
      DEALLOCATE (GWFUZFDAT(Igrid)%EPS)
      DEALLOCATE (GWFUZFDAT(Igrid)%THTS)
      DEALLOCATE (GWFUZFDAT(Igrid)%THTI)
      DEALLOCATE (GWFUZFDAT(Igrid)%PETRATE)
      DEALLOCATE (GWFUZFDAT(Igrid)%ROOTDPTH)
      DEALLOCATE (GWFUZFDAT(Igrid)%WCWILT)
      DEALLOCATE (GWFUZFDAT(Igrid)%FINF)
      DEALLOCATE (GWFUZFDAT(Igrid)%DELSTOR)
      DEALLOCATE (GWFUZFDAT(Igrid)%UZOLSFLX)
      DEALLOCATE (GWFUZFDAT(Igrid)%HLDUZF)
      DEALLOCATE (GWFUZFDAT(Igrid)%UZFETOUT)
      DEALLOCATE (GWFUZFDAT(Igrid)%GWET)
      DEALLOCATE (GWFUZFDAT(Igrid)%UZTOTBAL)
      DEALLOCATE (GWFUZFDAT(Igrid)%CUMUZVOL)
      DEALLOCATE (GWFUZFDAT(Igrid)%UZTSRAT)
      DEALLOCATE (GWFUZFDAT(Igrid)%THTR)
      DEALLOCATE (GWFUZFDAT(Igrid)%UZFLWT)
      DEALLOCATE (GWFUZFDAT(Igrid)%UZSTOR)
      DEALLOCATE (GWFUZFDAT(Igrid)%UZDPIT)
      DEALLOCATE (GWFUZFDAT(Igrid)%UZDPST)
      DEALLOCATE (GWFUZFDAT(Igrid)%UZTHIT)
      DEALLOCATE (GWFUZFDAT(Igrid)%UZTHST)
      DEALLOCATE (GWFUZFDAT(Igrid)%UZSPIT)
      DEALLOCATE (GWFUZFDAT(Igrid)%UZSPST)
      DEALLOCATE (GWFUZFDAT(Igrid)%UZFLIT)
      DEALLOCATE (GWFUZFDAT(Igrid)%UZFLST)
      DEALLOCATE (GWFUZFDAT(Igrid)%REJ_INF)
      DEALLOCATE (GWFUZFDAT(Igrid)%SURFDEP)
      DEALLOCATE (GWFUZFDAT(Igrid)%RTSOLUTE)
      DEALLOCATE (GWFUZFDAT(Igrid)%GRIDSTOR)
      DEALLOCATE (GWFUZFDAT(Igrid)%FNETEXFIL)
      DEALLOCATE (GWFUZFDAT(Igrid)%NUMCELLS)
      DEALLOCATE (GWFUZFDAT(Igrid)%TOTCELLS)
      DEALLOCATE (GWFUZFDAT(Igrid)%Iseepsupress)
      DEALLOCATE (GWFUZFDAT(Igrid)%IPRCNT)
      DEALLOCATE (GWFUZFDAT(Igrid)%ITHTIFLG)
      DEALLOCATE (GWFUZFDAT(Igrid)%ITHTRFLG)
      deallocate (GWFUZFDAT(igrid)%NeedUzfWaterMover)
      DEALLOCATE (GWFUZFDAT(Igrid)%IETBUD)
      DEALLOCATE (GWFUZFDAT(Igrid)%CUMGWET)
C
      END SUBROUTINE GWF2UZF1DA
C
C-------SUBROUTINE SGWF2UZF1PNT
      SUBROUTINE SGWF2UZF1PNT(Igrid)
C Set UZF pointers for grid.
C     ------------------------------------------------------------------
C     ARGUMENTS
C     ------------------------------------------------------------------
      INTEGER Igrid
C     ------------------------------------------------------------------
      MORE=>GWFUZFDAT(Igrid)%MORE
      CHECKTIME=>GWFUZFDAT(Igrid)%CHECKTIME
      LAYNUM=>GWFUZFDAT(Igrid)%LAYNUM
      NUZTOP=>GWFUZFDAT(Igrid)%NUZTOP
      IUZFOPT=>GWFUZFDAT(Igrid)%IUZFOPT
      IRUNFLG=>GWFUZFDAT(Igrid)%IRUNFLG
      IETFLG=>GWFUZFDAT(Igrid)%IETFLG
      IUZM=>GWFUZFDAT(Igrid)%IUZM
      IUZFCB1=>GWFUZFDAT(Igrid)%IUZFCB1
      IUZFCB2=>GWFUZFDAT(Igrid)%IUZFCB2
      IUZFB22=>GWFUZFDAT(Igrid)%IUZFB22
      IUZFB11=>GWFUZFDAT(Igrid)%IUZFB11
      NTRAIL=>GWFUZFDAT(Igrid)%NTRAIL
      NWAV=>GWFUZFDAT(Igrid)%NWAV
      NSETS=>GWFUZFDAT(Igrid)%NSETS
      IGSFLOW=>GWFUZFDAT(Igrid)%IGSFLOW
      NUZGAG=>GWFUZFDAT(Igrid)%NUZGAG
      NUZGAGAR=>GWFUZFDAT(Igrid)%NUZGAGAR
      NUZCL=>GWFUZFDAT(Igrid)%NUZCL
      NUZRW=>GWFUZFDAT(Igrid)%NUZRW
      ITRLSTH=>GWFUZFDAT(Igrid)%ITRLSTH
      IRUNBND=>GWFUZFDAT(Igrid)%IRUNBND
      IUZFBND=>GWFUZFDAT(Igrid)%IUZFBND
      IUZLIST=>GWFUZFDAT(Igrid)%IUZLIST
      NWAVST=>GWFUZFDAT(Igrid)%NWAVST
      IUZHOLD=>GWFUZFDAT(Igrid)%IUZHOLD
      LTRLIT=>GWFUZFDAT(Igrid)%LTRLIT
      LTRLST=>GWFUZFDAT(Igrid)%LTRLST
      ITRLIT=>GWFUZFDAT(Igrid)%ITRLIT
      ITRLST=>GWFUZFDAT(Igrid)%ITRLST
      TOTRUNOFF=>GWFUZFDAT(Igrid)%TOTRUNOFF
      FBINS=>GWFUZFDAT(Igrid)%FBINS
      SEEPOUT=>GWFUZFDAT(Igrid)%SEEPOUT
      AIR_ENTRY=>GWFUZFDAT(Igrid)%AIR_ENTRY
      EXCESPP=>GWFUZFDAT(Igrid)%EXCESPP
      VKS=>GWFUZFDAT(Igrid)%VKS
      EPS=>GWFUZFDAT(Igrid)%EPS
      THTS=>GWFUZFDAT(Igrid)%THTS
      THTI=>GWFUZFDAT(Igrid)%THTI
      PETRATE=>GWFUZFDAT(Igrid)%PETRATE
      ROOTDPTH=>GWFUZFDAT(Igrid)%ROOTDPTH
      WCWILT=>GWFUZFDAT(Igrid)%WCWILT
      FINF=>GWFUZFDAT(Igrid)%FINF
      DELSTOR=>GWFUZFDAT(Igrid)%DELSTOR
      UZOLSFLX=>GWFUZFDAT(Igrid)%UZOLSFLX
      HLDUZF=>GWFUZFDAT(Igrid)%HLDUZF
      UZFETOUT=>GWFUZFDAT(Igrid)%UZFETOUT
      GWET=>GWFUZFDAT(Igrid)%GWET
      UZTOTBAL=>GWFUZFDAT(Igrid)%UZTOTBAL
      CUMUZVOL=>GWFUZFDAT(Igrid)%CUMUZVOL
      UZTSRAT=>GWFUZFDAT(Igrid)%UZTSRAT
      THTR=>GWFUZFDAT(Igrid)%THTR
      UZFLWT=>GWFUZFDAT(Igrid)%UZFLWT
      UZSTOR=>GWFUZFDAT(Igrid)%UZSTOR
      UZDPIT=>GWFUZFDAT(Igrid)%UZDPIT
      UZDPST=>GWFUZFDAT(Igrid)%UZDPST
      UZTHIT=>GWFUZFDAT(Igrid)%UZTHIT
      UZTHST=>GWFUZFDAT(Igrid)%UZTHST
      UZSPIT=>GWFUZFDAT(Igrid)%UZSPIT
      UZSPST=>GWFUZFDAT(Igrid)%UZSPST
      UZFLIT=>GWFUZFDAT(Igrid)%UZFLIT
      UZFLST=>GWFUZFDAT(Igrid)%UZFLST
      REJ_INF=>GWFUZFDAT(Igrid)%REJ_INF
      SURFDEP=>GWFUZFDAT(Igrid)%SURFDEP
      RTSOLUTE=>GWFUZFDAT(Igrid)%RTSOLUTE
      GRIDSTOR=>GWFUZFDAT(Igrid)%GRIDSTOR
      FNETEXFIL=>GWFUZFDAT(Igrid)%FNETEXFIL
      NUMCELLS=>GWFUZFDAT(Igrid)%NUMCELLS
      TOTCELLS=>GWFUZFDAT(Igrid)%TOTCELLS
      Iseepsupress=>GWFUZFDAT(Igrid)%Iseepsupress
      IPRCNT=>GWFUZFDAT(Igrid)%IPRCNT
      ITHTIFLG=>GWFUZFDAT(Igrid)%ITHTIFLG
      ITHTRFLG=>GWFUZFDAT(Igrid)%ITHTRFLG
      NeedUzfWaterMover=>GWFUZFDAT(Igrid)%NeedUzfWaterMover
      IETBUD=>GWFUZFDAT(Igrid)%IETBUD
      CUMGWET=>GWFUZFDAT(Igrid)%CUMGWET
C
      END SUBROUTINE SGWF2UZF1PNT
C
C-------SUBROUTINE SGWF2UZF1PSV
      SUBROUTINE SGWF2UZF1PSV(Igrid)
C Save UZF pointers for grid.
C     ------------------------------------------------------------------
C     ARGUMENTS
C     ------------------------------------------------------------------
      INTEGER Igrid
C     ------------------------------------------------------------------
      GWFUZFDAT(Igrid)%MORE=>MORE
      GWFUZFDAT(Igrid)%CHECKTIME=>CHECKTIME
      GWFUZFDAT(Igrid)%LAYNUM=>LAYNUM
      GWFUZFDAT(Igrid)%NUZTOP=>NUZTOP
      GWFUZFDAT(Igrid)%IUZFOPT=>IUZFOPT
      GWFUZFDAT(Igrid)%IRUNFLG=>IRUNFLG
      GWFUZFDAT(Igrid)%IETFLG=>IETFLG
      GWFUZFDAT(Igrid)%IUZM=>IUZM
      GWFUZFDAT(Igrid)%IUZFCB1=>IUZFCB1
      GWFUZFDAT(Igrid)%IUZFCB2=>IUZFCB2
      GWFUZFDAT(Igrid)%IUZFB22=>IUZFB22
      GWFUZFDAT(Igrid)%IUZFB11=>IUZFB11
      GWFUZFDAT(Igrid)%NTRAIL=>NTRAIL
      GWFUZFDAT(Igrid)%NWAV=>NWAV
      GWFUZFDAT(Igrid)%NSETS=>NSETS
      GWFUZFDAT(Igrid)%IGSFLOW=>IGSFLOW
      GWFUZFDAT(Igrid)%NUZGAG=>NUZGAG
      GWFUZFDAT(Igrid)%NUZGAGAR=>NUZGAGAR
      GWFUZFDAT(Igrid)%NUZCL=>NUZCL
      GWFUZFDAT(Igrid)%NUZRW=>NUZRW
      GWFUZFDAT(Igrid)%ITRLSTH=>ITRLSTH
      GWFUZFDAT(Igrid)%IRUNBND=>IRUNBND
      GWFUZFDAT(Igrid)%IUZFBND=>IUZFBND
      GWFUZFDAT(Igrid)%IUZLIST=>IUZLIST
      GWFUZFDAT(Igrid)%NWAVST=>NWAVST
      GWFUZFDAT(Igrid)%IUZHOLD=>IUZHOLD
      GWFUZFDAT(Igrid)%LTRLIT=>LTRLIT
      GWFUZFDAT(Igrid)%LTRLST=>LTRLST
      GWFUZFDAT(Igrid)%ITRLIT=>ITRLIT
      GWFUZFDAT(Igrid)%ITRLST=>ITRLST
      GWFUZFDAT(Igrid)%TOTRUNOFF=>TOTRUNOFF
      GWFUZFDAT(Igrid)%FBINS=>FBINS
      GWFUZFDAT(Igrid)%SEEPOUT=>SEEPOUT
      GWFUZFDAT(Igrid)%AIR_ENTRY=>AIR_ENTRY
      GWFUZFDAT(Igrid)%EXCESPP=>EXCESPP
      GWFUZFDAT(Igrid)%VKS=>VKS
      GWFUZFDAT(Igrid)%EPS=>EPS
      GWFUZFDAT(Igrid)%THTS=>THTS
      GWFUZFDAT(Igrid)%THTI=>THTI
      GWFUZFDAT(Igrid)%PETRATE=>PETRATE
      GWFUZFDAT(Igrid)%ROOTDPTH=>ROOTDPTH
      GWFUZFDAT(Igrid)%WCWILT=>WCWILT
      GWFUZFDAT(Igrid)%FINF=>FINF
      GWFUZFDAT(Igrid)%DELSTOR=>DELSTOR
      GWFUZFDAT(Igrid)%UZOLSFLX=>UZOLSFLX
      GWFUZFDAT(Igrid)%HLDUZF=>HLDUZF
      GWFUZFDAT(Igrid)%UZFETOUT=>UZFETOUT
      GWFUZFDAT(Igrid)%GWET=>GWET
      GWFUZFDAT(Igrid)%UZTOTBAL=>UZTOTBAL
      GWFUZFDAT(Igrid)%CUMUZVOL=>CUMUZVOL
      GWFUZFDAT(Igrid)%UZTSRAT=>UZTSRAT
      GWFUZFDAT(Igrid)%THTR=>THTR
      GWFUZFDAT(Igrid)%UZFLWT=>UZFLWT
      GWFUZFDAT(Igrid)%UZSTOR=>UZSTOR
      GWFUZFDAT(Igrid)%UZDPIT=>UZDPIT
      GWFUZFDAT(Igrid)%UZDPST=>UZDPST
      GWFUZFDAT(Igrid)%UZTHIT=>UZTHIT
      GWFUZFDAT(Igrid)%UZTHST=>UZTHST
      GWFUZFDAT(Igrid)%UZSPIT=>UZSPIT
      GWFUZFDAT(Igrid)%UZSPST=>UZSPST
      GWFUZFDAT(Igrid)%UZFLIT=>UZFLIT
      GWFUZFDAT(Igrid)%UZFLST=>UZFLST
      GWFUZFDAT(Igrid)%REJ_INF=>REJ_INF
      GWFUZFDAT(Igrid)%SURFDEP=>SURFDEP
      GWFUZFDAT(Igrid)%RTSOLUTE=>RTSOLUTE
      GWFUZFDAT(Igrid)%GRIDSTOR=>GRIDSTOR
      GWFUZFDAT(Igrid)%FNETEXFIL=>FNETEXFIL
      GWFUZFDAT(Igrid)%NUMCELLS=>NUMCELLS
      GWFUZFDAT(Igrid)%TOTCELLS=>TOTCELLS
      GWFUZFDAT(Igrid)%Iseepsupress=>Iseepsupress
      GWFUZFDAT(Igrid)%IPRCNT=>IPRCNT
      GWFUZFDAT(Igrid)%ITHTIFLG=>ITHTIFLG
      GWFUZFDAT(Igrid)%ITHTRFLG=>ITHTRFLG
      GWFUZFDAT(Igrid)%NeedUzfWaterMover=>NeedUzfWaterMover
      GWFUZFDAT(Igrid)%IETBUD=>IETBUD
      GWFUZFDAT(Igrid)%CUMGWET=>CUMGWET
C
      END SUBROUTINE SGWF2UZF1PSV

      END MODULE GwfUzfModule