C****
C                    ************************
C                    *     OASIS MODULE     *
C                    *     ------------     *
C                    ************************
C****
C***********************************************************************
C     This module belongs to the SCRIP library. It is a modified version
C     of SCRIP 1.4 remap_ditswgt.f in order to weight a neighbour by
C     exp[-1/2 * d^^2/sigma^^2] where d is the distance between the source
C     and the target points and sigma^^2=VAR*dm^^2, where dm is the
C     average distance between the source grid points and VAR is a value
C     given by the user.
C
C     Additional Modifications:
C       - restrict types are written in capital letters
C       - bug line 429: bin_lons(3,n) instead of bin_lons(2,n)
C
C     Modified by            D. Declat,  CERFACS              27.06.2002
C***********************************************************************
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!     this module contains necessary routines for performing an
!     interpolation using a distance-weighted average of n nearest
!     neighbors.
!
!-----------------------------------------------------------------------
!
!     CVS:$Id: remap_gauswgt.f 2826 2010-12-10 11:14:21Z valcke $
!
!     Copyright (c) 1997, 1998 the Regents of the University of
!       California.
!
!     This software and ancillary information (herein called software)
!     called SCRIP is made available under the terms described here.
!     The software has been approved for release with associated
!     LA-CC Number 98-45.
!
!     Unless otherwise indicated, this software has been authored
!     by an employee or employees of the University of California,
!     operator of the Los Alamos National Laboratory under Contract
!     No. W-7405-ENG-36 with the U.S. Department of Energy.  The U.S.
!     Government has rights to use, reproduce, and distribute this
!     software.  The public may copy and use this software without
!     charge, provided that this Notice and any statement of authorship
!     are reproduced on all copies.  Neither the Government nor the
!     University makes any warranty, express or implied, or assumes
!     any liability or responsibility for the use of this software.
!
!     If software is modified to produce derivative works, such modified
!     software should be clearly marked, so as not to confuse it with
!     the version available from Los Alamos National Laboratory.
!
!***********************************************************************

      module remap_gaussian_weight

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

      use kinds_mod     ! defines common data types
      use constants     ! defines common constants
      use grids         ! module containing grid info
      use remap_vars    ! module containing remap info
      USE mod_oasis_flush

      implicit none

!-----------------------------------------------------------------------
!
!     module variables
!
!-----------------------------------------------------------------------

      real (kind=dbl_kind), dimension(:), allocatable, save ::
     &     coslat, sinlat, ! cosine, sine of grid lats (for distance)
     &     coslon, sinlon, ! cosine, sine of grid lons (for distance)
     &     wgtstmp         ! an array to hold the link weight

!***********************************************************************

      contains

!***********************************************************************

      subroutine remap_gauswgt (lextrapdone, num_neighbors, rl_varmul)

!-----------------------------------------------------------------------
!
!     this routine computes the inverse-distance weights for a
!     nearest-neighbor interpolation.
!
!-----------------------------------------------------------------------

      LOGICAL ::
     &           lextrapdone   ! logical, true if EXTRAP done on field

      REAL (kind=real_kind) ::
     $    rl_varmul             ! Gaussian variance

      INTEGER (kind=int_kind) ::
     &       num_neighbors     ! number of neighbours

!-----------------------------------------------------------------------
!
!     local variables
!
!-----------------------------------------------------------------------

      logical (kind=log_kind), dimension(num_neighbors) ::
     &     nbr_mask        ! mask at nearest neighbors

      integer (kind=int_kind) :: n,
     &     dst_add,        ! destination address
     &     nmap            ! index of current map being computed

      integer (kind=int_kind), dimension(num_neighbors) ::
     &     nbr_add         ! source address at nearest neighbors

      real (kind=dbl_kind), dimension(num_neighbors) ::
     &     nbr_dist        ! angular distance four nearest neighbors

      real (kind=dbl_kind) ::
     &     coslat_dst,     ! cos(lat) of destination grid point
     &     coslon_dst,     ! cos(lon) of destination grid point
     &     sinlat_dst,     ! sin(lat) of destination grid point
     &     sinlon_dst,     ! sin(lon) of destination grid point
     &     dist_tot,       ! sum of neighbor distances (for normalizing)
     &     dist_average    ! average distance between the source points
      logical (kind=log_kind) :: ll_allmask
      logical (kind=log_kind), PARAMETER :: ll_nnei=.true.
      real (kind=dbl_kind) ::
     &        distance ,plat,plon,src_latsnn, arg   ! angular distance
      real (kind=dbl_kind), dimension (1) :: wgts_new
      integer (kind=int_kind) :: min_add_out, max_add_out,
     &        srch_add, src_addnn
!-----------------------------------------------------------------------
!
      IF (nlogprt .GE. 2) THEN
         WRITE (UNIT = nulou,FMT = *)' '
         WRITE (UNIT = nulou,FMT = *)'Entering routine remap_gauswgt'
         CALL OASIS_FLUSH_SCRIP(nulou)
      ENDIF
!-----------------------------------------------------------------------
!
!     compute mappings from grid1 to grid2
!
!-----------------------------------------------------------------------

      nmap = 1

      !***
      !*** allocate wgtstmp to be consistent with store_link interface
      !***

      allocate (wgtstmp(num_wts))

      !***
      !*** compute cos, sin of lat/lon on source grid for distance
      !*** calculations
      !***

      allocate (coslat(grid1_size), coslon(grid1_size),
     &          sinlat(grid1_size), sinlon(grid1_size))

      coslat = cos(grid1_center_lat)
      coslon = cos(grid1_center_lon)
      sinlat = sin(grid1_center_lat)
      sinlon = sin(grid1_center_lon)

      !***
      !*** compute the average of the distances between the source points
      !***

      call grid_dist_average(grid1_size,
     &                       coslat, coslon,
     &                       sinlat, sinlon,
     &                       dist_average)
      !***
      !*** loop over destination grid
      !***

      grid_loop1: do dst_add = 1, grid2_size

        if (.not. grid2_mask(dst_add)) cycle grid_loop1

        coslat_dst = cos(grid2_center_lat(dst_add))
        coslon_dst = cos(grid2_center_lon(dst_add))
        sinlat_dst = sin(grid2_center_lat(dst_add))
        sinlon_dst = sin(grid2_center_lon(dst_add))

        !***
        !*** find nearest grid points on source grid and
        !*** distances to each point
        !***

        call grid_search_nbrg(nbr_add, nbr_dist,
     &                        min_add_out, max_add_out,
     &                        grid2_center_lat(dst_add),
     &                        grid2_center_lon(dst_add),
     &                        coslat_dst, coslon_dst,
     &                        sinlat_dst, sinlon_dst,
     &                        bin_addr1,
     &                        dist_average,  num_neighbors, rl_varmul)

        !***
        !*** compute weights based on inverse distance
        !*** if mask is false, eliminate those points
        !***
        src_addnn = zero
        dist_tot = zero
        do n=1,num_neighbors
          if ((grid1_mask(nbr_add(n))) .or.
     &        (.not. grid1_mask(nbr_add(n)) .and. lextrapdone)) THEN
            nbr_dist(n) = one/nbr_dist(n)
            dist_tot = dist_tot + nbr_dist(n)
            nbr_mask(n) = .true.
          else
            nbr_mask(n) = .false.
          endif
        end do

        !***
        !*** normalize weights and store the link
        !***

        do n=1,num_neighbors
          if (nbr_mask(n)) then
            wgtstmp(1) = nbr_dist(n)/dist_tot
            call store_link_nbr(nbr_add(n), dst_add, wgtstmp, nmap)
            grid2_frac(dst_add) = one
          endif
        end do
        IF (ll_nnei) THEN
            ll_allmask= .true.
            do n=1,num_neighbors
              if (nbr_mask(n)) then
                  ll_allmask=.false.
              endif
            end do
            if ( ll_allmask) THEN
                src_latsnn = bignum
                do srch_add = min_add_out,max_add_out
                  if (grid1_mask(srch_add) .or.
     &                (.not. grid1_mask(srch_add)
     &                .and. lextrapdone)) THEN
                      arg = coslat_dst*cos(grid1_center_lat(srch_add))*
     &                (coslon_dst*cos(grid1_center_lon(srch_add)) +
     &                sinlon_dst*sin(grid1_center_lon(srch_add)))+
     &                sinlat_dst*sin(grid1_center_lat(srch_add))
                      IF (arg < -1.0d0) THEN
                          arg = -1.0d0
                      ELSE IF (arg > 1.0d0) THEN
                          arg = 1.0d0
                      END IF
                      distance=acos(arg)

                      if (distance < src_latsnn) then
                          src_addnn = srch_add
                          src_latsnn = distance
                      endif
                  endif
                end do
                IF (nlogprt .GE. 2) THEN
                    WRITE(nulou,*)'ll_allmask=true and src_addnn= '
     &                  ,src_addnn
                    CALL OASIS_FLUSH_SCRIP(nulou)
                ENDIF
                wgts_new(1) = 1.
                grid2_frac(dst_add) = one
                call store_link_nbr(src_addnn,dst_add ,wgts_new, nmap)
            endif
        endif

      end do grid_loop1

      deallocate (coslat, coslon, sinlat, sinlon)

!-----------------------------------------------------------------------
!
!     compute mappings from grid2 to grid1 if necessary
!
!-----------------------------------------------------------------------

      if (num_maps > 1) then

      nmap = 2

      !***
      !*** compute cos, sin of lat/lon on source grid for distance
      !*** calculations
      !***

      allocate (coslat(grid2_size), coslon(grid2_size),
     &          sinlat(grid2_size), sinlon(grid2_size))

      coslat = cos(grid2_center_lat)
      coslon = cos(grid2_center_lon)
      sinlat = sin(grid2_center_lat)
      sinlon = sin(grid2_center_lon)

      !***
      !*** compute the average of the distances between the source points
      !***

      call grid_dist_average(grid2_size,
     &                       coslat, coslon,
     &                       sinlat, sinlon,
     &                       dist_average)

      !***
      !*** loop over destination grid
      !***

      grid_loop2: do dst_add = 1, grid1_size

        if (.not. grid1_mask(dst_add)) cycle grid_loop2

        coslat_dst = cos(grid1_center_lat(dst_add))
        coslon_dst = cos(grid1_center_lon(dst_add))
        sinlat_dst = sin(grid1_center_lat(dst_add))
        sinlon_dst = sin(grid1_center_lon(dst_add))

        !***
        !*** find four nearest grid points on source grid and
        !*** distances to each point
        !***

        call grid_search_nbrg(nbr_add, nbr_dist,
     &                        min_add_out, max_add_out,
     &                        grid1_center_lat(dst_add),
     &                        grid1_center_lon(dst_add),
     &                        coslat_dst, coslon_dst,
     &                        sinlat_dst, sinlon_dst,
     &                        bin_addr2,
     &                        dist_average, num_neighbors, rl_varmul)

        !***
        !*** compute weights based on inverse distance
        !*** if mask is false, eliminate those points
        !***

        dist_tot = zero
        do n=1,num_neighbors
          if (grid2_mask(nbr_add(n))) then
            nbr_dist(n) = one/nbr_dist(n)
            dist_tot = dist_tot + nbr_dist(n)
            nbr_mask(n) = .true.
          else
            nbr_mask(n) = .false.
          endif
        end do

        !***
        !*** normalize weights and store the link
        !***

        do n=1,num_neighbors
          if (nbr_mask(n)) then
            wgtstmp(1) = nbr_dist(n)/dist_tot
            call store_link_nbr(dst_add, nbr_add(n), wgtstmp, nmap)
            grid1_frac(dst_add) = one
          endif
        end do

        IF (ll_nnei) THEN
            ll_allmask= .true.
            do n=1,num_neighbors
              if (nbr_mask(n)) then
                  ll_allmask=.false.
              endif
            end do
            if ( ll_allmask) then
                PRINT*, 'll_allmask true',src_addnn
                src_latsnn = bignum
                do srch_add = min_add_out,max_add_out
                  if (grid2_mask(srch_add) .or.
     &                (.not. grid2_mask(srch_add)
     &                .and. lextrapdone)) THEN
                      arg = coslat_dst*cos(grid2_center_lat(srch_add))*
     &                (coslon_dst*cos(grid2_center_lon(srch_add)) +
     &                sinlon_dst*sin(grid2_center_lon(srch_add)))+
     &                sinlat_dst*sin(grid2_center_lat(srch_add))
                      IF (arg < -1.0d0) THEN
                          arg = -1.0d0
                      ELSE IF (arg > 1.0d0) THEN
                          arg = 1.0d0
                      END IF
                      distance=acos(arg)

                      if (distance < src_latsnn) then
                          src_addnn = srch_add
                          src_latsnn = distance
                      endif
                  endif
                end do
                wgts_new = 1.
                grid1_frac(dst_add) = one
                call store_link_nbr(dst_add, src_addnn, wgts_new, nmap)
            endif
        endif
      end do grid_loop2

      deallocate (coslat, coslon, sinlat, sinlon)

      endif

      deallocate(wgtstmp)
!
      IF (nlogprt .GE. 2) THEN
         WRITE (UNIT = nulou,FMT = *)' '
         WRITE (UNIT = nulou,FMT = *)'Leaving routine remap_gauswgt'
         CALL OASIS_FLUSH_SCRIP(nulou)
      ENDIF
!
!-----------------------------------------------------------------------

      end subroutine remap_gauswgt

!***********************************************************************

      subroutine grid_search_nbrg(nbr_add, nbr_dist, min_add, max_add,
     &               plat, plon,
     &               coslat_dst, coslon_dst, sinlat_dst, sinlon_dst,
     &               src_bin_add, dst_average,
     $               num_neighbors, rl_varmul)

!-----------------------------------------------------------------------
!
!     this routine finds the closest num_neighbor points to a search
!     point and computes a distance to each of the neighbors.
!
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
!
!     input variables
!
!-----------------------------------------------------------------------

      integer (kind=int_kind), dimension(:,:), intent(in) ::
     &        src_bin_add ! search bins for restricting search

      real (kind=dbl_kind), intent(in) ::
     &        plat,         ! latitude  of the search point
     &        plon,         ! longitude of the search point
     &        coslat_dst,   ! cos(lat)  of the search point
     &        coslon_dst,   ! cos(lon)  of the search point
     &        sinlat_dst,   ! sin(lat)  of the search point
     &        sinlon_dst,   ! sin(lon)  of the search point
     &        dst_average   ! average distance between the source points

      REAL (kind=real_kind), intent(in) ::
     &        rl_varmul     ! Gaussian variance

      INTEGER (kind=int_kind) ::
     &       num_neighbors     ! number of neighbours

!-----------------------------------------------------------------------
!
!     output variables
!
!-----------------------------------------------------------------------

      integer (kind=int_kind), dimension(num_neighbors), intent(out) ::
     &        nbr_add  ! address of each of the closest points

      real (kind=dbl_kind), dimension(num_neighbors), intent(out) ::
     &        nbr_dist ! distance to each of the closest points

      integer (kind=int_kind),intent(out) :: min_add, max_add

!-----------------------------------------------------------------------
!
!     local variables
!
!-----------------------------------------------------------------------

      integer (kind=int_kind) :: n, nmax, nadd, nchk, ! dummy indices
     &        nm1, np1, i, j, ip1, im1, jp1, jm1

      real (kind=dbl_kind) ::
     &        distance, arg      ! angular distance

      real (kind=dbl_kind) ::
     &        variance      ! variance for the gaussian FUNCTION

!-----------------------------------------------------------------------
!
!     loop over source grid and find nearest neighbors
!
!-----------------------------------------------------------------------

      !***
      !*** restrict the search using search bins
      !*** expand the bins to catch neighbors
      !***

      select case (restrict_type)
      case('LATITUDE')

        do n=1,num_srch_bins
          if (plat >= bin_lats(1,n) .and. plat <= bin_lats(2,n)) then
            min_add = src_bin_add(1,n)
            max_add = src_bin_add(2,n)

            nm1 = max(n-1,1)
            np1 = min(n+1,num_srch_bins)

            min_add = min(min_add,src_bin_add(1,nm1))
            max_add = max(max_add,src_bin_add(2,nm1))
            min_add = min(min_add,src_bin_add(1,np1))
            max_add = max(max_add,src_bin_add(2,np1))
          endif
        end do

      case('LATLON')

        n = 0
        nmax = nint(sqrt(real(num_srch_bins)))
        do j=1,nmax
        jp1 = min(j+1,nmax)
        jm1 = max(j-1,1)
        do i=1,nmax
          ip1 = min(i+1,nmax)
          im1 = max(i-1,1)

          n = n+1
          if (plat >= bin_lats(1,n) .and. plat <= bin_lats(2,n) .and.
     &        plon >= bin_lons(1,n) .and. plon <= bin_lons(2,n)) then
            min_add = src_bin_add(1,n)
            max_add = src_bin_add(2,n)

            nm1 = (jm1-1)*nmax + im1
            np1 = (jp1-1)*nmax + ip1
            nm1 = max(nm1,1)
            np1 = min(np1,num_srch_bins)

            min_add = min(min_add,src_bin_add(1,nm1))
            max_add = max(max_add,src_bin_add(2,nm1))
            min_add = min(min_add,src_bin_add(1,np1))
            max_add = max(max_add,src_bin_add(2,np1))
          endif
        end do
        end do

      end select

      !***
      !*** initialize distance and address arrays
      !***

      nbr_add = 0
      nbr_dist = bignum
      variance = rl_varmul*dst_average*dst_average
      do nadd=min_add,max_add

        !***
        !*** find distance to this point
        !***
        arg = sinlat_dst*sinlat(nadd) +
     &        coslat_dst*coslat(nadd)*
     &       (coslon_dst*coslon(nadd) +
     &        sinlon_dst*sinlon(nadd))
        IF (arg < -1.0d0) THEN
            arg = -1.0d0
        ELSE IF (arg > 1.0d0) THEN
            arg = 1.0d0
        END IF
        distance = acos(arg)
        !distance = min(500., distance) !ts-sv
        !distance = exp(.5*distance*distance/variance)
        !***
        !*** store the address and distance if this is one of the
        !*** smallest four so far
        !***

        check_loop: do nchk=1,num_neighbors
          if (distance .lt. nbr_dist(nchk)) THEN
            do n=num_neighbors,nchk+1,-1
              nbr_add(n) = nbr_add(n-1)
              nbr_dist(n) = nbr_dist(n-1)
            end do
            nbr_add(nchk) = nadd
            nbr_dist(nchk) = distance
            exit check_loop
          endif
        end do check_loop

      end do

      exp_loop: do nchk=1,num_neighbors
          nbr_dist(nchk) =
     &     exp(.5*nbr_dist(nchk)*nbr_dist(nchk)/variance)
      end do exp_loop

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

      end subroutine grid_search_nbrg

!***********************************************************************

      subroutine store_link_nbr(add1, add2, weights, nmap)

!-----------------------------------------------------------------------
!
!     this routine stores the address and weight for this link in
!     the appropriate address and weight arrays and resizes those
!     arrays if necessary.
!
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
!
!     input variables
!
!-----------------------------------------------------------------------

      integer (kind=int_kind), intent(in) ::
     &        add1,  ! address on grid1
     &        add2,  ! address on grid2
     &        nmap   ! identifies which direction for mapping

      real (kind=dbl_kind), dimension(:), intent(in) ::
     &        weights ! array of remapping weights for this link

!-----------------------------------------------------------------------
!
!     increment number of links and check to see if remap arrays need
!     to be increased to accomodate the new link.  then store the
!     link.
!
!-----------------------------------------------------------------------

      select case (nmap)
      case(1)

        num_links_map1  = num_links_map1 + 1

        if (num_links_map1 > max_links_map1)
     &     call resize_remap_vars(1,resize_increment)

        grid1_add_map1(num_links_map1) = add1
        grid2_add_map1(num_links_map1) = add2
        wts_map1    (:,num_links_map1) = weights

      case(2)

        num_links_map2  = num_links_map2 + 1

        if (num_links_map2 > max_links_map2)
     &     call resize_remap_vars(2,resize_increment)

        grid1_add_map2(num_links_map2) = add1
        grid2_add_map2(num_links_map2) = add2
        wts_map2    (:,num_links_map2) = weights

      end select

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

      end subroutine store_link_nbr

!***********************************************************************

      subroutine grid_dist_average(grid_size,
     &                             coslat_grid, coslon_grid,
     &                             sinlat_grid, sinlon_grid,
     &                             dist_average)

!-----------------------------------------------------------------------
!
!     this routine computes the average distance between the points of a
!     grid.
!
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
!
!     output variables
!
!-----------------------------------------------------------------------

      real (kind=dbl_kind), intent(out) ::
     &        dist_average ! distance to each of the closest points

!-----------------------------------------------------------------------
!
!     input variables
!
!-----------------------------------------------------------------------

      integer (kind=int_kind), intent(in) ::
     &        grid_size

      real (kind=dbl_kind), dimension(:), intent(in) ::
     &        coslat_grid,   ! cos(lat)  of the grid points
     &        coslon_grid,   ! cos(lon)  of the grid points
     &        sinlat_grid,   ! sin(lat)  of the grid points
     &        sinlon_grid    ! sin(lon)  of the grid points
      REAL (kind=dbl_kind) :: arg

!-----------------------------------------------------------------------
!
!     local variables
!
!-----------------------------------------------------------------------

      integer (kind=int_kind) :: i
!
      IF (nlogprt .GE. 2) THEN
         WRITE (UNIT = nulou,FMT = *)' '
         WRITE (UNIT = nulou,FMT = *)
     &       'Entering routine remap_dist_average'
         CALL OASIS_FLUSH_SCRIP(nulou)
      ENDIF
!
!-----------------------------------------------------------------------
!
!     compute the distance over the grid and average
!
!-----------------------------------------------------------------------

      dist_average = 0.0
      DO i = 1, grid_size
        IF (i .eq. 1) THEN
            arg = sinlat_grid(grid_size)*sinlat_grid(i) +
     &          coslat_grid(grid_size)*coslat_grid(i)*
     &          (coslon_grid(grid_size)*coslon_grid(i) +
     &          sinlon_grid(grid_size)*sinlon_grid(i))
            IF (arg < -1.0d0) THEN
                arg = -1.0d0
            ELSE IF (arg > 1.0d0) THEN
                arg = 1.0d0
            END IF
            dist_average = dist_average + acos(arg)

            arg = sinlat_grid(i)*sinlat_grid(i+1) +
     &          coslat_grid(i)*coslat_grid(i+1)*
     &          (coslon_grid(i)*coslon_grid(i+1) +
     &          sinlon_grid(i)*sinlon_grid(i+1))
            IF (arg < -1.0d0) THEN
                arg = -1.0d0
            ELSE IF (arg > 1.0d0) THEN
                arg = 1.0d0
            END IF
            dist_average = dist_average + acos(arg)

        ELSE IF (i .eq. grid_size) THEN
            arg = sinlat_grid(i-1)*sinlat_grid(i) +
     &          coslat_grid(i-1)*coslat_grid(i)*
     &          (coslon_grid(i-1)*coslon_grid(i) +
     &          sinlon_grid(i-1)*sinlon_grid(i))
            IF (arg < -1.0d0) THEN
                arg = -1.0d0
            ELSE IF (arg > 1.0d0) THEN
                arg = 1.0d0
            END IF
            dist_average = dist_average + acos(arg)

            arg = sinlat_grid(i)*sinlat_grid(1) +
     &          coslat_grid(i)*coslat_grid(1)*
     &          (coslon_grid(i)*coslon_grid(1) +
     &          sinlon_grid(i)*sinlon_grid(1))
            IF (arg < -1.0d0) THEN
                arg = -1.0d0
            ELSE IF (arg > 1.0d0) THEN
                arg = 1.0d0
            END IF
            dist_average = dist_average + acos(arg)

        ELSE
            arg = sinlat_grid(i-1)*sinlat_grid(i) +
     &          coslat_grid(i-1)*coslat_grid(i)*
     &          (coslon_grid(i-1)*coslon_grid(i) +
     &          sinlon_grid(i-1)*sinlon_grid(i))
            IF (arg < -1.0d0) THEN
                arg = -1.0d0
            ELSE IF (arg > 1.0d0) THEN
                arg = 1.0d0
            END IF
            dist_average = dist_average + acos(arg)

            arg = sinlat_grid(i)*sinlat_grid(i+1) +
     &          coslat_grid(i)*coslat_grid(i+1)*
     &          (coslon_grid(i)*coslon_grid(i+1) +
     &          sinlon_grid(i)*sinlon_grid(i+1))
            IF (arg < -1.0d0) THEN
                arg = -1.0d0
            ELSE IF (arg > 1.0d0) THEN
                arg = 1.0d0
            END IF
            dist_average = dist_average + acos(arg)
        END IF
      END DO
      dist_average = dist_average / (2*grid_size)
!
      IF (nlogprt .GE. 2) THEN
         WRITE (UNIT = nulou,FMT = *)' '
         WRITE (UNIT = nulou,FMT = *)
     &       'Leaving routine remap_dist_average'
         CALL OASIS_FLUSH_SCRIP(nulou)
      ENDIF
!
      END subroutine grid_dist_average

!***********************************************************************

      end module remap_gaussian_weight

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!


module parameters
! This module contains all the modifiable parameters (except nz & pi below)
! for the suite of casl f90 files.
 !Initial time loop from which to begin the simulation:
integer,parameter:: loopinit=0
 !loopinit > 0 may be used for continuing a simulation (see replace below)
 !Logical to indicate replacing existing data with the output of a new
 !simulation or to append to existing data:
logical,parameter:: replace=.false.
 !Number of fluid layers (here always 2):
integer,parameter:: nz=2
! Number of grid boxes in the x & y directions (inversion grid):
integer,parameter:: nx=128,ny=64
 !Number of contours used for representing PV in either layer:
integer,parameter:: ncontq=80
! ncontq : used to compute the PV contour interval from
! dq = (qq_max-qq_min)/ncontq (in each layer)
! Simulation time length etc..
double precision,parameter:: tsim=750.0
double precision,parameter:: tgsave=1.0,tcsave=50.0
! tsim : total duration of the simulation
! tgsave : grid data save time increment
! tcsave : contour data save time increment (approximate)
! ***NOTE*** tcsave should always be an integer multiple of tgsave
 !The number pi (*** non-modifiable ***):
double precision,parameter:: pi=3.141592653589793238462643383279502884197169399375105820974944592307816
!***Physical parameters:***
double precision,parameter:: alpha=1.0,h1=0.50,kdbar=20.0
double precision,parameter:: ellx=6.28318530717958647692
double precision,parameter:: elly=3.14159265358979323846
double precision,parameter:: ymin=-1.57079632679489661923
double precision,parameter:: beta=2.51327412287183459076
double precision,parameter:: u1bot=0.0,u1top=0.0
double precision,parameter:: u2bot=0.0,u2top=0.0
double precision,parameter:: rtherm1=0.0
double precision,parameter:: rtherm2=0.0
double precision,parameter:: rekman=0.0
double precision,parameter:: eirate=0.0
double precision,parameter:: vorvor=1.0
double precision,parameter:: rheton=0.1
double precision,parameter:: thdmax=0.0
double precision,parameter:: sponlen=3.14159265358979323846
integer,parameter:: iseed=2583211,mod1bc=0
logical,parameter:: topogr=.false.
! h1 : fractional thickness of the lower layer
! kdbar : f*sqrt{(H1+H2)/(g*H1*H2*(1-alpha))} where H1 & H2 are the
! layer depths, f is the Coriolis frequency and g is gravity
! ellx : domain width in x (periodic, centred at 0)
! elly : domain width in y
! ymin : minimum value of y (ymax = ymin + elly; see constants.f90)
! beta : planetary vorticity gradient
! u1bot : zonal mean mode 1 (smaller kd) velocity at y = ymin
! u1top : zonal mean mode 1 (smaller kd) velocity at y = ymax
! *** NOTE: these are not used if kd = kd1 = 0 ***
! u2bot : zonal mean mode 2 (larger kd) velocity at y = ymin
! u2top : zonal mean mode 2 (larger kd) velocity at y = ymax
! rtherm1: thermal damping rate (1/tau_1) of lower layer thickness
! rtherm2: thermal damping rate (1/tau_2) of upper layer thickness
! rekman : Ekman damping rate (1/tau_E)
! eirate : enstrophy input rate (via heton pairs of point vortices
! which are converted to gridded vorticity and added to qd)
! vorvor : the mean vorticity magnitude associated with the point
! vortex upon placement on the grid
! rheton : the radius of each of the pair of vortices added as a heton
! iseed : seed for initialising point vortex forcing
! topogr : logical variable to indicate presence of topography
! mod1bc : boundary condition used on mode 1 when kd1 > 0;
! use 1 to implement fixed zonal mean velocities u1bot & u1top;
! use 2 to implement zero average streamfunction and velocity;
! (not used if kd1 = 0)
! thdmax : max rate of thermal damping at the domain edges
! sponlen: sponge length of vorticity damping; the function used
! is defined in casl.f90 (see "sponge")
!----------------------------------------------------------------
end module


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!  USER FUNCTIONS FOR TETE ROUSSE CAVITY PROBLEM
!
!
!!!!!!!!!!!!!!!!!!!
! Function InterpolateDEM
!!------------------------------------------------------------------------------!!
FUNCTION InterpolateDEM (x, y, xb, yb, zb, Nbx, Nby, xb0, yb0, lbx, lby) RESULT(zbed)
   USE DefUtils
   IMPLICIT NONE
   INTEGER :: imin, Npt, t
   INTEGER :: NMAX, i, j, Nb, Nbx, Nby, ib, ix, iy
   REAL(KIND=dp) :: x, y, zbed, xb0, yb0, x1, x2, y1, y2, zi(2,2)
   REAL(KIND=dp) :: R, Rmin, lbx, lby, dbx, dby
   REAL(KIND=dp) :: xb(Nbx*Nby), yb(Nbx*Nby), zb(Nbx*Nby)

! Find zbed for that point from the Bedrock MNT
        dbx = lbx / (Nbx-1.0)
        dby = lby / (Nby-1.0)
        Nb = Nbx*Nby

        ix = INT((x-xb0)/dbx)+1
        iy = INT((y-yb0)/dbx)+1
        ib = Nbx * (iy - 1) + ix

        x1 = xb(ib)
        x2 = xb(ib+1)
        y1 = yb(ib)
        y2 = yb(ib + Nbx)

        zi(1,1) = zb(ib)
        zi(2,1) = zb(ib+1)
        zi(2,2) = zb(ib + Nbx + 1)
        zi(1,2) = zb(ib + Nbx)

        IF ((zi(1,1)<-9990.0).OR.(zi(1,2)<-9990.0).OR.(zi(2,1)<-9990.0).OR.(zi(2,2)<-9990.0)) THEN
           IF ((zi(1,1)<-9990.0).AND.(zi(1,2)<-9990.0).AND.(zi(2,1)<-9990.0).AND.(zi(2,2)<-9990.0)) THEN
           ! Find the nearest point available
             Rmin = 9999.0
             DO i=1, Nb
               IF (zb(i)>0.0) THEN
                 R = SQRT((x-xb(i))**2.0+(y-yb(i))**2.0)
                 IF (R<Rmin) THEN
                   Rmin = R
                   imin = i
                 END IF
               END IF
             END DO
            zbed = zb(imin)

           ELSE
            ! Mean value over the available data
             zbed = 0.0
             Npt = 0
             DO i=1, 2
               DO J=1, 2
                  IF (zi(i,j) > 0.0) THEN
                     zbed = zbed + zi(i,j)
                     Npt = Npt + 1
                  END IF
               END DO
             END DO
             zbed = zbed / Npt

           END IF
        ELSE
          zbed = (zi(1,1)*(x2-x)*(y2-y)+zi(2,1)*(x-x1)*(y2-y)+zi(1,2)*(x2-x)*(y-y1)+zi(2,2)*(x-x1)*(y-y1))/(dbx*dby)
        END IF
END FUNCTION InterpolateDEM

!!!!!!!!!!!!!!!!!!!
! User Function TopSurface
! Return the TopfaceElevation from the DEM
! Make sure the top surface is above the bedrock...
!!------------------------------------------------------------------------------!!
FUNCTION TopSurface ( Model, nodenumber, znode) RESULT(Zsurf)
   USE types
   USE CoordinateSystems
   USE SolverUtils
   USE ElementDescription
   USE DefUtils
   IMPLICIT NONE
   TYPE(Model_t) :: Model
   TYPE(Solver_t), TARGET :: Solver
   INTEGER :: nodenumber
   REAL(KIND=dp) :: znode, Zbed, zsurf
   INTEGER :: imin, Npt, t
   INTEGER :: NMAX, i, j,Nb, Nbx, Nby, ib, ix, iy
   INTEGER :: Ns, Nsx, Nsy
   REAL(KIND=dp) :: x, y, z, xb0, yb0, x1, x2, y1, y2, zi(2,2)
   REAL(KIND=dp) :: xs0, ys0
   REAL(KIND=dp) :: R, Rmin, lbx, lby
   REAL(KIND=dp) :: lsx, lsy, InterpolateDEM
   REAL(KIND=dp), ALLOCATABLE :: xb(:), yb(:), zb(:)
   REAL(KIND=dp), ALLOCATABLE :: xs(:), ys(:), zs(:)
   LOGICAL :: FirstTime=.True.

   SAVE FirstTime
   SAVE xb, yb, zb, xs, ys, zs

   Nsx = 268
   Nsy = 118
   xs0 = 947700.0d0
   ys0 = 2104850.0d0
   lsx = 800.0
   lsy = 350.0

   Ns = Nsx * Nsy

   Nbx = 301
   Nby = 176
   xb0 = 947700.0d0
   yb0 = 2104850.0d0
   lbx = 600.0
   lby = 350.0

   Nb = Nbx * Nby

   IF (FirstTime) THEN
        FirstTime = .False.
        OPEN(10,file="./PROG/DEM_TR_surf.dat")
        ALLOCATE(xs(Ns), ys(Ns), zs(Ns))
        READ(10,*)(xs(i), ys(i), zs(i), i=1,Ns)
        CLOSE(10)

        OPEN(10,file="./PROG/DEM_TR_cavity.dat")
        ALLOCATE(xb(Nb), yb(Nb), zb(Nb))
        READ(10,*)(xb(i), yb(i), zb(i), i=1,Nb)
        CLOSE(10)
   END IF

! Compute zbed for that point (x,y)

        x = Model % Nodes % x (nodenumber)
        y = Model % Nodes % y (nodenumber)

        zbed = InterpolateDEM(x,y,xb,yb,zb,Nbx,Nby,xb0,yb0,lbx,lby)
        zsurf = InterpolateDEM(x,y,xs,ys,zs,Nsx,Nsy,xs0,ys0,lsx,lsy)
        IF (zsurf-zbed < EPSILON(zsurf)) zsurf = zbed + 1.0
END FUNCTION TopSurface

!!!!!!!!!!!!!!!!!!!
! User Function BottomSurface
! Return the BottomSurfaceElevation from the DEM
!!------------------------------------------------------------------------------!!
FUNCTION BottomSurface ( Model, nodenumber, znode) RESULT(Zbed)
   USE types
   USE CoordinateSystems
   USE SolverUtils
   USE ElementDescription
   USE DefUtils
   IMPLICIT NONE
   TYPE(Model_t) :: Model
   TYPE(Solver_t), TARGET :: Solver
   INTEGER :: nodenumber
   REAL(KIND=dp) :: znode, Zbed
   INTEGER :: imin, Npt, t
   INTEGER :: NMAX, i, j, Nb, Nbx, Nby
   REAL(KIND=dp) :: x, y, z, xb0, yb0
   REAL(KIND=dp) :: R, Rmin, lbx, lby, InterpolateDEM
   REAL(KIND=dp), ALLOCATABLE :: xb(:), yb(:), zb(:)
   LOGICAL :: FirstTime=.True.

   SAVE FirstTime
   SAVE xb, yb, zb

   Nbx = 301
   Nby = 176
   xb0 = 947700.0d0
   yb0 = 2104850.0d0
   lbx = 600.0
   lby = 350.0

   Nb = Nbx * Nby

   IF (FirstTime) THEN
        FirstTime = .False.
        OPEN(10,file="./PROG/DEM_TR_cavity.dat")
        ALLOCATE(xb(Nb), yb(Nb), zb(Nb))
        READ(10,*)(xb(i), yb(i), zb(i), i=1,Nb)
        CLOSE(10)
   END IF

! Compute zbed for that point (x,y)

        x = Model % Nodes % x (nodenumber)
        y = Model % Nodes % y (nodenumber)

        zbed = InterpolateDEM(x,y,xb,yb,zb,Nbx,Nby,xb0,yb0,lbx,lby)
END FUNCTION BottomSurface

!!!!!!!!!!!!!!!!!!!
! User Function Bedrock
! Return the bedrock altitude for a given nodes
!!------------------------------------------------------------------------------!!
FUNCTION Bedrock ( Model, nodenumber, znode) RESULT(Zbed)
   USE types
   USE CoordinateSystems
   USE SolverUtils
   USE ElementDescription
   USE DefUtils
   IMPLICIT NONE
   TYPE(Model_t) :: Model
   TYPE(Solver_t), TARGET :: Solver
   INTEGER :: nodenumber
   REAL(KIND=dp) :: znode, Zbed
   INTEGER :: imin, Npt, t
   INTEGER :: NMAX, i, j, Nb, Nbx, Nby
   REAL(KIND=dp) :: x, y, z, xb0, yb0
   REAL(KIND=dp) :: R, Rmin, lbx, lby, InterpolateDEM
   REAL(KIND=dp), ALLOCATABLE :: xb(:), yb(:), zb(:)
   LOGICAL :: FirstTime=.True.

   SAVE FirstTime
   SAVE xb, yb, zb

   Nbx = 301
   Nby = 176
   xb0 = 947700.0d0
   yb0 = 2104850.0d0
   lbx = 600.0
   lby = 350.0

   Nb = Nbx * Nby

   IF (FirstTime) THEN
        FirstTime = .False.
        OPEN(10,file="./PROG/DEM_TR_bed.dat")
        ALLOCATE(xb(Nb), yb(Nb), zb(Nb))
        READ(10,*)(xb(i), yb(i), zb(i), i=1,Nb)
        CLOSE(10)
   END IF

! Compute zbed for that point (x,y)

        x = Model % Nodes % x (nodenumber)
        y = Model % Nodes % y (nodenumber)
        zbed = InterpolateDEM(x,y,xb,yb,zb,Nbx,Nby,xb0,yb0,lbx,lby)
END FUNCTION Bedrock

!!!!!!!!!!!!!!!!!!!
! User Function MaskCavity
! Mask = -1 for cavity nodes (zb > b), Mask = 1 for bedrock (zb=b)
!!------------------------------------------------------------------------------!!
FUNCTION MaskCavity ( Model, nodenumber, znode) RESULT(Mask)
   USE types
   USE CoordinateSystems
   USE SolverUtils
   USE ElementDescription
   USE DefUtils
   IMPLICIT NONE
   TYPE(Model_t) :: Model
   TYPE(Solver_t), TARGET :: Solver
   INTEGER :: nodenumber
   REAL(KIND=dp) :: znode, Mask
   INTEGER :: imin, Npt, t
   INTEGER :: NMAX, i, j,Nb, Nbx, Nby
   REAL(KIND=dp) :: x, y, z, xb0, yb0
   REAL(KIND=dp) :: R, Rmin, lbx, lby, zbed, InterpolateDEM
   REAL(KIND=dp), ALLOCATABLE :: xb(:), yb(:), zb(:)
   LOGICAL :: FirstTime=.True.

   SAVE FirstTime
   SAVE xb, yb, zb

   Nbx = 301
   Nby = 176
   xb0 = 947700.0d0
   yb0 = 2104850.0d0
   lbx = 600.0
   lby = 350.0

   Nb = Nbx * Nby

   IF (FirstTime) THEN
        FirstTime = .False.
        OPEN(10,file="./PROG/DEM_TR_bed.dat")
        ALLOCATE(xb(Nb), yb(Nb), zb(Nb))
        READ(10,*)(xb(i), yb(i), zb(i), i=1,Nb)
        CLOSE(10)
   END IF

! Compute zbed for that point (x,y)

        x = Model % Nodes % x (nodenumber)
        y = Model % Nodes % y (nodenumber)

        zbed = InterpolateDEM(x,y,xb,yb,zb,Nbx,Nby,xb0,yb0,lbx,lby)

   znode = Model % Nodes % z(nodenumber)
   IF (znode > Zbed+0.1) THEN
      Mask = -1.0
   ELSE
      Mask = 1.0
   END IF
END FUNCTION MaskCavity


!-----------------------------------------------------------------------
      subroutine ppiclf_user_SetYdot
!
      implicit none
!
#include "PPICLF.h"
!
! Internal:
!
      real*8 rpi, rmu, rhof, rmass, vmag, dp, rep, rphip, rphif,
     >       beta, reps, cds, fqsx, fqsy, fbx, fby, fcx, fcy,
     >       beta1, beta2, rs, rdum

      integer*4 i
!
      rpi  = 4.0*atan(1.0)
      rmu  = 1.8E-5
      rhof = 1.205

! evaluate ydot
      do i=1,ppiclf_npart
         ! particle mass
         rmass = ppiclf_rprop(PPICLF_R_JVOLP,i)
     >          *ppiclf_rprop(PPICLF_R_JRHOP,i)

         ! Gidaspow drag
         vmag  = sqrt((ppiclf_rprop(PPICLF_R_JUX,i)
     >                 -ppiclf_y(PPICLF_JVX,i))**2
     >               +(ppiclf_rprop(PPICLF_R_JUY,i)
     >                 -ppiclf_y(PPICLF_JVY,i))**2)
         dp    = ppiclf_rprop(PPICLF_R_JDP,i)
         rep   = vmag*dp*rhof/rmu
         rphip = ppiclf_rprop(PPICLF_R_JPHIP,i)
         rphif = 1.0-ppiclf_rprop(PPICLF_R_JPHIP,i)

         if (rphip .gt. 0.2) then
            beta = 150.*rphip*rmu/rphif/dp**2 + 1.75*rhof*vmag/dp
         else
            reps = rep*rphif
            reps = max(reps,1E-1)
            if (reps .le. 1E3) then
               cds = 24.0/reps*(1.0+0.15*reps**(0.687))
            else
               cds = 0.44
            endif
            beta = 0.75*cds*rphif*rhof*vmag*rphif**(-2.65)/dp
         endif

         fqsx = beta*ppiclf_rprop(PPICLF_R_JVOLP,i)
     >          *(ppiclf_rprop(PPICLF_R_JUX,i)-ppiclf_y(PPICLF_JVX,i))
         fqsy = beta*ppiclf_rprop(PPICLF_R_JVOLP,i)
     >          *(ppiclf_rprop(PPICLF_R_JUY,i)-ppiclf_y(PPICLF_JVY,i))

         ! Gravity
         fbx  = 0.0
         fby  = -9.8*rmass

         ! Collision search
         call ppiclf_solve_NearestNeighbor(i)

         fcx  = ppiclf_ydotc(PPICLF_JVX,i)
         fcy  = ppiclf_ydotc(PPICLF_JVY,i)

         ! set ydot for all PPICLF_SLN number of equations
         ppiclf_ydot(PPICLF_JX ,i) = ppiclf_y(PPICLF_JVX,i)
         ppiclf_ydot(PPICLF_JY ,i) = ppiclf_y(PPICLF_JVY,i)
         ppiclf_ydot(PPICLF_JVX,i) = (fbx+fqsx+fcx)/rmass
         ppiclf_ydot(PPICLF_JVY,i) = (fby+fqsy+fcy)/rmass

         ppiclf_ydotc(PPICLF_JVX,i) = -fqsx
         ppiclf_ydotc(PPICLF_JVY,i) = -fqsy
      enddo
! evaluate ydot

      return
      end
!-----------------------------------------------------------------------
      subroutine ppiclf_user_MapProjPart(map,y,ydot,ydotc,rprop)
!
      implicit none
!
! Input:
!
      real*8 y    (PPICLF_LRS)
      real*8 ydot (PPICLF_LRS)
      real*8 ydotc(PPICLF_LRS)
      real*8 rprop(PPICLF_LRP)
!
! Output:
!
      real*8 map  (PPICLF_LRP_PRO)
!
! Internal:
!
      real*8 dp_norm
!

      ! particle volume divided by particle diameter for 2d
      dp_norm = 1./rprop(PPICLF_R_JDP)
      map(PPICLF_P_JPHIP) = dp_norm*rprop(PPICLF_R_JVOLP)
      map(PPICLF_P_JFX)   = dp_norm*ydotc(PPICLF_JVX)
      map(PPICLF_P_JFY)   = dp_norm*ydotc(PPICLF_JVY)

      return
      end
!-----------------------------------------------------------------------
      subroutine ppiclf_user_EvalNearestNeighbor
     >                                        (i,j,yi,rpropi,yj,rpropj)
!
      implicit none
!
#include "PPICLF.h"
!
! Input:
!
      integer*4 i
      integer*4 j
      real*8 yi    (PPICLF_LRS)
      real*8 rpropi(PPICLF_LRP)
      real*8 yj    (PPICLF_LRS)
      real*8 rpropj(PPICLF_LRP)
!
! Internal:
!
      real*8 ksp,erest
      common /ucollision/ ksp,erest

      real*8 rpi2, rthresh, rxdiff, rydiff, rzdiff, rdiff, rm1, rm2,
     >       rmult, eta, rbot, rn_12x, rn_12y, rn_12z, rdelta12,
     >       rv12_mag, rv12_mage, rksp_max, rnmag, rksp_wall, rextra
!
      rpi2  =  9.869604401089358d0

      ! other particles
      if (j .ne. 0) then
         rthresh  = 0.5d0*(rpropi(PPICLF_R_JDP) + rpropj(PPICLF_R_JDP))

         rxdiff = yj(PPICLF_JX) - yi(PPICLF_JX)
         rydiff = yj(PPICLF_JY) - yi(PPICLF_JY)

         rdiff = sqrt(rxdiff**2 + rydiff**2)

         if (rdiff .gt. rthresh) return

         rm1 = rpropi(PPICLF_R_JRHOP)*rpropi(PPICLF_R_JVOLP)
         rm2 = rpropj(PPICLF_R_JRHOP)*rpropj(PPICLF_R_JVOLP)

         rmult = 1.0d0/sqrt(1.0d0/rm1+1.0d0/rm2)
         eta   = 2.0d0*sqrt(ksp)*log(erest)/sqrt(log(erest)**2+rpi2)
     >           *rmult

         rbot = 1.0d0/rdiff
         rn_12x = rxdiff*rbot
         rn_12y = rydiff*rbot

         rdelta12 = rthresh - rdiff

         rv12_mag = (yj(PPICLF_JVX)-yi(PPICLF_JVX))*rn_12x +
     >              (yj(PPICLF_JVY)-yi(PPICLF_JVY))*rn_12y

         rv12_mage = rv12_mag*eta
         rksp_max  = ksp*rdelta12
         rnmag     = -rksp_max - rv12_mage

         ppiclf_ydotc(PPICLF_JVX,i) = ppiclf_ydotc(PPICLF_JVX,i)
     >                              + rnmag*rn_12x
         ppiclf_ydotc(PPICLF_JVY,i) = ppiclf_ydotc(PPICLF_JVY,i)
     >                              + rnmag*rn_12y

      ! boundaries
      elseif (j .eq. 0) then

         rksp_wall = ksp

         ! give a bit larger collision threshold for walls
         rextra   = 0.0d0
         rthresh  = (0.5d0+rextra)*rpropi(PPICLF_R_JDP)

         rxdiff = yj(PPICLF_JX) - yi(PPICLF_JX)
         rydiff = yj(PPICLF_JY) - yi(PPICLF_JY)

         rdiff = sqrt(rxdiff**2 + rydiff**2)

         if (rdiff .gt. rthresh) return

         rm1 = rpropi(PPICLF_R_JRHOP)*rpropi(PPICLF_R_JVOLP)

         rmult = sqrt(rm1)
         eta   = 2.0d0*sqrt(rksp_wall)*log(erest)
     >           /sqrt(log(erest)**2+rpi2)*rmult

         rbot = 1.0d0/rdiff
         rn_12x = rxdiff*rbot
         rn_12y = rydiff*rbot
         rn_12z = rzdiff*rbot

         rdelta12 = rthresh - rdiff

         rv12_mag = -1.0d0*(yi(PPICLF_JVX)*rn_12x +
     >                      yi(PPICLF_JVY)*rn_12y)

         rv12_mage = rv12_mag*eta
         rksp_max  = rksp_wall*rdelta12
         rnmag     = -rksp_max - rv12_mage

         ppiclf_ydotc(PPICLF_JVX,i) = ppiclf_ydotc(PPICLF_JVX,i)
     >                              + rnmag*rn_12x
         ppiclf_ydotc(PPICLF_JVY,i) = ppiclf_ydotc(PPICLF_JVY,i)
     >                              + rnmag*rn_12y

      endif

      return
      end
!-----------------------------------------------------------------------


program test_sympl

use orbit_symplectic
use orbit_symplectic_quasi, only: f_quasi => f, si_quasi => si, &
    orbit_timestep_quasi, orbit_timestep_multi_quasi
use neo_orb
use new_vmec_stuff_mod, only: rmajor
use diag_mod, only : icounter
use omp_lib

implicit none
save

integer :: ierr, kt

double precision :: z0(4), vpar0, dt

type(FieldCan) :: f
type(SymplecticIntegrator) :: euler1, euler2, midpoint, gauss2, gauss4, gauss6, lobatto4
type(MultistageIntegrator) :: verlet, order4, mclachlan4, blanes4, kahan6
type(NeoOrb) :: norb

integer :: npoiper2
real(8) :: rbig, dtau, dtaumax

integer :: nt

call init_field(norb, 'wout.nc', 5, 5, 3, 2)

npoiper2 = 64
rbig = rmajor*1.0d2
dtaumax = twopi*rbig/npoiper2
dtau = dtaumax

call init_params(norb, 2, 4, 3.5d6, dtau, dtaumax, 1d-8)  ! fusion alphas)

! Initial conditions
z0(1) = 0.4d0  ! r
z0(2) = 0.7d0  ! theta
z0(3) = 0.1d0  ! phi
vpar0 = 0.8d0  ! parallel velocity
call eval_field(f, z0(1), z0(2), z0(3), 0)

f%mu = .5d0**2*(1.d0-vpar0**2)/f%Bmod*2d0 ! mu by factor 2 from other modules
f%ro0 = ro0/dsqrt(2d0) ! ro0 = mc/e*v0, different by sqrt(2) from other modules
f%vpar = vpar0*dsqrt(2d0) ! vpar_bar = vpar/sqrt(T/m), different by sqrt(2) from other modules

print *, f%ro0, f%mu
z0(4) = vpar0*f%hph + f%Aph/f%ro0  ! p_phi

npoiper2 = 48
dt = twopi*rbig/npoiper2

nt = 10000*npoiper2/64

call orbit_sympl_init(euler1, f, z0, dt, 1, 1d-12, 1, 1)
call test_single(euler1, 'euler1.out')
call orbit_sympl_init(euler2, f, z0, dt, 1, 1d-12, 2, 1)
call test_single(euler2, 'euler2.out')
print *, ''

call orbit_sympl_init(gauss2, f, z0, dt, 1, 1d-12, 4, 0)
call test_single(gauss2, 'gauss2.out')
call orbit_sympl_init(midpoint, f, z0, dt, 1, 1d-12, 3, 0)
call test_single(midpoint, 'midpoint.out')
call orbit_sympl_init_verlet(verlet, f, z0, dt, 1, 1d-12)
call test_multi(verlet, 'verlet.out')
print *, ''

call orbit_sympl_init(gauss4, f, z0, dt, 1, 1d-12, 5, 0)
call test_single(gauss4, 'gauss4.out')
! call orbit_sympl_init_order4(order4, f, z0, dt, 1, 1d-12)
! call test_multi(order4, 'order4.out')
call orbit_sympl_init_mclachlan4(mclachlan4, f, z0, dt, 1, 1d-12)
call test_multi(mclachlan4, 'mclachlan4.out')
call orbit_sympl_init_blanes4(blanes4, f, z0, dt, 1, 1d-12)
call test_multi(blanes4, 'blanes4.out')
call orbit_sympl_init(lobatto4, f, z0, dt, 1, 1d-12, 15, 0)
call test_single(lobatto4, 'lobatto4.out')
call orbit_sympl_init(gauss6, f, z0, dt, 1, 1d-12, 6, 0)
call test_single(gauss6, 'gauss6.out')
print *, ''

stop

call orbit_sympl_init_kahan6(kahan6, f, z0, dt, 1, 1d-12)
call test_multi(kahan6, 'kahan6.out')
print *, ''

call orbit_sympl_init(euler1, f, z0, dt, 1, 1d-12, 1, 0)
call test_quasi(euler1, 'euler11.out')
call orbit_sympl_init(euler2, f, z0, dt, 1, 1d-12, 2, 0)
call test_quasi(euler2, 'euler21.out')
print *, ''

call orbit_sympl_init_verlet(verlet, f, z0, dt, 1, 1d-12)
call test_multi_quasi(verlet, 'verletq.out')
call orbit_sympl_init(midpoint, f, z0, dt, 1, 1d-12, 3, 0)
call test_quasi(midpoint, 'midpointq.out')
call orbit_sympl_init(gauss2, f, z0, dt, 1, 1d-12, 4, 0)
call test_quasi(gauss2, 'gauss2q.out')
print *, ''

!call orbit_sympl_init_order4(order4, f, z0, dt, 1, 1d-12)
!call test_multi_quasi(order4, 'order4q.out')
call orbit_sympl_init_mclachlan4(mclachlan4, f, z0, dt, 1, 1d-12)
call test_multi_quasi(mclachlan4, 'mclachlan4q.out')
call orbit_sympl_init_blanes4(blanes4, f, z0, dt, 1, 1d-12)
call test_multi_quasi(blanes4, 'blanes4q.out')
call orbit_sympl_init(gauss4, f, z0, dt, 1, 1d-12, 5, 0)
call test_quasi(gauss4, 'gauss4q.out')
print *, ''

call orbit_sympl_init_kahan6(kahan6, f, z0, dt, 1, 1d-12)
call test_multi_quasi(kahan6, 'kahan6q.out')
call orbit_sympl_init(gauss6, f, z0, dt, 1, 1d-12, 6, 0)
call test_quasi(gauss6, 'gauss6q.out')
print *, ''

contains

subroutine test_single(si, outname)
    type(SymplecticIntegrator) :: si
    character(len=*) :: outname

    double precision :: starttime, endtime
    double precision, allocatable :: out(:, :)

    allocate(out(5,nt))

    icounter = 0
    out=0d0

    out(1:4,1) = z0
    out(5,1) = f%H
    starttime = omp_get_wtime()
    do kt = 2, nt
        ierr = 0
        call orbit_timestep_sympl(si, f, ierr)
        if (.not. ierr==0) then
            print *, si%z
            exit
        endif
        out(1:4,kt) = si%z
        out(5,kt) = f%H
    end do
    endtime = omp_get_wtime()
    print *, outname(1:10), endtime-starttime, icounter

    open(unit=20, file=outname, action='write', recl=4096)
    do kt = 1, nt
        write(20,*) out(:,kt)
    end do
    close(20)
    deallocate(out)
end subroutine test_single

subroutine test_quasi(si, outname)
    type(SymplecticIntegrator) :: si
    character(len=*) :: outname

    double precision :: starttime, endtime
    double precision, allocatable :: out(:, :)

    allocate(out(5,nt))

    icounter = 0
    out(:,1:)=0d0

    out(1:4,1) = z0
    out(5,1) = f%H

    f_quasi = f
    si_quasi = si

    starttime = omp_get_wtime()
    do kt = 2, nt
        ierr = 0
        call orbit_timestep_quasi(ierr)
        if (.not. ierr==0) then
            print *, si%z
            exit
        endif
        out(1:4,kt) = si_quasi%z
        out(5,kt) = f_quasi%H
    end do
    endtime = omp_get_wtime()
    print *, outname(1:10), endtime-starttime, icounter

    open(unit=20, file=outname, action='write', recl=4096)
    do kt = 1, nt
        write(20,*) out(:,kt)
    end do
    close(20)
    deallocate(out)

end subroutine test_quasi

subroutine test_multi(mi, outname)
    type(MultistageIntegrator) :: mi
    character(len=*) :: outname

    double precision :: starttime, endtime
    double precision, allocatable :: out(:, :)

    allocate(out(5,nt))

    icounter = 0
    out=0d0

    out(1:4,1) = z0
    out(5,1) = f%H
    starttime = omp_get_wtime()
    do kt = 2, nt
        ierr = 0
        call orbit_timestep_sympl_multi(mi, f, ierr)
        if (.not. ierr==0) stop 'Error'
        out(1:4,kt) = mi%stages(1)%z
        out(5,kt) = f%H
    end do
    endtime = omp_get_wtime()
    print *, outname(1:10), endtime-starttime, icounter

    open(unit=20, file=outname, action='write', recl=4096)
    do kt = 1, nt
        write(20,*) out(:,kt)
    end do
    close(20)
    deallocate(out)
end subroutine test_multi

subroutine test_multi_quasi(mi, outname)
    type(MultistageIntegrator) :: mi
    character(len=*) :: outname

    double precision :: starttime, endtime
    double precision, allocatable :: out(:, :)

    f_quasi = f

    allocate(out(5,nt))

    icounter = 0
    out=0d0

    out(1:4,1) = z0
    out(5,1) = f_quasi%H

    starttime = omp_get_wtime()
    do kt = 2, nt
        ierr = 0
        call orbit_timestep_multi_quasi(mi, ierr)
        if (.not. ierr==0) stop 'Error'
        out(1:4,kt) = mi%stages(1)%z
        out(5,kt) = f_quasi%H
    end do
    endtime = omp_get_wtime()
    print *, outname(1:10), endtime-starttime, icounter

    open(unit=20, file=outname, action='write', recl=4096)
    do kt = 1, nt
        write(20,*) out(:,kt)
    end do
    close(20)
    deallocate(out)
end subroutine test_multi_quasi

end program test_sympl


!> \file errors.f90
!! \BRIEF
!> Module with errors subroutine - Propagate standard error (or uncertainty) in carbonate system vars
MODULE merrors
CONTAINS

!>    Compute standard errors (or uncertainties) of standard carbonate system variables
!>    (H+, pCO2, fCO2, CO2*, HCO3- and CO3--, OmegaA, OmegaC) based on uncertainties
!!    in input variables, which are Alk, DIC, Total Silicate and Phosphate, T and S
!!    and in dissociations constants  K0, K1, K2, Kb, Kw, Kspa, Kspc
SUBROUTINE errors  (eH, epCO2, efCO2, eCO2, eHCO3, eCO3, eOmegaA, eOmegaC,    &
                temp, sal, alk, dic, sil, phos, Patm, depth, lat, N,          &
                etemp, esal, ealk, edic, esil, ephos,                         &
                optCON, optT, optP, optB, optK1K2, optKf, optGAS, optS, lon,  &
                r, epK, ebt )

!     This subroutine does error propagation on the computation of carbonate system variables
!     from errors (or uncertainties) on six input
!      - Alk and DIC
!      - nutrients (silicate and phosphate concentrations)
!      - temperature and salinity
!     plus errors on dissociation constants pK0, pK1, pK2, pKb, pKw, pKspa and pKspc
!
!     It computes numerical derivatives then applies error propagation using the method of moments.
!     The method of moments is a very general technique for estimating the second moment of a variable z
!     (variance or standard deviation) based on a first-order approximation to z.
!
!     INPUT variables:
!     ================
!     - temp, sal, alk, dic, sil, phos, Patm, depth, lat :  same as input of subroutine  vars() : vectors
!
!     - N              :  number of data points (= size of input and output vectors)
!     - ealk, edic     :  standard error (or uncertainty) on alk and DIC
!     - esal, etemp    :  standard error (or uncertainty) on Salinity and Temperature
!     - ephos, esil    :  standard error (or uncertainty) on Phosphate and Silicate total concentrations
!     - epK            :  standard error (or uncertainty) on all seven dissociation constants (a vector) [pK units]
!     - ebt            :  standard error (or uncertainty) on total boron fractional error [default=0.01], i.e., 1%
!
!       All parameters are vectors of length N except epK
!         epK must be vector of seven values : errors of pK0, pK1, pK2, pKb, pKw, pKspa and pKspc
!         these errors are assumed to be equal for all data points.
!         In constrast, ealk, edic, esal, etemp, ephos and esilt are errors associated with each data point.
!
!       epK is optional :  if not given, following default error values will be taken :
!                   pK0     pK1    pK2,   pKb    pKw    pKspa   pKspc
!                   0.002   0.0075  0.015   0.01   0.01   0.02    0.02
!
!       ebt is optional :  if not given, the default error is 0.02 (i.e., 2%)
!                   Bt (rel. err)
!                   0.02
!
!     INPUT options:
!     ==============
!
!     - optCON, optT, optP, opB, optK1K2, optKf, optGAS, optS, lon :  same as for input of subroutine vars()
!
!
!     OUTPUT variables:
!     =================
!
!     - eH       total error to [H+] concentration  (mol/kg) on the total scale
!     - epCO2    total error to "standard" pCO2, CO2 partial pressure computed at in situ temperature and atmospheric pressure (µatm)
!     - efCO2    total error to "standard" fCO2, CO2 fugacity computed at in situ temperature and atmospheric pressure (µatm)
!     - eCO2     total error to CO2 concentration (mol/kg)
!     - eHCO3    total error to HCO3 concentration (mol/kg)
!     - eCO3     total error to CO3 concentration (mol/kg)
!     - eOmegaA  total error of Omega aragonite (aragonite saturation state)
!     - eOmegaC  total error of Omega calcite   (calcite saturation state)
!
!*****************************************************************************************************

#if USE_PRECISION == 2
#   define SGLE(x)    (x)
#else
#   define SGLE(x)    REAL(x)
#endif

  USE msingledouble
  USE mconstants
  USE mderivnum

  IMPLICIT NONE

! Input variables
  !>     number of records
!f2py intent(hide) n
  INTEGER, INTENT(in) :: N
  !> either in situ temperature (when optT='Tinsitu', typical data)
  !! OR potential temperature (when optT='Tpot', typical models) [degree C]
  REAL(kind=rx), INTENT(in),    DIMENSION(N) :: temp
  !> salinity [psu]
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: sal
  !> total alkalinity in [eq/m^3] (when optCON = 'mol/m3') OR in [eq/kg]  (when optCON = 'mol/kg')
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: alk
  !> dissolved inorganic carbon in [mol/m^3] (when optCON = 'mol/m3') OR in [mol/kg] (when optCON = 'mol/kg')
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: dic
  !> SiO2 concentration in [mol/m^3] (when optCON = 'mol/m3') OR in [mol/kg] (when optCON = 'mol/kg')
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: sil
  !> phosphate concentration in [mol/m^3] (when optCON = 'mol/m3') OR in [mol/kg] (when optCON = 'mol/kg')
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: phos
  !> atmospheric pressure [atm]
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: Patm
  !> depth in \b meters (when optP='m') or \b decibars (when optP='db')
  REAL(kind=rx), INTENT(in),    DIMENSION(N) :: depth
  !> latitude [degrees north]
  REAL(kind=rx), INTENT(in),    DIMENSION(N) :: lat

  !> standard error (or uncertainty) on Temperature
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: etemp
  !> standard error (or uncertainty) on Salinity
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: esal
  !> standard error (or uncertainty) on alk
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: ealk
  !> standard error (or uncertainty) on DIC
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: edic
  !> standard error (or uncertainty) on Silicate total concentrations
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: esil
  !> standard error (or uncertainty) on Phosphate total concentrations
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: ephos
  !> standard error (or uncertainty) on all seven dissociation constants (a vector)
!!!f2py real(8) intent(in), optional, dimension(7) :: epK=(0.002,0.0075,0.015,0.01,0.01,0.02,0.02)
  REAL(kind=rx), INTENT(in), OPTIONAL, DIMENSION(7) :: epK
!f2py real(8) intent(in), optional, dimension(7) :: epK=(0.002,0.0075,0.015,0.01,0.01,0.02,0.02)
!!!f2py optional :: epK=(0.002,0.0075,0.015,0.01,0.01,0.02,0.02)
  !> correlation coefficient (-1 < r < 1) for correlation between ALK and DIC (zero by default)
!f2py  real intent(in), optional :: r = 0.0
  REAL(kind=rx), OPTIONAL, INTENT(in) :: r
  !> standard error (or uncertainty) on total boron (Bt) - a single number, not a vector like other errors
!f2py  real intent(in), optional :: ebt=0.02
  REAL(kind=rx), OPTIONAL, INTENT(in) :: ebt

  !> choose either \b 'mol/kg' (std DATA units) or \b 'mol/m3' (std MODEL units) to select
  !! concentration units for input (for alk, dic, sil, phos) & output (co2, hco3, co3)
  CHARACTER(6), INTENT(in) :: optCON
  !> choose \b 'Tinsitu' for in situ temperature or \b 'Tpot' for potential temperature (in situ Temp is computed, needed for models)
  CHARACTER(7), INTENT(in) :: optT
  !> for depth input, choose \b "db" for decibars (in situ pressure) or \b "m" for meters (pressure is computed, needed for models)
  CHARACTER(2), INTENT(in) :: optP
  !> for total boron, choose either \b 'u74' (Uppstrom, 1974) or \b 'l10' (Lee et al., 2010).
  !! The 'l10' formulation is based on 139 measurements (instead of 20),
  !! uses a more accurate method, and
  !! generally increases total boron in seawater by 4%
!f2py character*3 optional, intent(in) :: optB='u74'
  CHARACTER(3), OPTIONAL, INTENT(in) :: optB
  !> for K1,K2 choose either \b 'l' (Lueker et al., 2000) or \b 'm10' (Millero, 2010)
!f2py character*3 optional, intent(in) :: optK1K2='l'
  CHARACTER(3), OPTIONAL, INTENT(in) :: optK1K2
  !> for Kf, choose either \b 'pf' (Perez & Fraga, 1987) or \b 'dg' (Dickson & Riley, 1979)
!f2py character*2 optional, intent(in) :: optKf='pf'
  CHARACTER(2), OPTIONAL, INTENT(in) :: optKf
  !> for K0,fugacity coefficient choose either \b 'Ppot' (no pressure correction) or \b 'Pinsitu' (with pressure correction)
  !! 'Ppot'    - for 'potential' fCO2 and pCO2 (water parcel brought adiabatically to the surface)
  !! 'Pinsitu' - for 'in situ' values of fCO2 and pCO2, accounting for pressure on K0 and Cf
  !! with 'Pinsitu' the fCO2 and pCO2 will be many times higher in the deep ocean
!f2py character*7 optional, intent(in) :: optGAS='Pinsitu'
  CHARACTER(7), OPTIONAL, INTENT(in) :: optGAS
!f2py character*7 optional, intent(in) :: optS='Sprc'
  CHARACTER(4), OPTIONAL, INTENT(in) :: optS
  !> longitude [degrees east]
!!!f2py real(8) optional, intent(in), dimension(n) :: lon = -25.
  REAL(kind=rx), OPTIONAL, INTENT(in),    DIMENSION(N) :: lon
!f2py optional :: lon = -25.

! Output variables:
  !> total error to [H+] concentration  (mol/kg) on the total scale
  REAL(kind=rx), INTENT(out), DIMENSION(N) :: eH
  !> total error to "standard" pCO2, CO2 partial pressure computed at in situ temperature and atmospheric pressure (µatm)
  REAL(kind=rx), INTENT(out), DIMENSION(N) :: epCO2
  !> total error to "standard" fCO2, CO2 fugacity computed at in situ temperature and atmospheric pressure (µatm)
  REAL(kind=rx), INTENT(out), DIMENSION(N) :: efCO2
  !> total error to CO2 concentration (mol/kg)
  REAL(kind=rx), INTENT(out), DIMENSION(N) :: eCO2
  !> total error to HCO3 concentration (mol/kg)
  REAL(kind=rx), INTENT(out), DIMENSION(N) :: eHCO3
  !> total error to CO3 concentration (mol/kg)
  REAL(kind=rx), INTENT(out), DIMENSION(N) :: eCO3
  !> total error of Omega aragonite (aragonite saturation state)
  REAL(kind=rx), INTENT(out), DIMENSION(N) :: eOmegaA
  !> total error of Omega calcite   (calcite saturation state)
  REAL(kind=rx), INTENT(out), DIMENSION(N) :: eOmegaC

! Local variables

  ! Default value for errors on pK
  REAL(kind=rx), DIMENSION(7) :: epK_local = (/0.002_r8, 0.0075_r8, 0.015_r8, 0.01_r8, 0.01_r8, 0.02_r8, 0.02_r8/)
  REAL(kind=rx), DIMENSION(7) :: epKstd = (/0.002_r8, 0.0075_r8, 0.015_r8, 0.01_r8, 0.01_r8, 0.02_r8, 0.02_r8/)
  REAL(kind=rx), DIMENSION(7) :: epKzero
! REAL(kind=rx), DIMENSION(7) :: epKstd
! Extend epK_local by 1 to later include error for Bt (simplifies coding)
  REAL(kind=rx), DIMENSION(8) :: epK_local8
  CHARACTER*3, DIMENSION(8) ::  Kid = (/'k0 ','k1 ','k2 ','kb ','kw ','ka ','kc ', 'bt '/)
! CHARACTER*3, DIMENSION(7) :: Kid = (/'k0 ','k1 ','k2 ','kb ','kw ','ka ','kc '/)

  ! Default value for error on Total Boron (ebt)
  REAL(kind=rx) :: ebt_local = 0.02_rx
! REAL(kind=rx) :: ebt_local

  ! Default value for correlation between ALK & DIC
  REAL(kind=rx) :: r_local = 0.0_r8

  ! derivative of H on the total scale
  REAL(kind=rx), DIMENSION(N) :: dh_dx
  ! derivative of CO2 partial pressure [uatm]
  REAL(kind=rx), DIMENSION(N) :: dpco2_dx
  ! derivative of CO2 fugacity [uatm]
  REAL(kind=rx), DIMENSION(N) :: dfco2_dx
  ! derivative of aqueous CO2* concentration, either in [mol/m^3] or [mol/kg] depending on choice for optCON
  REAL(kind=rx), DIMENSION(N) :: dco2_dx
  ! derivative of (HCO3-) concentration, either in [mol/m^3] or [mol/kg] depending on choice for optCON
  REAL(kind=rx), DIMENSION(N) :: dhco3_dx
  ! derivative of (CO3--) concentration, either in [mol/m^3] or [mol/kg] depending on choice for optCON
  REAL(kind=rx), DIMENSION(N) :: dco3_dx
  ! derivative of Omega for aragonite, i.e., the aragonite saturation state
  REAL(kind=rx), DIMENSION(N) :: dOmegaA_dx
  ! derivative of Omega for calcite, i.e., the calcite saturation state
  REAL(kind=rx), DIMENSION(N) :: dOmegaC_dx

  ! covariance tmp array for derivative of H on the total scale
  REAL(kind=rx), DIMENSION(N) :: r_dh_dx
  ! covariance tmp array for derivative of CO2 partial pressure [uatm]
  REAL(kind=rx), DIMENSION(N) :: r_dpco2_dx
  ! covariance tmp array for derivative of CO2 fugacity [uatm]
  REAL(kind=rx), DIMENSION(N) :: r_dfco2_dx
  ! covariance tmp array for derivative of aqueous CO2* concentration, either in [mol/m^3] or [mol/kg] depending on choice for optCON
  REAL(kind=rx), DIMENSION(N) :: r_dco2_dx
  ! covariance tmp array for derivative of (HCO3-) concentration, either in [mol/m^3] or [mol/kg] depending on choice for optCON
  REAL(kind=rx), DIMENSION(N) :: r_dhco3_dx
  ! covariance tmp array for derivative of (CO3--) concentration, either in [mol/m^3] or [mol/kg] depending on choice for optCON
  REAL(kind=rx), DIMENSION(N) :: r_dco3_dx
  ! covariance tmp array for derivative of Omega for aragonite, i.e., the aragonite saturation state
  REAL(kind=rx), DIMENSION(N) :: r_dOmegaA_dx
  ! covariance tmp array for Omega for calcite, i.e., the calcite saturation state
  REAL(kind=rx), DIMENSION(N) :: r_dOmegaC_dx

  REAL(kind=r8), DIMENSION(N) :: K0, K1, K2, Kb, Kw, Ks, Kf, Kspc
  REAL(kind=r8), DIMENSION(N) :: Kspa, K1p, K2p, K3p, Ksi
  REAL(kind=r8), DIMENSION(N) :: St, Ft, Bt
  ! Standard error on dissociation constant Kx
  REAL(kind=r8), DIMENSION(N) :: eK

! Arrays to pass optional arguments into or use defaults (Dickson et al., 2007)
  CHARACTER(3) :: opB
  CHARACTER(3) :: opK1K2
  CHARACTER(2) :: opKf
  CHARACTER(7) :: opGAS
  CHARACTER(4) :: opS

  INTEGER :: i

! *******************************************************************

! Set defaults for optional arguments (in Fortran90)
! Note:  Optional arguments with f2py (python) are set above with
!        the !f2py statements that precede each type declaraion

  epKstd = (/0.002d0, 0.0075d0, 0.015d0, 0.01d0, 0.01d0, 0.02d0, 0.02d0/)
  epK_local(:) = epKstd(:)
  epKzero = epKstd * 0.0

  !------------------------------------------------------------------------------------------------------
  ! IMPORTANT: in python (after f2py), the result of "PRESENT()" clause below is always .TRUE.
  !            Thus the corresponding ELSE blocks below are executed only when in pure FORTRAN;
  !            They are not reached in a python call of the same fortran routines. Thus
  !            for f2py, the same defaults are assigned with "!f2py" statements above
  IF (PRESENT(optB)) THEN
     opB = optB
  ELSE
!   Default is Uppstrom (1974) for total boron
     opB = 'u74'
  ENDIF
  IF (PRESENT(optK1K2)) THEN
     opK1K2 = optK1K2
  ELSE
!    Default is Lueker et al. 2000) for K1 & K2
     opK1K2 = 'l'
  ENDIF
  IF (PRESENT(optKf)) THEN
     opKf = optKf
  ELSE
!    Default is Perez & Fraga (1987) for Kf
     opKf = 'pf'
  ENDIF
  IF (PRESENT(optGAS)) THEN
     opGAS = optGAS
  ELSE
     opGAS = 'Pinsitu'
  ENDIF
  IF (PRESENT(optS)) THEN
     opS = optS
  ELSE
     opS = 'Sprc'
  ENDIF
! IF (PRESENT(lon)) THEN
!    lon_local = lon
! ELSE
!    lon_local = 1.e20
! ENDIF
  IF (PRESENT(r)) THEN
     r_local = r
  ELSE
     r_local = 0.0_r8
  ENDIF
  IF (PRESENT(epK)) THEN
     epK_local(:) = epK(:)
     ! Kludge: when used in python, the init. of epK fails (does not work with an array)
     ! i.e;, all 7 epK members are equal to last specified element on !f2py statement)
     IF (epK(1)==epK(7) .and. epK(2)==epK(7) .and. epK(3)==epK(7) .AND. &
         epK(4)==epK(7) .and. epK(5)==epK(7) .and. epK(6)==epK(7)         ) THEN
         ! if so, initialize to the default
         IF (epK(1)==0.0) THEN
            epK_local = epKzero
         ELSE
            epK_local = epKstd
         ENDIF
     ENDIF
  ELSE
     epK_local = (/0.002_r8, 0.0075_r8, 0.015_r8, 0.01_r8, 0.01_r8, 0.02_r8, 0.02_r8/)
  ENDIF
  IF (PRESENT(ebt)) THEN
     ebt_local = ebt
  ELSE
     ebt_local = 0.02_rx
  ENDIF

  ! initialise total square error
  eH(:) = 0
  epCO2(:) = 0
  efCO2(:) = 0
  eCO2(:) = 0
  eHCO3(:) = 0
  eCO3(:) = 0
  eOmegaA(:) = 0
  eOmegaC(:) = 0

  ! Contribution of Alk to squared standard error
  ! ---------------------------------------------

  ! Compute sensitivities (partial derivatives)
  CALL derivnum (dh_dx, dpco2_dx, dfco2_dx, dco2_dx, dhco3_dx,              &
            dco3_dx, dOmegaA_dx, dOmegaC_dx,                                &
            temp, sal, alk, dic, sil, phos, Patm, depth, lat, N, 'alk',     &
            optCON, optT, optP, opB, opK1K2, opKf, opGAS                    )

  ! Covariance (only when R is not zero)
  IF (r_local .NE. 0.0_r8) THEN
     r_dh_dx(:)      = dh_dx(:)      * ealk(:)
     r_dpco2_dx(:)   = dpco2_dx(:)   * ealk(:)
     r_dfco2_dx(:)   = dfco2_dx(:)   * ealk(:)
     r_dco2_dx(:)    = dco2_dx(:)    * ealk(:)
     r_dhco3_dx(:)   = dhco3_dx(:)   * ealk(:)
     r_dco3_dx(:)    = dco3_dx(:)    * ealk(:)
     r_dOmegaA_dx(:) = dOmegaA_dx(:) * ealk(:)
     r_dOmegaC_dx(:) = dOmegaC_dx(:) * ealk(:)
  ENDIF

  ! multiply derivatives by error
  dh_dx(:)      = dh_dx(:)      * ealk(:)
  dpco2_dx(:)   = dpco2_dx(:)   * ealk(:)
  dfco2_dx(:)   = dfco2_dx(:)   * ealk(:)
  dco2_dx(:)    = dco2_dx(:)    * ealk(:)
  dhco3_dx(:)   = dhco3_dx(:)   * ealk(:)
  dco3_dx(:)    = dco3_dx(:)    * ealk(:)
  dOmegaA_dx(:) = dOmegaA_dx(:) * ealk(:)
  dOmegaC_dx(:) = dOmegaC_dx(:) * ealk(:)
  ! Square
  dh_dx(:)      = dh_dx(:) * dh_dx(:)
  dpco2_dx(:)   = dpco2_dx(:) * dpco2_dx(:)
  dfco2_dx(:)   = dfco2_dx(:) * dfco2_dx(:)
  dco2_dx(:)    = dco2_dx(:)  * dco2_dx(:)
  dhco3_dx(:)   = dhco3_dx(:) * dhco3_dx(:)
  dco3_dx(:)    = dco3_dx(:)  * dco3_dx(:)
  dOmegaA_dx(:) = dOmegaA_dx(:) * dOmegaA_dx(:)
  dOmegaC_dx(:) = dOmegaC_dx(:) * dOmegaC_dx(:)
  ! sum up
  eH(:)    = eH(:)    + dh_dx(:)
  epCO2(:) = epCO2(:) + dpco2_dx(:)
  efCO2(:) = efCO2(:) + dfco2_dx(:)
  eCO2(:)  = eCO2(:)  + dco2_dx(:)
  eHCO3(:) = eHCO3(:) + dhco3_dx(:)
  eCO3(:)  = eCO3(:)  + dco3_dx(:)
  eOmegaA(:) = eOmegaA(:) + dOmegaA_dx(:)
  eOmegaC(:) = eOmegaC(:) + dOmegaC_dx(:)

  ! Contribution of DIC to squared standard error
  ! ---------------------------------------------

  ! Compute sensitivities (partial derivatives)
  CALL derivnum (dh_dx, dpco2_dx, dfco2_dx, dco2_dx, dhco3_dx,              &
            dco3_dx, dOmegaA_dx, dOmegaC_dx,                                &
            temp, sal, alk, dic, sil, phos, Patm, depth, lat, N, 'dic',     &
            optCON, optT, optP, opB, opK1K2, opKf, opGAS                    )

  ! Covariance (only when R is not zero) = 2*r*(dvar/dAt)*(dvar/dCt)*sigma1*sigma2
  IF (r_local .NE. 0.0_r8) THEN
     eH(:)      = eH(:)      + 2.0_r8 * r_local * r_dh_dx(:)      * dh_dx(:)      * edic(:)
     epco2(:)   = epco2(:)   + 2.0_r8 * r_local * r_dpco2_dx(:)   * dpco2_dx(:)   * edic(:)
     efco2(:)   = efco2(:)   + 2.0_r8 * r_local * r_dfco2_dx(:)   * dfco2_dx(:)   * edic(:)
     eco2(:)    = eco2(:)    + 2.0_r8 * r_local * r_dco2_dx(:)    * dco2_dx(:)    * edic(:)
     ehco3(:)   = ehco3(:)   + 2.0_r8 * r_local * r_dhco3_dx(:)   * dhco3_dx(:)   * edic(:)
     eco3(:)    = eco3(:)    + 2.0_r8 * r_local * r_dco3_dx(:)    * dco3_dx(:)    * edic(:)
     eOmegaA(:) = eOmegaA(:) + 2.0_r8 * r_local * r_dOmegaA_dx(:) * dOmegaA_dx(:) * edic(:)
     eOmegaC(:) = eOmegaC(:) + 2.0_r8 * r_local * r_dOmegaC_dx(:) * dOmegaC_dx(:) * edic(:)
  ENDIF

  ! multiply derivatives by error
  dh_dx(:)      = dh_dx(:)      * edic(:)
  dpco2_dx(:)   = dpco2_dx(:)   * edic(:)
  dfco2_dx(:)   = dfco2_dx(:)   * edic(:)
  dco2_dx(:)    = dco2_dx(:)    * edic(:)
  dhco3_dx(:)   = dhco3_dx(:)   * edic(:)
  dco3_dx(:)    = dco3_dx(:)    * edic(:)
  dOmegaA_dx(:) = dOmegaA_dx(:) * edic(:)
  dOmegaC_dx(:) = dOmegaC_dx(:) * edic(:)
  ! Square
  dh_dx(:)      = dh_dx(:) * dh_dx(:)
  dpco2_dx(:)   = dpco2_dx(:) * dpco2_dx(:)
  dfco2_dx(:)   = dfco2_dx(:) * dfco2_dx(:)
  dco2_dx(:)    = dco2_dx(:)  * dco2_dx(:)
  dhco3_dx(:)   = dhco3_dx(:) * dhco3_dx(:)
  dco3_dx(:)    = dco3_dx(:)  * dco3_dx(:)
  dOmegaA_dx(:) = dOmegaA_dx(:) * dOmegaA_dx(:)
  dOmegaC_dx(:) = dOmegaC_dx(:) * dOmegaC_dx(:)
  ! sum up
  eH(:)    = eH(:)    + dh_dx(:)
  epCO2(:) = epCO2(:) + dpco2_dx(:)
  efCO2(:) = efCO2(:) + dfco2_dx(:)
  eCO2(:)  = eCO2(:)  + dco2_dx(:)
  eHCO3(:) = eHCO3(:) + dhco3_dx(:)
  eCO3(:)  = eCO3(:)  + dco3_dx(:)
  eOmegaA(:) = eOmegaA(:) + dOmegaA_dx(:)
  eOmegaC(:) = eOmegaC(:) + dOmegaC_dx(:)

  ! Contribution of Silicon (total dissolved inorganic concentration) to squared standard error
  ! -------------------------------------------------------------------------------------------

  IF (any (esil .ne. 0.0)) THEN
      ! Compute sensitivities (partial derivatives)
      CALL derivnum (dh_dx, dpco2_dx, dfco2_dx, dco2_dx, dhco3_dx,              &
                dco3_dx, dOmegaA_dx, dOmegaC_dx,                                &
                temp, sal, alk, dic, sil, phos, Patm, depth, lat, N, 'sil',     &
                optCON, optT, optP, opB, opK1K2, opKf, opGAS                )

      ! Cancels derivative where Sil = 0
      !   because computation of derivative w/ respect to sil fails in that case
      WHERE (sil(:) .EQ. 0)
          dh_dx(:)      = 0
          dpco2_dx(:)   = 0
          dfco2_dx(:)   = 0
          dco2_dx(:)    = 0
          dhco3_dx(:)   = 0
          dco3_dx(:)    = 0
          dOmegaA_dx(:) = 0
          dOmegaC_dx(:) = 0
      END WHERE

      ! multiply derivatives by error
      dh_dx(:)      = dh_dx(:)      * esil(:)
      dpco2_dx(:)   = dpco2_dx(:)   * esil(:)
      dfco2_dx(:)   = dfco2_dx(:)   * esil(:)
      dco2_dx(:)    = dco2_dx(:)    * esil(:)
      dhco3_dx(:)   = dhco3_dx(:)   * esil(:)
      dco3_dx(:)    = dco3_dx(:)    * esil(:)
      dOmegaA_dx(:) = dOmegaA_dx(:) * esil(:)
      dOmegaC_dx(:) = dOmegaC_dx(:) * esil(:)
      ! Square
      dh_dx(:)      = dh_dx(:) * dh_dx(:)
      dpco2_dx(:)   = dpco2_dx(:) * dpco2_dx(:)
      dfco2_dx(:)   = dfco2_dx(:) * dfco2_dx(:)
      dco2_dx(:)    = dco2_dx(:)  * dco2_dx(:)
      dhco3_dx(:)   = dhco3_dx(:) * dhco3_dx(:)
      dco3_dx(:)    = dco3_dx(:)  * dco3_dx(:)
      dOmegaA_dx(:) = dOmegaA_dx(:) * dOmegaA_dx(:)
      dOmegaC_dx(:) = dOmegaC_dx(:) * dOmegaC_dx(:)
      ! sum up
      eH(:)    = eH(:)    + dh_dx(:)
      epCO2(:) = epCO2(:) + dpco2_dx(:)
      efCO2(:) = efCO2(:) + dfco2_dx(:)
      eCO2(:)  = eCO2(:)  + dco2_dx(:)
      eHCO3(:) = eHCO3(:) + dhco3_dx(:)
      eCO3(:)  = eCO3(:)  + dco3_dx(:)
      eOmegaA(:) = eOmegaA(:) + dOmegaA_dx(:)
      eOmegaC(:) = eOmegaC(:) + dOmegaC_dx(:)
  ENDIF

  ! Contribution of Phosphorus (total dissoloved inorganic concentration) to squared standard error
  ! -----------------------------------------------------------------------------------------------

  IF (any (ephos .ne. 0.0)) THEN

      ! Compute sensitivities (partial derivatives)
      CALL derivnum (dh_dx, dpco2_dx, dfco2_dx, dco2_dx, dhco3_dx,              &
                dco3_dx, dOmegaA_dx, dOmegaC_dx,                                &
                temp, sal, alk, dic, sil, phos, Patm, depth, lat, N, 'pho',     &
                optCON, optT, optP, opB, opK1K2, opKf, opGAS                )

      ! Cancels derivative where Phos = 0
      !   because computation of derivative w/ respect to phos fails in that case
      WHERE (phos(:) .EQ. 0)
          dh_dx(:)      = 0
          dpco2_dx(:)   = 0
          dfco2_dx(:)   = 0
          dco2_dx(:)    = 0
          dhco3_dx(:)   = 0
          dco3_dx(:)    = 0
          dOmegaA_dx(:) = 0
          dOmegaC_dx(:) = 0
      END WHERE

      ! multiply derivatives by error
      dh_dx(:)      = dh_dx(:)      * ephos(:)
      dpco2_dx(:)   = dpco2_dx(:)   * ephos(:)
      dfco2_dx(:)   = dfco2_dx(:)   * ephos(:)
      dco2_dx(:)    = dco2_dx(:)    * ephos(:)
      dhco3_dx(:)   = dhco3_dx(:)   * ephos(:)
      dco3_dx(:)    = dco3_dx(:)    * ephos(:)
      dOmegaA_dx(:) = dOmegaA_dx(:) * ephos(:)
      dOmegaC_dx(:) = dOmegaC_dx(:) * ephos(:)
      ! Square
      dh_dx(:)      = dh_dx(:) * dh_dx(:)
      dpco2_dx(:)   = dpco2_dx(:) * dpco2_dx(:)
      dfco2_dx(:)   = dfco2_dx(:) * dfco2_dx(:)
      dco2_dx(:)    = dco2_dx(:)  * dco2_dx(:)
      dhco3_dx(:)   = dhco3_dx(:) * dhco3_dx(:)
      dco3_dx(:)    = dco3_dx(:)  * dco3_dx(:)
      dOmegaA_dx(:) = dOmegaA_dx(:) * dOmegaA_dx(:)
      dOmegaC_dx(:) = dOmegaC_dx(:) * dOmegaC_dx(:)
      ! sum up
      eH(:)    = eH(:)    + dh_dx(:)
      epCO2(:) = epCO2(:) + dpco2_dx(:)
      efCO2(:) = efCO2(:) + dfco2_dx(:)
      eCO2(:)  = eCO2(:)  + dco2_dx(:)
      eHCO3(:) = eHCO3(:) + dhco3_dx(:)
      eCO3(:)  = eCO3(:)  + dco3_dx(:)
      eOmegaA(:) = eOmegaA(:) + dOmegaA_dx(:)
      eOmegaC(:) = eOmegaC(:) + dOmegaC_dx(:)
  ENDIF

  ! Contribution of temperature to squared standard error
  ! -----------------------------------------------------

  IF (any (etemp .ne. 0.0)) THEN
      ! Compute sensitivities (partial derivatives)
      CALL derivnum (dh_dx, dpco2_dx, dfco2_dx, dco2_dx, dhco3_dx,              &
                dco3_dx, dOmegaA_dx, dOmegaC_dx,                                &
                temp, sal, alk, dic, sil, phos, Patm, depth, lat, N, 'tem',     &
                optCON, optT, optP, opB, opK1K2, opKf, opGAS                )

      ! multiply derivatives by error
      dh_dx(:)      = dh_dx(:)      * etemp(:)
      dpco2_dx(:)   = dpco2_dx(:)   * etemp(:)
      dfco2_dx(:)   = dfco2_dx(:)   * etemp(:)
      dco2_dx(:)    = dco2_dx(:)    * etemp(:)
      dhco3_dx(:)   = dhco3_dx(:)   * etemp(:)
      dco3_dx(:)    = dco3_dx(:)    * etemp(:)
      dOmegaA_dx(:) = dOmegaA_dx(:) * etemp(:)
      dOmegaC_dx(:) = dOmegaC_dx(:) * etemp(:)
      ! Square
      dh_dx(:)      = dh_dx(:) * dh_dx(:)
      dpco2_dx(:)   = dpco2_dx(:) * dpco2_dx(:)
      dfco2_dx(:)   = dfco2_dx(:) * dfco2_dx(:)
      dco2_dx(:)    = dco2_dx(:)  * dco2_dx(:)
      dhco3_dx(:)   = dhco3_dx(:) * dhco3_dx(:)
      dco3_dx(:)    = dco3_dx(:)  * dco3_dx(:)
      dOmegaA_dx(:) = dOmegaA_dx(:) * dOmegaA_dx(:)
      dOmegaC_dx(:) = dOmegaC_dx(:) * dOmegaC_dx(:)
      ! sum up
      eH(:)    = eH(:)    + dh_dx(:)
      epCO2(:) = epCO2(:) + dpco2_dx(:)
      efCO2(:) = efCO2(:) + dfco2_dx(:)
      eCO2(:)  = eCO2(:)  + dco2_dx(:)
      eHCO3(:) = eHCO3(:) + dhco3_dx(:)
      eCO3(:)  = eCO3(:)  + dco3_dx(:)
      eOmegaA(:) = eOmegaA(:) + dOmegaA_dx(:)
      eOmegaC(:) = eOmegaC(:) + dOmegaC_dx(:)
  ENDIF

  ! Contribution of salinity to squared standard error
  ! --------------------------------------------------

  IF (any (esal .ne. 0.0)) THEN
      ! Compute sensitivities (partial derivatives)
      CALL derivnum (dh_dx, dpco2_dx, dfco2_dx, dco2_dx, dhco3_dx,              &
                dco3_dx, dOmegaA_dx, dOmegaC_dx,                                &
                temp, sal, alk, dic, sil, phos, Patm, depth, lat, N, 'sal',     &
                optCON, optT, optP, opB, opK1K2, opKf, opGAS                )

      ! multiply derivatives by error
      dh_dx(:)      = dh_dx(:)      * esal(:)
      dpco2_dx(:)   = dpco2_dx(:)   * esal(:)
      dfco2_dx(:)   = dfco2_dx(:)   * esal(:)
      dco2_dx(:)    = dco2_dx(:)    * esal(:)
      dhco3_dx(:)   = dhco3_dx(:)   * esal(:)
      dco3_dx(:)    = dco3_dx(:)    * esal(:)
      dOmegaA_dx(:) = dOmegaA_dx(:) * esal(:)
      dOmegaC_dx(:) = dOmegaC_dx(:) * esal(:)
      ! Square
      dh_dx(:)      = dh_dx(:) * dh_dx(:)
      dpco2_dx(:)   = dpco2_dx(:) * dpco2_dx(:)
      dfco2_dx(:)   = dfco2_dx(:) * dfco2_dx(:)
      dco2_dx(:)    = dco2_dx(:)  * dco2_dx(:)
      dhco3_dx(:)   = dhco3_dx(:) * dhco3_dx(:)
      dco3_dx(:)    = dco3_dx(:)  * dco3_dx(:)
      dOmegaA_dx(:) = dOmegaA_dx(:) * dOmegaA_dx(:)
      dOmegaC_dx(:) = dOmegaC_dx(:) * dOmegaC_dx(:)
      ! sum up
      eH(:)    = eH(:)    + dh_dx(:)
      epCO2(:) = epCO2(:) + dpco2_dx(:)
      efCO2(:) = efCO2(:) + dfco2_dx(:)
      eCO2(:)  = eCO2(:)  + dco2_dx(:)
      eHCO3(:) = eHCO3(:) + dhco3_dx(:)
      eCO3(:)  = eCO3(:)  + dco3_dx(:)
      eOmegaA(:) = eOmegaA(:) + dOmegaA_dx(:)
      eOmegaC(:) = eOmegaC(:) + dOmegaC_dx(:)
  ENDIF

  ! Contribution of the equil constants and Bt to squared standard error
  ! --------------------------------------------------------------------

  ! Make vector of (epK_local, ebt_local), i.e., adding 1 value at end of epK (for testing below)
  epK_local8(1:7) = epK_local
  epK_local8(8)   = ebt_local

  ! Preliminary calculations for dissociation constants and total boron
  IF (any (epK_local8 .NE. 0) ) THEN

      ! Get all equilibrium constants and total concentrations of SO4, F, B
      CALL constants (K0, K1, K2, Kb, Kw, Ks, Kf,                &
                  Kspc, Kspa, K1p, K2p, K3p, Ksi, St, Ft, Bt,    &
                  temp, sal, Patm, depth, lat, N,                &
                  optT, optP, opB, opK1K2, opKf, opGAS        )

      ! Contribution of all pKi to squared standard error
      DO i = 1,8
          ! if error on Ki is given
          IF (epK_local8(i) .ne. 0.0) THEN

              ! compute error on Ki from that on pKi
              SELECT CASE (i)
              CASE(1)
                  eK(:) = - epK_local(i) * K0(:) * log(10.0)
              CASE(2)
                  eK(:) = - epK_local(i) * K1(:) * log(10.0)
              CASE(3)
                  eK(:) = - epK_local(i) * K2(:) * log(10.0)
              CASE(4)
                  eK(:) = - epK_local(i) * Kb(:) * log(10.0)
              CASE(5)
                  eK(:) = - epK_local(i) * Kw(:) * log(10.0)
              CASE(6)
                  eK(:) = - epK_local(i) * Kspa(:) * log(10.0)
              CASE(7)
                  eK(:) = - epK_local(i) * Kspc(:) * log(10.0)
              CASE(8)
                  ! for convenience we tag on ebt here, even though Bt is not an equilibrium constant
                  ! For Bt, we start from % error in Bt (not from absolute delta pK, so no log(10) conversion)
                  eK(:) =  ebt_local    * Bt(:)
              END SELECT

              ! Compute sensitivities (partial derivatives)
              CALL derivnum (dh_dx, dpco2_dx, dfco2_dx, dco2_dx, dhco3_dx,              &
                        dco3_dx, dOmegaA_dx, dOmegaC_dx,                                &
                        temp, sal, alk, dic, sil, phos, Patm, depth, lat, N, Kid(i),    &
                        optCON, optT, optP, opB, opK1K2, opKf, opGAS                    )

              ! multiply derivatives by error
              dh_dx(:)      = dh_dx(:)      * eK(:)
              dpco2_dx(:)   = dpco2_dx(:)   * eK(:)
              dfco2_dx(:)   = dfco2_dx(:)   * eK(:)
              dco2_dx(:)    = dco2_dx(:)    * eK(:)
              dhco3_dx(:)   = dhco3_dx(:)   * eK(:)
              dco3_dx(:)    = dco3_dx(:)    * eK(:)
              dOmegaA_dx(:) = dOmegaA_dx(:) * eK(:)
              dOmegaC_dx(:) = dOmegaC_dx(:) * eK(:)
              ! Square
              dh_dx(:)      = dh_dx(:) * dh_dx(:)
              dpco2_dx(:)   = dpco2_dx(:) * dpco2_dx(:)
              dfco2_dx(:)   = dfco2_dx(:) * dfco2_dx(:)
              dco2_dx(:)    = dco2_dx(:)  * dco2_dx(:)
              dhco3_dx(:)   = dhco3_dx(:) * dhco3_dx(:)
              dco3_dx(:)    = dco3_dx(:)  * dco3_dx(:)
              dOmegaA_dx(:) = dOmegaA_dx(:) * dOmegaA_dx(:)
              dOmegaC_dx(:) = dOmegaC_dx(:) * dOmegaC_dx(:)
              ! sum up
              eH(:)    = eH(:)    + dh_dx(:)
              epCO2(:) = epCO2(:) + dpco2_dx(:)
              efCO2(:) = efCO2(:) + dfco2_dx(:)
              eCO2(:)  = eCO2(:)  + dco2_dx(:)
              eHCO3(:) = eHCO3(:) + dhco3_dx(:)
              eCO3(:)  = eCO3(:)  + dco3_dx(:)
              eOmegaA(:) = eOmegaA(:) + dOmegaA_dx(:)
              eOmegaC(:) = eOmegaC(:) + dOmegaC_dx(:)
          ENDIF
      END DO
  ENDIF

  ! Compute resulting total error (or uncertainty)
  eH       = sqrt(eH)
  epCO2    = sqrt(epCO2)
  efCO2    = sqrt(efCO2)
  eCO2     = sqrt(eCO2)
  eHCO3    = sqrt(eHCO3)
  eCO3     = sqrt(eCO3)
  eOmegaA  = sqrt(eOmegaA)
  eOmegaC  = sqrt(eOmegaC)

  RETURN
END SUBROUTINE errors
END MODULE merrors


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

MODULE m_ifft
   use m_juDFT
CONTAINS
   INTEGER FUNCTION ifft235(ksfft, n, gmaxp)
!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
!   this function checks wether n can be expressed as :
!   n =  (2**P) * (3**Q) * (5**R) to match withe the MFFT - routines
!   used in this program. If close to n there is a number n' which
!   is solely expressable as n'= 2**p then this number sis choosen
!   and is outputted by the function. If n is not expressable as
!   n =  (2**P) * (3**Q) * (5**R) a number n' is choosen close to ns
!   is selected which fullfilles these requirements.

!                            Stefan Bl"ugel , kfa, Oct. 1993
!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
      IMPLICIT NONE

!----> declaration part

      INTEGER :: ksfft, n
      REAL ::    gmaxp

!----> local variabels

      INTEGER :: np, nn, nl, iexp, is, itrial
      REAL :: rl
      REAL :: fac_1, two, fac_2, fac_3, one, fac_4
      PARAMETER(two=2.0e0, fac_1=1.001e0, fac_2=1.7e0, fac_3=1.95e0)
      PARAMETER(one=1.0e0, fac_4=0.03e0)
      INTRINSIC abs, log, mod, real

      ifft235 = 0
      IF (n == 0) THEN
         CALL juDFT_error("n should not be zero", calledby="ifft235")
      ENDIF

!====> RADIX 2 CALCULATION ONLY

      IF (ksfft == 0) THEN
         rl = log(real(n))/log(two)
         nl = rl
         IF (abs(n - 2**nl) > abs(n - 2**(nl + 1))) THEN
            np = nl + 1
         ELSE
            np = nl
         ENDIF
         IF ((np == nl) .AND. (gmaxp*real(nl)/rl < fac_1)) &
            np = nl + 1
         ifft235 = 2**np
         RETURN
      ENDIF

!====> RADIX 2 , 3, 5 CALCULATION

!----> since gmaxp is large enough, try also smaller n

      IF (gmaxp > fac_2 .AND. gmaxp < fac_3) THEN
         is = -1
      ELSE
         is = 1
      ENDIF
      np = n
      nn = n

      DO itrial = 1, 200

         !----> check whether there is a number close by, which is 2**NL
         !      ( FFT very fast )

         rl = log(real(nn))/log(two)
         nl = rl
         IF ((abs(real(nl)/rl - one) < fac_4) .AND. &
             (2**nl >= n)) THEN
            IF (gmaxp*real(nl)/rl > one) ifft235 = 2**nl
            RETURN
         ELSE IF ((abs(real(nl + 1)/rl - one) < fac_4) .AND. &
                  (2**(nl + 1) >= n)) THEN
            ifft235 = 2**(nl + 1)
            RETURN
         ELSE

            !----> no , no binary number is arround, check wether number can be
            !      divided by 2,3 or 5

            DO iexp = 1, nl + 1
               IF (mod(nn, 2) == 0) THEN
                  nn = nn/2
               ELSE IF (mod(nn, 3) == 0) THEN
                  nn = nn/3
               ELSE IF (mod(nn, 5) == 0) THEN
                  nn = nn/5
               ENDIF
               IF (nn == 2 .OR. nn == 3 .OR. nn == 5) THEN
                  !---> o.k.
                  ifft235 = np
                  RETURN
               ENDIF
            ENDDO

            !----> no , n  cannot be expressed as (2**P) * (3**Q) * (5**R)
            !      change number
            nn = n + (is**(itrial))*((itrial + 1)/2)
            np = n + (is**(itrial))*((itrial + 1)/2)
         ENDIF
      ENDDO

      call juDFT_error(' to few trials '//int2str(itrial))

   END FUNCTION ifft235
!-----------------------------------------------------------------------
   INTEGER FUNCTION i2357(ii)

! simple setup to determine fft-length for ESSL calls

      IMPLICIT NONE
      INTEGER, INTENT(IN)  :: ii
      INTEGER :: i, j, k, h, m, n, nn

      nn = 12582912
      DO m = 0, 1
         DO k = 0, 1
            DO j = 0, 1
               DO i = 0, 1
                  DO h = 1, 25
                     n = 2**h*3**i*5**j*7**k*11**m
                     IF ((n > ii) .AND. (n < nn)) nn = n
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
      ENDDO
      i2357 = nn

   END FUNCTION i2357

END MODULE m_ifft


!
!   FnVFBRet.f90
!
!
!   Created by Kurt Mitman on 17/10/14.

DOUBLE PRECISION FUNCTION FnVFBRet(bsav)

USE Params
USE Globals
USE funcs
USE Procedures

IMPLICIT NONE

DOUBLE PRECISION, INTENT(IN) :: bsav
DOUBLE PRECISION             :: cons,qltemp,qmtemp
DOUBLE PRECISION             :: vals(2)
INTEGER                      :: inds(2)

call basefun(GridB,nb,bsav,vals,inds)

! call BiLinInterp1(nb,GridB,ngpPh,PhGrid,qmret(:,gil,gim,gih,giExo,:,gij+1),bsav,gPh,qmtemp)
! call BiLinInterp1(nb,GridB,ngpPh,PhGrid,qlret(:,gil,gim,gih,giExo,:,gij+1),bsav,gPh,qltemp)

qmtemp = sum(vals*qmret(:,gil,gim,gih,giExo,giPh,gij+1))
qltemp = sum(vals*qlret(:,gil,gim,gih,giExo,giPh,gij+1))

cons=gliq+(qltemp*gloc+qmtemp*gmort)*ghouse-FnQb(bsav,(gPh-gmort)*ghouse)*bsav

if(cons .GT. cmin) then

FnVFBRet = -1.0d0*(uown(cons,ghouse,gij)+bet*(vals(1)*EVownRet(inds(1),gil,gim,gih,gij)+vals(2)*EVownRet(inds(2),gil,gim,gih,gij)))

else

FnVFBRet = 1.0d10+10.0d0*(cmin-cons)

endif

END FUNCTION FnVFBRet


!======================================================================!
  subroutine Time_And_Length_Scale(grid)
!----------------------------------------------------------------------!
!  Purpose:                                                            !
!  Calculates time scale and leght scale in manner to avoid singularity!
!  in Eps equation.                                                     !
!                                                                      !
!  Authors: Muhamed Hadziabdic
!----------------------------------------------------------------------!
!------------------------------[Modules]-------------------------------!
  use all_mod
  use pro_mod
  use les_mod
  use rans_mod
  use Grid_Mod
  use Parameters_Mod
!----------------------------------------------------------------------!
  implicit none
  type(Grid_Type) :: grid
!-------------------------------[Locals]-------------------------------!
  integer c
  real T1, T2, L1, L2, L3, T3
!======================================================================!

  if(SIMULA==K_EPS_VV) then
    do c = 1, grid % n_cells
      T1 = Kin%n(c)/(Eps%n(c) )
      T2 = Ct*(abs(VISc/(Eps%n(c) )))**0.5
      T3 = 0.6*Kin % n(c) / ( CmuD * v_2 % n(c) * Shear(c) *&
           sqrt(3.0))
      L1 = Kin%n(c)**1.5/(Eps%n(c))
      L2 = Cni*(VISc**3/(Eps%n(c)))**0.25
      L3 = Kin % n(c)**1.5 / ( CmuD * v_2 % n(c) *&
           Shear(c) * sqrt(3.0))
      Tsc(c) = max(min(T1,T3),T2)
      Lsc(c) = Cl*max(min(L1,L3),L2)
    end do
  else if(SIMULA == ZETA.or.SIMULA==HYB_ZETA) then
    if(ROUGH == YES) then
      do c = 1, grid % n_cells
        T1 = Kin%n(c)/(Eps%n(c))
        T2 = Ct*sqrt(VISc/Eps%n(c))

        L1 = Kin%n(c)**1.5/Eps%n(c)
        L2 = Cni*(VISc**3/Eps%n(c))**0.25

        Tsc(c) = max(T1,T2)
        Lsc(c) = Cl*max(L1,L2)
      end do
    else
      do c = 1, grid % n_cells
        T1 = Kin%n(c)/(Eps%n(c) + tiny)
        T2 = Ct*sqrt(VISc/Eps%n(c))
        T3 = 0.6/(sqrt(3.0)*CmuD * v_2 % n(c) * Shear(c))

        L1 = Kin%n(c)**1.5/Eps%n(c)
        L2 = Cni*(VISc**3/Eps%n(c))**0.25
        L3 = sqrt(Kin % n(c)/3.0)/(CmuD * v_2 % n(c) * Shear(c))

        Tsc(c) = max(min(T1,T3),T2)
        Lsc(c) = Cl*max(min(L1,L3),L2)
      end do
    end if
  else if(SIMULA == EBM) then
    do c = 1, grid % n_cells
      Kin % n(c) = max(0.5*(uu % n(c) + vv % n(c) + ww % n(c)),1.0e-12)
      T1 = Kin%n(c)/(Eps%n(c))
      T2 = Ct*sqrt(VISc/abs(Eps%n(c)))

      L1 = Kin%n(c)**1.5/Eps%n(c)
      L2 = Cni*(VISc**3/abs(Eps%n(c)))**0.25

      Tsc(c) = max(T1,T2)
      Lsc(c) = Cl*max(L1,L2)
    end do
  end if

  end subroutine