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

Program test_kmeans
  Use ieee_arithmetic
  Use iso_c_binding
  Use mlf_intf
  Use mlf_rsc_array
  Use mlf_step_algo
  Use mlf_utils
  Use mlf_rand
  Use mlf_kmeans_naive
  Use mlf_kmeans
  IMPLICIT NONE
  CALL testkmeans()
CONTAINS
  Subroutine testkmeans()
    integer, parameter :: nX = 1024, nY = 16, nC = 6
    real(c_double), allocatable, target :: X(:,:), Mu(:,:)
    integer, allocatable :: idx(:)
    real(c_double) :: dt
    integer(kind=8) :: nstep = 32
    type(mlf_algo_kmeans_naive) :: km_algo
    integer :: i, info

    info = mlf_init()

    ALLOCATE(X(nY,nX*nC), Mu(nY, nC), idx(NC))
    CALL RandN(Mu, 10d0)
    CALL PrintMatrix(Mu)
    Do i=1,nC
      CALL RandN(X(:,(1+(i-1)*nX):(i*nX)), 1d0, Mu(:,i))
    End Do
    info = km_algo%init(X, nC)
    info = km_algo%step(dt, nstep)
    PRINT *, dt
    CALL mlf_match_points(Mu, km_algo%Mu, idx)
    CALL PrintMatrix(km_algo%Mu(:,idx))
    CALL km_algo%finalize()
    info = mlf_quit()
  End Subroutine testkmeans
End program test_kmeans


!========================================================================
!
!                   S P E C F E M 2 D  Version 7 . 0
!                   --------------------------------
!
!     Main historical authors: Dimitri Komatitsch and Jeroen Tromp
!                        Princeton University, USA
!                and CNRS / University of Marseille, France
!                 (there are currently many more authors!)
! (c) Princeton University and CNRS / University of Marseille, April 2014
!
! This software is a computer program whose purpose is to solve
! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
! using a spectral-element method (SEM).
!
! This software is governed by the CeCILL license under French law and
! abiding by the rules of distribution of free software. You can use,
! modify and/or redistribute the software under the terms of the CeCILL
! license as circulated by CEA, CNRS and Inria at the following URL
! "http://www.cecill.info".
!
! As a counterpart to the access to the source code and rights to copy,
! modify and redistribute granted by the license, users are provided only
! with a limited warranty and the software's author, the holder of the
! economic rights, and the successive licensors have only limited
! liability.
!
! In this respect, the user's attention is drawn to the risks associated
! with loading, using, modifying and/or developing or reproducing the
! software by the user in light of its specific status of free software,
! that may mean that it is complicated to manipulate, and that also
! therefore means that it is reserved for developers and experienced
! professionals having in-depth computer knowledge. Users are therefore
! encouraged to load and test the software's suitability as regards their
! requirements in conditions enabling the security of their systems and/or
! data to be ensured and, more generally, to use and operate it in the
! same conditions as regards security.
!
! The full text of the license is available in file "LICENSE".
!
!========================================================================

  subroutine is_in_convex_quadrilateral(elmnt_coords, x_coord, z_coord, is_in)

  implicit none

  double precision, dimension(2,4)  :: elmnt_coords
  double precision, intent(in)  :: x_coord, z_coord
  logical, intent(out)  :: is_in

  real :: x1, x2, x3, x4, z1, z2, z3, z4
  real  :: normal1, normal2, normal3, normal4

  x1 = elmnt_coords(1,1)
  x2 = elmnt_coords(1,2)
  x3 = elmnt_coords(1,3)
  x4 = elmnt_coords(1,4)
  z1 = elmnt_coords(2,1)
  z2 = elmnt_coords(2,2)
  z3 = elmnt_coords(2,3)
  z4 = elmnt_coords(2,4)

  normal1 = (z_coord-z1) * (x2-x1) - (x_coord-x1) * (z2-z1)
  normal2 = (z_coord-z2) * (x3-x2) - (x_coord-x2) * (z3-z2)
  normal3 = (z_coord-z3) * (x4-x3) - (x_coord-x3) * (z4-z3)
  normal4 = (z_coord-z4) * (x1-x4) - (x_coord-x4) * (z1-z4)

  if ((normal1 < 0) .or. (normal2 < 0) .or. (normal3 < 0) .or. (normal4 < 0)) then
    is_in = .false.
  else
    is_in = .true.
  endif

  end subroutine is_in_convex_quadrilateral


      subroutine roth(naxes,fi,dx,dy,dz,nlines,nbeg,nend)
      common/gfcrdn/xp,yp,zp
      dimension r(4,4)
      dimension dx(2,nlines),dy(2,nlines),dz(2,nlines)
C *********************************************************
C    rotate about the axes "naxes" on angle "fi" in right c.s.
C    clockwice if look from the end of the unit axes vector
C    to the origin.
C *********************************************************
      fi=fi*3.14159265/180.
      call strot3(naxes,cos(fi),sin(fi),r)
      do 5 j=nbeg,nend
      do 5 i=1,2
      call hcncor(dx(i,j),dy(i,j),dz(i,j),r)
      dx(i,j)=xp
      dy(i,j)=yp
      dz(i,j)=zp
5      continue
      return
      end


program test_md
use types, only: dp
use constants, only: ang2bohr, K2au, density2gcm3, u2au, s2au
use md, only: velocity_verlet, minimize_energy
use random, only: randn
use utils, only: init_random, stop_error
implicit none

! All variables are in Hartree atomic units

integer, parameter :: N = 864
integer :: i, steps, u
real(dp) :: dt, V(3, N), X(3, N), f(3, N), m(N), L, t, Rcut, eps, sigma, rho
real(dp) :: Temp, Ekin, Epot, Temp_current, t1, t2, t3, t4

steps = 800
dt = 1e-14_dp * s2au
m = 39.948_dp * u2au ! Using Argon mass in atomic mass units [u]
sigma = 3.4_dp * ang2bohr
eps = 120 * K2au
Rcut = 2.25_dp*sigma
rho = 1.374_dp / density2gcm3
Temp = 94.4_dp * K2au

L = (sum(m) / rho)**(1._dp/3)
rho = sum(m) / L**3
print *, "Input:"
print *, "N =", N
print *, "rho = ", rho * density2gcm3, "g/cm^3 = ", rho, "a.u."
print *, "T =", Temp / K2au, "K =", Temp, "a.u."
print "('dt =', es10.2, ' s = ', es10.2, ' ps = ', f8.2, ' a.u.')", dt/s2au, &
    dt/s2au * 1e12_dp, dt
print *, "eps =", eps / K2au, "K/kB =", eps, "a.u.";
print *, "sigma =", sigma / ang2bohr, " A =", sigma, "a.u."
print *, "Rcut =", Rcut / sigma, " sigma =", Rcut, "a.u."
print *
print *, "Calculated quantities:"
print *, "L =", L/sigma, "sigma = ", L, "a.u."
print *

call init_random()
call random_number(X)
X = L*X

call cpu_time(t1)
call minimize_energy(forces, calc_Epot, X, f, h0=1._dp, max_iter=50)
call cpu_time(t2)

call randn(V)
V = V * sqrt(Temp / spread(m, 1, 3))

open(newunit=u, file="md_results.txt", status="replace", form="unformatted")
t = 0
call cpu_time(t3)
do i = 1, steps
    Ekin = calc_Ekin(V, m)
    Epot = calc_Epot(X)
    Temp_current = 2*Ekin/(3*N)
    print "(i5, ': E=', f10.4, ' a.u.; Epot=', f10.4, ' a.u.; T=',f10.4,' K')",&
        i, Ekin + Epot, Epot, Temp_current / K2au
    write(u) t/s2au, f, V, X, Ekin, Epot, Temp_current / K2au
    call velocity_verlet(dt, m, L, forces, f, V, X)
    t = t + dt
    if (i < 100) then
        Ekin = calc_Ekin(V, m)
        Temp_current = 2*Ekin/(3*N)
        V = V * sqrt(Temp / Temp_current)
    end if
end do
call cpu_time(t4)
close(u)
print "('TIMINGS')"
print "('Minimization:', f10.4, 's')", t2-t1
print "('MD run:      ', f10.4, 's')", t4-t3
print "('MD step:     ', f10.4, 's')", (t4-t3)/steps

contains

    subroutine forces(X, f)
    real(dp), intent(in) :: X(:, :) ! positions
    real(dp), intent(out) :: f(:, :) ! forces
    real(dp) :: r2, d(3), force(3), Xj(3)
    integer :: N, i, j
    N = size(X, 2)
    f = 0
    do i = 1, N
        do j = 1, i-1
            Xj = X(:, j)-X(:, i)+[L/2, L/2, L/2]
            Xj = Xj - L*floor(Xj/L)
            d = [L/2, L/2, L/2] - Xj
            r2 = sum(d**2)
            if (r2 <= Rcut**2) then
                force = 24*eps*d/r2 * (2*sigma**12/r2**6 - sigma**6/r2**3)
                f(:, i) = f(:, i) + force
                f(:, j) = f(:, j) - force
            end if
        end do
    end do
    end subroutine

    real(dp) function calc_Epot(X) result(E)
    real(dp), intent(in) :: X(:, :) ! positions
    real(dp) :: r2, d(3), Xj(3)
    integer :: N, i, j
    N = size(X, 2)
    E = 0
    do i = 1, N
        do j = 1, i-1
            Xj = X(:, j)-X(:, i)+[L/2, L/2, L/2]
            Xj = Xj - L*floor(Xj/L)
            d = [L/2, L/2, L/2] - Xj
            r2 = sum(d**2)
            if (r2 <= Rcut**2) E = E + 4*eps *(sigma**12/r2**6 - sigma**6/r2**3)
        end do
    end do
    end function

    real(dp) pure function calc_Ekin(V, m) result(Ekin)
    real(dp), intent(in) :: V(:, :) ! velocities
    real(dp), intent(in) :: m(:) ! masses
    Ekin = sum(m*sum(V**2, dim=1))/2
    end function

end program


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Spherepack                            *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
submodule(vector_laplacian_routines) invert_vector_laplacian_regular_grid

contains
    !     subroutine ivlapec(nlat, nlon, ityp, nt, v, w, idvw, jdvw, br, bi, cr, ci,
    !    +mdbc, ndbc, wvhsec, lvhsec, work, lwork, ierror)
    !
    !
    !     subroutine ivlapec computes a the vector field (v, w) whose vector
    !     laplacian is (vlap, wlap).  w and wlap are east longitudinal
    !     components of the vectors.  v and vlap are colatitudinal components
    !     of the vectors.  br, bi, cr, and ci are the vector harmonic coefficients
    !     of (vlap, wlap).  these must be precomputed by vhaec and are input
    !     parameters to ivlapec.  (v, w) have the same symmetry or lack of
    !     symmetry about the about the equator as (vlap, wlap).  the input
    !     parameters ityp, nt, mdbc, ndbc must have the same values used by
    !     vhaec to compute br, bi, cr, and ci for (vlap, wlap).
    !
    !
    !     input parameters
    !
    !     nlat   the number of colatitudes on the full sphere including the
    !            poles. for example, nlat = 37 for a five degree grid.
    !            nlat determines the grid increment in colatitude as
    !            pi/(nlat-1).  if nlat is odd the equator is located at
    !            grid point i=(nlat + 1)/2. if nlat is even the equator is
    !            located half way between points i=nlat/2 and i=nlat/2+1.
    !            nlat must be at least 3. note: on the half sphere, the
    !            number of grid points in the colatitudinal direction is
    !            nlat/2 if nlat is even or (nlat + 1)/2 if nlat is odd.
    !
    !     nlon   the number of distinct longitude points.  nlon determines
    !            the grid increment in longitude as 2*pi/nlon. for example
    !            nlon = 72 for a five degree grid. nlon must be greater
    !            than zero. the axisymmetric case corresponds to nlon=1.
    !            the efficiency of the computation is improved when nlon
    !            is a product of small prime numbers.
    !
    !     ityp   this parameter should have the same value input to subroutine
    !            vhaec to compute the coefficients br, bi, cr, and ci for the
    !            vector field (vlap, wlap).  ityp is set as follows:
    !
    !            = 0  no symmetries exist in (vlap, wlap) about the equator. (v, w)
    !                 is computed and stored on the entire sphere in the arrays
    !                 arrays v(i, j) and w(i, j) for i=1, ..., nlat and j=1, ..., nlon.
    !
    !            = 1  no symmetries exist in (vlap, wlap) about the equator. (v, w)
    !                 is computed and stored on the entire sphere in the arrays
    !                 v(i, j) and w(i, j) for i=1, ..., nlat and j=1, ..., nlon.  the
    !                 vorticity of (vlap, wlap) is zero so the coefficients cr and
    !                 ci are zero and are not used.  the vorticity of (v, w) is
    !                 also zero.
    !
    !
    !            = 2  no symmetries exist in (vlap, wlap) about the equator. (v, w)
    !                 is computed and stored on the entire sphere in the arrays
    !                 w(i, j) and v(i, j) for i=1, ..., nlat and j=1, ..., nlon.  the
    !                 divergence of (vlap, wlap) is zero so the coefficients br and
    !                 bi are zero and are not used.  the divergence of (v, w) is
    !                 also zero.
    !
    !            = 3  wlap is antisymmetric and vlap is symmetric about the
    !                 equator. consequently w is antisymmetric and v is symmetric.
    !                 (v, w) is computed and stored on the northern hemisphere
    !                 only.  if nlat is odd, storage is in the arrays v(i, j),
    !                 w(i, j) for i=1, ..., (nlat + 1)/2 and j=1, ..., nlon.  if nlat
    !                 is even, storage is in the arrays v(i, j), w(i, j) for
    !                 i=1, ..., nlat/2 and j=1, ..., nlon.
    !
    !            = 4  wlap is antisymmetric and vlap is symmetric about the
    !                 equator. consequently w is antisymmetric and v is symmetric.
    !                 (v, w) is computed and stored on the northern hemisphere
    !                 only.  if nlat is odd, storage is in the arrays v(i, j),
    !                 w(i, j) for i=1, ..., (nlat + 1)/2 and j=1, ..., nlon.  if nlat
    !                 is even, storage is in the arrays v(i, j), w(i, j) for
    !                 i=1, ..., nlat/2 and j=1, ..., nlon.  the vorticity of (vlap,
    !                 wlap) is zero so the coefficients cr, ci are zero and
    !                 are not used. the vorticity of (v, w) is also zero.
    !
    !            = 5  wlap is antisymmetric and vlap is symmetric about the
    !                 equator. consequently w is antisymmetric and v is symmetric.
    !                 (v, w) is computed and stored on the northern hemisphere
    !                 only.  if nlat is odd, storage is in the arrays w(i, j),
    !                 v(i, j) for i=1, ..., (nlat + 1)/2 and j=1, ..., nlon.  if nlat
    !                 is even, storage is in the arrays w(i, j), v(i, j) for
    !                 i=1, ..., nlat/2 and j=1, ..., nlon.  the divergence of (vlap,
    !                 wlap) is zero so the coefficients br, bi are zero and
    !                 are not used. the divergence of (v, w) is also zero.
    !
    !
    !            = 6  wlap is symmetric and vlap is antisymmetric about the
    !                 equator. consequently w is symmetric and v is antisymmetric.
    !                 (v, w) is computed and stored on the northern hemisphere
    !                 only.  if nlat is odd, storage is in the arrays w(i, j),
    !                 v(i, j) for i=1, ..., (nlat + 1)/2 and j=1, ..., nlon.  if nlat
    !                 is even, storage is in the arrays w(i, j), v(i, j) for
    !                 i=1, ..., nlat/2 and j=1, ..., nlon.
    !
    !            = 7  wlap is symmetric and vlap is antisymmetric about the
    !                 equator. consequently w is symmetric and v is antisymmetric.
    !                 (v, w) is computed and stored on the northern hemisphere
    !                 only.  if nlat is odd, storage is in the arrays w(i, j),
    !                 v(i, j) for i=1, ..., (nlat + 1)/2 and j=1, ..., nlon.  if nlat
    !                 is even, storage is in the arrays w(i, j), v(i, j) for
    !                 i=1, ..., nlat/2 and j=1, ..., nlon.  the vorticity of (vlap,
    !                 wlap) is zero so the coefficients cr, ci are zero and
    !                 are not used. the vorticity of (v, w) is also zero.
    !
    !            = 8  wlap is symmetric and vlap is antisymmetric about the
    !                 equator. consequently w is symmetric and v is antisymmetric.
    !                 (v, w) is computed and stored on the northern hemisphere
    !                 only.  if nlat is odd, storage is in the arrays w(i, j),
    !                 v(i, j) for i=1, ..., (nlat + 1)/2 and j=1, ..., nlon.  if nlat
    !                 is even, storage is in the arrays w(i, j), v(i, j) for
    !                 i=1, ..., nlat/2 and j=1, ..., nlon.  the divergence of (vlap,
    !                 wlap) is zero so the coefficients br, bi are zero and
    !                 are not used. the divergence of (v, w) is also zero.
    !
    !
    !     nt     nt is the number of vector fields (vlap, wlap). some computational
    !            efficiency is obtained for multiple fields.  in the program
    !            that calls ivlapec, the arrays v, w, br, bi, cr and ci can be
    !            three dimensional corresponding to an indexed multiple vector
    !            field.  in this case multiple vector synthesis will be performed
    !            to compute the (v, w) for each field (vlap, wlap).  the third
    !            index is the synthesis index which assumes the values k=1, ..., nt.
    !            for a single synthesis set nt=1.  the description of the
    !            remaining parameters is simplified by assuming that nt=1 or
    !            that all arrays are two dimensional.
    !
    !   idvw     the first dimension of the arrays w and v as it appears in
    !            the program that calls ivlapec.  if ityp=0, 1, or 2  then idvw
    !            must be at least nlat.  if ityp > 2 and nlat is even then idvw
    !            must be at least nlat/2. if ityp > 2 and nlat is odd then idvw
    !            must be at least (nlat + 1)/2.
    !
    !   jdvw     the second dimension of the arrays w and v as it appears in
    !            the program that calls ivlapec. jdvw must be at least nlon.
    !
    !
    !   br, bi    two or three dimensional arrays (see input parameter nt)
    !   cr, ci    that contain vector spherical harmonic coefficients of the
    !            vector field (vlap, wlap) as computed by subroutine vhaec.
    !            br, bi, cr and ci must be computed by vhaec prior to calling
    !            ivlapec.  if ityp=1, 4, or 7 then cr, ci are not used and can
    !            be dummy arguments.  if ityp=2, 5, or 8 then br, bi are not
    !            used and can be dummy arguments.
    !
    !    mdbc    the first dimension of the arrays br, bi, cr and ci as it
    !            appears in the program that calls ivlapec.  mdbc must be
    !            at least min(nlat, nlon/2) if nlon is even or at least
    !            min(nlat, (nlon + 1)/2) if nlon is odd.
    !
    !    ndbc    the second dimension of the arrays br, bi, cr and ci as it
    !            appears in the program that calls ivlapec. ndbc must be at
    !            least nlat.
    !
    !    wvhsec  an array which must be initialized by subroutine vhseci.
    !            once initialized, wvhsec
    !            can be used repeatedly by ivlapec as long as nlat and nlon
    !            remain unchanged.  wvhsec must not be altered between calls
    !            of ivlapec.
    !
    !    lvhsec  the dimension of the array wvhsec as it appears in the
    !            program that calls ivlapec.  let
    !
    !               l1 = min(nlat, nlon/2) if nlon is even or
    !               l1 = min(nlat, (nlon + 1)/2) if nlon is odd
    !
    !            and
    !
    !               l2 = nlat/2        if nlat is even or
    !               l2 = (nlat + 1)/2    if nlat is odd.
    !
    !            then lvhsec must be at least
    !
    !            4*nlat*l2+3*max(l1-2, 0)*(2*nlat-l1-1)+nlon+15
    !
    !     output parameters
    !
    !
    !    v, w     two or three dimensional arrays (see input parameter nt) that
    !            contain a vector field whose vector laplacian is (vlap, wlap).
    !            w(i, j) is the east longitude and v(i, j) is the colatitudinal
    !            component of the vector. v(i, j) and w(i, j) are given on the
    !            sphere at the colatitude
    !
    !                 theta(i) = (i-1)*pi/(nlat-1)
    !
    !            for i=1, ..., nlat and east longitude
    !
    !                 lambda(j) = (j-1)*2*pi/nlon
    !
    !            for j=1, ..., nlon.
    !
    !            let cost and sint be the cosine and sine at colatitude theta.
    !            let d()/dlambda  and d()/dtheta be the first order partial
    !            derivatives in longitude and colatitude.  let sf be either v
    !            or w.  define:
    !
    !                 del2s(sf) = [d(sint*d(sf)/dtheta)/dtheta +
    !                               2            2
    !                              d (sf)/dlambda /sint]/sint
    !
    !            then the vector laplacian of (v, w) in (vlap, wlap) satisfies
    !
    !                 vlap = del2s(v) + (2*cost*dw/dlambda - v)/sint**2
    !
    !            and
    !
    !                 wlap = del2s(w) - (2*cost*dv/dlambda + w)/sint**2
    !
    !
    !  ierror    a parameter which flags errors in input parameters as follows:
    !
    !            = 0  no errors detected
    !            = 1  error in the specification of nlat
    !            = 2  error in the specification of nlon
    !            = 3  error in the specification of ityp
    !            = 4  error in the specification of nt
    !            = 5  error in the specification of idvw
    !            = 6  error in the specification of jdvw
    !            = 7  error in the specification of mdbc
    !            = 8  error in the specification of ndbc
    !            = 9  error in the specification of lvhsec
    !
    module subroutine ivlapec(nlat, nlon, ityp, nt, v, w, idvw, jdvw, br, bi, cr, ci, &
        mdbc, ndbc, wvhsec, ierror)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip), intent(in)  :: ityp
        integer(ip), intent(in)  :: nt
        real(wp),    intent(out) :: v(idvw, jdvw, nt)
        real(wp),    intent(out) :: w(idvw, jdvw, nt)
        integer(ip), intent(in)  :: idvw
        integer(ip), intent(in)  :: jdvw
        real(wp),    intent(in)  :: br(mdbc, ndbc, nt)
        real(wp),    intent(in)  :: bi(mdbc, ndbc, nt)
        real(wp),    intent(in)  :: cr(mdbc, ndbc, nt)
        real(wp),    intent(in)  :: ci(mdbc, ndbc, nt)
        integer(ip), intent(in)  :: mdbc
        integer(ip), intent(in)  :: ndbc
        real(wp),    intent(in)  :: wvhsec(:)
        integer(ip), intent(out) :: ierror

        ! Local variables
        integer(ip) :: required_wavetable_size
        type(VectorSynthesisUtility) :: util

        ! Check input arguments
        required_wavetable_size = util%get_lvhsec(nlat, nlon)

        call util%check_vector_transform_inputs(ityp, idvw, jdvw, &
            mdbc, ndbc, nlat, nlon, nt, required_wavetable_size, &
            wvhsec, ierror)

        ! Check error flag
        if (ierror /= 0) return

        call invert_vector_laplacian_lower_utility_routine(nlat, nlon, ityp, nt, v, w, &
            br, bi, cr, ci, wvhsec, vhsec, ierror)

    end subroutine ivlapec

end submodule invert_vector_laplacian_regular_grid


module mod_mom
  use mod_types
  implicit none
  private
  public momx_a,momy_a,momz_a,momx_d,momy_d,momz_d,momx_p,momy_p,momz_p
  contains
  subroutine momx_a(lo,hi,dxc,dxf,dyf,dzf,u,v,w,dudt)
    implicit none
    integer , intent(in), dimension(3) :: lo,hi
    real(rp), intent(in), dimension(lo(1)-1:) :: dxc,dxf
    real(rp), intent(in), dimension(lo(2)-1:) :: dyf
    real(rp), intent(in), dimension(lo(3)-1:) :: dzf
    real(rp), dimension(lo(1)-1:,lo(2)-1:,lo(3)-1:), intent(in   ) :: u,v,w
    real(rp), dimension(lo(1):  ,lo(2):  ,lo(3):  ), intent(inout) :: dudt
    real(rp) :: uuip,uuim,uvjp,uvjm,uwkp,uwkm
    integer  :: i,j,k
    !
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP PRIVATE(uuip,uuim,uvjp,uvjm,uwkp,uwkm) &
    !$OMP SHARED(lo,hi,dxc,dxf,dyf,dzf,u,v,w,dudt)
    do k=lo(3),hi(3)
      do j=lo(2),hi(2)
        do i=lo(1),hi(1)
          uuip  = 0.25_rp*( u(i+1,j,k)+u(i,j,k) )*( u(i+1,j  ,k  )+u(i,j  ,k  ) )
          uuim  = 0.25_rp*( u(i-1,j,k)+u(i,j,k) )*( u(i-1,j  ,k  )+u(i,j  ,k  ) )
          uvjp  = 0.25_rp*( u(i,j+1,k)+u(i,j,k) )*( v(i+1,j  ,k  )+v(i,j  ,k  ) )
          uvjm  = 0.25_rp*( u(i,j-1,k)+u(i,j,k) )*( v(i+1,j-1,k  )+v(i,j-1,k  ) )
          uwkp  = 0.25_rp*( u(i,j,k+1)+u(i,j,k) )*( w(i+1,j  ,k  )+w(i,j  ,k  ) )
          uwkm  = 0.25_rp*( u(i,j,k-1)+u(i,j,k) )*( w(i+1,j  ,k-1)+w(i,j  ,k-1) )
          !
          ! Momentum balance
          !
          dudt(i,j,k) = dudt(i,j,k) + &
                        ( -uuip + uuim )/dxc(i) + &
                        ( -uvjp + uvjm )/dyf(j) + &
                        ( -uwkp + uwkm )/dzf(k)
        end do
      end do
    end do
    !$OMP END PARALLEL DO
  end subroutine momx_a
  !
  subroutine momy_a(lo,hi,dxf,dyc,dyf,dzf,u,v,w,dvdt)
    implicit none
    integer , intent(in), dimension(3) :: lo,hi
    real(rp), intent(in), dimension(lo(1)-1:) :: dxf
    real(rp), intent(in), dimension(lo(2)-1:) :: dyc,dyf
    real(rp), intent(in), dimension(lo(3)-1:) :: dzf
    real(rp), dimension(lo(1)-1:,lo(2)-1:,lo(3)-1:), intent(in   ) :: u,v,w
    real(rp), dimension(lo(1):  ,lo(2):  ,lo(3):  ), intent(inout) :: dvdt
    real(rp) :: uvip,uvim,vvjp,vvjm,wvkp,wvkm
    integer  :: i,j,k
    !
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP PRIVATE(uvip,uvim,vvjp,vvjm,wvkp,wvkm) &
    !$OMP SHARED(lo,hi,dxf,dyc,dyf,dzf,u,v,w,dvdt)
    do k=lo(3),hi(3)
      do j=lo(2),hi(2)
        do i=lo(1),hi(1)
          uvip  = 0.25_rp*( u(i  ,j,k  )+u(i  ,j+1,k  ) )*( v(i,j,k  )+v(i+1,j  ,k) )
          uvim  = 0.25_rp*( u(i-1,j,k  )+u(i-1,j+1,k  ) )*( v(i,j,k  )+v(i-1,j  ,k) )
          vvjp  = 0.25_rp*( v(i  ,j,k  )+v(i  ,j+1,k  ) )*( v(i,j,k  )+v(i  ,j+1,k) )
          vvjm  = 0.25_rp*( v(i  ,j,k  )+v(i  ,j-1,k  ) )*( v(i,j,k  )+v(i  ,j-1,k) )
          wvkp  = 0.25_rp*( w(i  ,j,k  )+w(i  ,j+1,k  ) )*( v(i,j,k+1)+v(i  ,j  ,k) )
          wvkm  = 0.25_rp*( w(i  ,j,k-1)+w(i  ,j+1,k-1) )*( v(i,j,k-1)+v(i  ,j  ,k) )
          !
          ! Momentum balance
          !
          dvdt(i,j,k) = dvdt(i,j,k) + &
                        ( -uvip + uvim )/dxf(i) + &
                        ( -vvjp + vvjm )/dyc(j) + &
                        ( -wvkp + wvkm )/dzf(k)
        end do
      end do
    end do
    !$OMP END PARALLEL DO
  end subroutine momy_a
  !
  subroutine momz_a(lo,hi,dxf,dyf,dzc,dzf,u,v,w,dwdt)
    implicit none
    integer , intent(in), dimension(3) :: lo,hi
    real(rp), intent(in), dimension(lo(1)-1:) :: dxf
    real(rp), intent(in), dimension(lo(2)-1:) :: dyf
    real(rp), intent(in), dimension(lo(3)-1:) :: dzc,dzf
    real(rp), dimension(lo(1)-1:,lo(2)-1:,lo(3)-1:), intent(in   ) :: u,v,w
    real(rp), dimension(lo(1):  ,lo(2):  ,lo(3):  ), intent(inout) :: dwdt
    real(rp) :: uwip,uwim,vwjp,vwjm,wwkp,wwkm
    integer  :: i,j,k
    !
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP PRIVATE(uwip,uwim,vwjp,vwjm,wwkp,wwkm) &
    !$OMP SHARED(lo,hi,dxf,dyf,dzc,dzf,u,v,w,dwdt)
    do k=lo(3),hi(3)
      do j=lo(2),hi(2)
        do i=lo(1),hi(1)
          uwip  = 0.25_rp*( w(i,j,k)+w(i+1,j,k) )*( u(i  ,j  ,k)+u(i  ,j  ,k+1) )
          uwim  = 0.25_rp*( w(i,j,k)+w(i-1,j,k) )*( u(i-1,j  ,k)+u(i-1,j  ,k+1) )
          vwjp  = 0.25_rp*( w(i,j,k)+w(i,j+1,k) )*( v(i  ,j  ,k)+v(i  ,j  ,k+1) )
          vwjm  = 0.25_rp*( w(i,j,k)+w(i,j-1,k) )*( v(i  ,j-1,k)+v(i  ,j-1,k+1) )
          wwkp  = 0.25_rp*( w(i,j,k)+w(i,j,k+1) )*( w(i  ,j  ,k)+w(i  ,j  ,k+1) )
          wwkm  = 0.25_rp*( w(i,j,k)+w(i,j,k-1) )*( w(i  ,j  ,k)+w(i  ,j  ,k-1) )
          !
          ! Momentum balance
          !
          dwdt(i,j,k) = dwdt(i,j,k) + &
                        ( -uwip + uwim )/dxf(i) + &
                        ( -vwjp + vwjm )/dyf(j) + &
                        ( -wwkp + wwkm )/dzc(k)
        end do
      end do
    end do
    !$OMP END PARALLEL DO
  end subroutine momz_a
  !
  subroutine momx_a_vv(lo,hi,dxc,dxf,dyf,dzf,u,v,w,dudt)
    implicit none
    integer , intent(in), dimension(3) :: lo,hi
    real(rp), intent(in), dimension(lo(1)-1:) :: dxc,dxf
    real(rp), intent(in), dimension(lo(2)-1:) :: dyf
    real(rp), intent(in), dimension(lo(3)-1:) :: dzf
    real(rp), dimension(lo(1)-1:,lo(2)-1:,lo(3)-1:), intent(in   ) :: u,v,w
    real(rp), dimension(lo(1):  ,lo(2):  ,lo(3):  ), intent(inout) :: dudt
    real(rp) :: uuip,uuim,uvjp,uvjm,uwkp,uwkm
    integer  :: i,j,k
    !
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP PRIVATE(uuip,uuim,uvjp,uvjm,uwkp,uwkm) &
    !$OMP SHARED(lo,hi,dxc,dxf,dyf,dzf,u,v,w,dudt)
    do k=lo(3),hi(3)
      do j=lo(2),hi(2)
        do i=lo(1),hi(1)
          uuip  = 0.25_rp*(u(i,j  ,k  )*dyf(j)*dzf(k)+u(i+1,j  ,k  )*dyf(j  )*dzf(k))*u(i+1,j,k)
          uuim  = 0.25_rp*(u(i,j  ,k  )*dyf(j)*dzf(k)+u(i-1,j  ,k  )*dyf(j  )*dzf(k))*u(i-1,j,k)
          uvjp  = 0.25_rp*(v(i,j  ,k  )*dxf(i)*dzf(k)+v(i+1,j  ,k  )*dxf(i+1)*dzf(k))*u(i,j+1,k)
          uvjm  = 0.25_rp*(v(i,j-1,k  )*dxf(i)*dzf(k)+v(i+1,j-1,k  )*dxf(i+1)*dzf(k))*u(i,j-1,k)
          uwkp  = 0.25_rp*(w(i,j  ,k  )*dxf(i)*dyf(j)+w(i+1,j  ,k  )*dxf(i+1)*dyf(j))*u(i,j,k+1)
          uwkm  = 0.25_rp*(w(i,j  ,k-1)*dxf(i)*dyf(j)+w(i+1,j  ,k-1)*dxf(i+1)*dyf(j))*u(i,j,k-1)
          !
          ! Momentum balance
          !
          dudt(i,j,k) = dudt(i,j,k) + ( &
                                       ( -uuip + uuim ) + &
                                       ( -uvjp + uvjm ) + &
                                       ( -uwkp + uwkm ) &
                                      )/(dxc(i)*dyf(j)*dzf(k))
        end do
      end do
    end do
    !$OMP END PARALLEL DO
  end subroutine momx_a_vv
  !
  subroutine momy_a_vv(lo,hi,dxf,dyc,dyf,dzf,u,v,w,dvdt)
    implicit none
    integer , intent(in), dimension(3) :: lo,hi
    real(rp), intent(in), dimension(lo(1)-1:) :: dxf
    real(rp), intent(in), dimension(lo(2)-1:) :: dyc,dyf
    real(rp), intent(in), dimension(lo(3)-1:) :: dzf
    real(rp), dimension(lo(1)-1:,lo(2)-1:,lo(3)-1:), intent(in   ) :: u,v,w
    real(rp), dimension(lo(1):  ,lo(2):  ,lo(3):  ), intent(inout) :: dvdt
    real(rp) :: uvip,uvim,vvjp,vvjm,wvkp,wvkm
    integer  :: i,j,k
    !
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP PRIVATE(uvip,uvim,vvjp,vvjm,wvkp,wvkm) &
    !$OMP SHARED(lo,hi,dxf,dyc,dyf,dzf,u,v,w,dvdt)
    do k=lo(3),hi(3)
      do j=lo(2),hi(2)
        do i=lo(1),hi(1)
          uvip  = 0.25_rp*(u(i  ,j,k  )*dyf(j)*dzf(k)+u(i  ,j+1,k  )*dyf(j+1)*dzf(k))*v(i+1,j,k)
          uvim  = 0.25_rp*(u(i-1,j,k  )*dyf(j)*dzf(k)+u(i-1,j+1,k  )*dyf(j+1)*dzf(k))*v(i-1,j,k)
          vvjp  = 0.25_rp*(v(i  ,j,k  )*dxf(i)*dzf(k)+v(i  ,j+1,k  )*dxf(i  )*dzf(k))*v(i,j+1,k)
          vvjm  = 0.25_rp*(v(i  ,j,k  )*dxf(i)*dzf(k)+v(i  ,j-1,k  )*dxf(i  )*dzf(k))*v(i,j-1,k)
          wvkp  = 0.25_rp*(w(i  ,j,k  )*dyf(j)*dxf(i)+w(i  ,j+1,k  )*dyf(j+1)*dxf(i))*v(i,j,k+1)
          wvkm  = 0.25_rp*(w(i  ,j,k-1)*dyf(j)*dxf(i)+w(i  ,j+1,k-1)*dyf(j+1)*dxf(i))*v(i,j,k-1)
          !
          ! Momentum balance
          !
          dvdt(i,j,k) = dvdt(i,j,k) + ( &
                                       ( -uvip + uvim ) + &
                                       ( -vvjp + vvjm ) + &
                                       ( -wvkp + wvkm ) &
                                      )/(dxf(i)*dyc(j)*dzf(k))

        end do
      end do
    end do
    !$OMP END PARALLEL DO
  end subroutine momy_a_vv
  !
  subroutine momz_a_vv(lo,hi,dxf,dyf,dzc,dzf,u,v,w,dwdt)
    implicit none
    integer , intent(in), dimension(3) :: lo,hi
    real(rp), intent(in), dimension(lo(1)-1:) :: dxf
    real(rp), intent(in), dimension(lo(2)-1:) :: dyf
    real(rp), intent(in), dimension(lo(3)-1:) :: dzc,dzf
    real(rp), dimension(lo(1)-1:,lo(2)-1:,lo(3)-1:), intent(in   ) :: u,v,w
    real(rp), dimension(lo(1):  ,lo(2):  ,lo(3):  ), intent(inout) :: dwdt
    real(rp) :: uwip,uwim,vwjp,vwjm,wwkp,wwkm
    integer  :: i,j,k
    !
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP PRIVATE(uwip,uwim,vwjp,vwjm,wwkp,wwkm) &
    !$OMP SHARED(lo,hi,dxf,dyf,dzc,dzf,u,v,w,dwdt)
    do k=lo(3),hi(3)
      do j=lo(2),hi(2)
        do i=lo(1),hi(1)
          uwip  = 0.25_rp*(u(i  ,j  ,k)*dzf(k)*dyf(j)+u(i  ,j  ,k+1)*dzf(k+1)*dyf(j))*w(i+1,j,k)
          uwim  = 0.25_rp*(u(i-1,j  ,k)*dzf(k)*dyf(j)+u(i-1,j  ,k+1)*dzf(k+1)*dyf(j))*w(i+1,j,k)
          vwjp  = 0.25_rp*(v(i  ,j  ,k)*dzf(k)*dxf(i)+v(i  ,j  ,k+1)*dzf(k+1)*dxf(i))*w(i,j+1,k)
          vwjm  = 0.25_rp*(v(i  ,j-1,k)*dzf(k)*dxf(i)+v(i  ,j-1,k+1)*dzf(k+1)*dxf(i))*w(i,j+1,k)
          wwkp  = 0.25_rp*(w(i  ,j  ,k)*dxf(i)*dyf(j)+w(i  ,j  ,k+1)*dxf(i  )*dyf(j))*w(i,j,k+1)
          wwkm  = 0.25_rp*(w(i  ,j  ,k)*dxf(i)*dyf(j)+w(i  ,j  ,k-1)*dxf(i  )*dyf(j))*w(i,j,k-1)
          !
          ! Momentum balance
          !
          dwdt(i,j,k) = dwdt(i,j,k) + ( &
                                       ( -uwip + uwim ) + &
                                       ( -vwjp + vwjm ) + &
                                       ( -wwkp + wwkm ) &
                                      )/(dxf(i)*dyf(j)*dzc(k))
        end do
      end do
    end do
    !$OMP END PARALLEL DO
  end subroutine momz_a_vv
  !
  subroutine momx_d(lo,hi,dxc,dxf,dyc,dyf,dzc,dzf,visc,u,dudt)
    implicit none
    integer , intent(in), dimension(3) :: lo,hi
    real(rp), intent(in), dimension(lo(1)-1:) :: dxc,dxf
    real(rp), intent(in), dimension(lo(2)-1:) :: dyc,dyf
    real(rp), intent(in), dimension(lo(3)-1:) :: dzc,dzf
    real(rp), intent(in)                      :: visc
    real(rp), dimension(lo(1)-1:,lo(2)-1:,lo(3)-1:), intent(in   ) :: u
    real(rp), dimension(lo(1):  ,lo(2):  ,lo(3):  ), intent(inout) :: dudt
    real(rp) :: dudxp,dudxm,dudyp,dudym,dudzp,dudzm
    integer  :: i,j,k
    !
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP PRIVATE(dudxp,dudxm,dudyp,dudym,dudzp,dudzm) &
    !$OMP SHARED(lo,hi,dxc,dxf,dyc,dyf,dzc,dzf,visc,u,dudt)
    do k=lo(3),hi(3)
      do j=lo(2),hi(2)
        do i=lo(1),hi(1)
          dudxp = (u(i+1,j,k)-u(i,j,k))/dxf(i+1)
          dudxm = (u(i,j,k)-u(i-1,j,k))/dxf(i  )
          dudyp = (u(i,j+1,k)-u(i,j,k))/dyc(j  )
          dudym = (u(i,j,k)-u(i,j-1,k))/dyc(j-1)
          dudzp = (u(i,j,k+1)-u(i,j,k))/dzc(k  )
          dudzm = (u(i,j,k)-u(i,j,k-1))/dzc(k-1)
          !
          ! Momentum balance
          !
          dudt(i,j,k) = dudt(i,j,k) + &
                        visc*(dudxp-dudxm)/dxc(i) + &
                        visc*(dudyp-dudym)/dyf(j) + &
                        visc*(dudzp-dudzm)/dzf(k)
        end do
      end do
    end do
    !$OMP END PARALLEL DO
  end subroutine momx_d
  !
  subroutine momy_d(lo,hi,dxc,dxf,dyc,dyf,dzc,dzf,visc,v,dvdt)
    implicit none
    integer , intent(in), dimension(3) :: lo,hi
    real(rp), intent(in), dimension(lo(1)-1:) :: dxc,dxf
    real(rp), intent(in), dimension(lo(2)-1:) :: dyc,dyf
    real(rp), intent(in), dimension(lo(3)-1:) :: dzc,dzf
    real(rp), intent(in)                      :: visc
    real(rp), dimension(lo(1)-1:,lo(2)-1:,lo(3)-1:), intent(in   ) :: v
    real(rp), dimension(lo(1):  ,lo(2):  ,lo(3):  ), intent(inout) :: dvdt
    real(rp) :: dvdxp,dvdxm,dvdyp,dvdym,dvdzp,dvdzm
    integer  :: i,j,k
    !
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP PRIVATE(dvdxp,dvdxm,dvdyp,dvdym,dvdzp,dvdzm) &
    !$OMP SHARED(lo,hi,dxc,dxf,dyc,dyf,dzc,dzf,visc,v,dvdt)
    do k=lo(3),hi(3)
      do j=lo(2),hi(2)
        do i=lo(1),hi(1)
          dvdxp = (v(i+1,j,k)-v(i,j,k))/dxc(i  )
          dvdxm = (v(i,j,k)-v(i-1,j,k))/dxc(i-1)
          dvdyp = (v(i,j+1,k)-v(i,j,k))/dyf(j+1)
          dvdym = (v(i,j,k)-v(i,j-1,k))/dyf(j  )
          dvdzp = (v(i,j,k+1)-v(i,j,k))/dzc(k  )
          dvdzm = (v(i,j,k)-v(i,j,k-1))/dzc(k-1)
          !
          ! Momentum balance
          !
          dvdt(i,j,k) = dvdt(i,j,k) + &
                        visc*(dvdxp-dvdxm)/dxf(i) + &
                        visc*(dvdyp-dvdym)/dyc(j) + &
                        visc*(dvdzp-dvdzm)/dzf(k)
        end do
      end do
    end do
    !$OMP END PARALLEL DO
  end subroutine momy_d
  !
  subroutine momz_d(lo,hi,dxc,dxf,dyc,dyf,dzc,dzf,visc,w,dwdt)
    implicit none
    integer , intent(in), dimension(3) :: lo,hi
    real(rp), intent(in), dimension(lo(1)-1:) :: dxc,dxf
    real(rp), intent(in), dimension(lo(2)-1:) :: dyc,dyf
    real(rp), intent(in), dimension(lo(3)-1:) :: dzc,dzf
    real(rp), intent(in)                      :: visc
    real(rp), dimension(lo(1)-1:,lo(2)-1:,lo(3)-1:), intent(in   ) :: w
    real(rp), dimension(lo(1):  ,lo(2):  ,lo(3):  ), intent(inout) :: dwdt
    real(rp) :: dwdxp,dwdxm,dwdyp,dwdym,dwdzp,dwdzm
    integer  :: i,j,k
    !
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP PRIVATE(dwdxp,dwdxm,dwdyp,dwdym,dwdzp,dwdzm) &
    !$OMP SHARED(lo,hi,dxc,dxf,dyc,dyf,dzc,dzf,visc,w,dwdt)
    do k=lo(3),hi(3)
      do j=lo(2),hi(2)
        do i=lo(1),hi(1)
          dwdxp = (w(i+1,j,k)-w(i,j,k))/dxc(i  )
          dwdxm = (w(i,j,k)-w(i-1,j,k))/dxc(i-1)
          dwdyp = (w(i,j+1,k)-w(i,j,k))/dyc(j  )
          dwdym = (w(i,j,k)-w(i,j-1,k))/dyc(j-1)
          dwdzp = (w(i,j,k+1)-w(i,j,k))/dzf(k+1)
          dwdzm = (w(i,j,k)-w(i,j,k-1))/dzf(k  )
          !
          ! Momentum balance
          !
          dwdt(i,j,k) = dwdt(i,j,k) + &
                        visc*(dwdxp-dwdxm)/dxf(i) + &
                        visc*(dwdyp-dwdym)/dyf(j) + &
                        visc*(dwdzp-dwdzm)/dzc(k)
        end do
      end do
    end do
    !$OMP END PARALLEL DO
  end subroutine momz_d
  subroutine momx_p(lo,hi,dxc,bforce,p,dudt)
    implicit none
    integer , intent(in), dimension(3) :: lo,hi
    real(rp), intent(in), dimension(lo(1)-1:) :: dxc
    real(rp), intent(in) :: bforce
    real(rp), dimension(lo(1)-1:,lo(2)-1:,lo(3)-1:), intent(in ) :: p
    real(rp), dimension(lo(1):  ,lo(2):  ,lo(3):  ), intent(out) :: dudt
    integer :: i,j,k
    !
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP SHARED(lo,hi,dxc,bforce,p,dudt)
    do k=lo(3),hi(3)
      do j=lo(2),hi(2)
        do i=lo(1),hi(1)
          dudt(i,j,k) = - ( p(i+1,j,k)-p(i,j,k) )/dxc(i) + bforce
        end do
      end do
    end do
    !$OMP END PARALLEL DO
  end subroutine momx_p
  !
  subroutine momy_p(lo,hi,dyc,bforce,p,dvdt)
    implicit none
    integer , intent(in), dimension(3) :: lo,hi
    real(rp), intent(in), dimension(lo(2)-1:) :: dyc
    real(rp), intent(in) :: bforce
    real(rp), dimension(lo(1)-1:,lo(2)-1:,lo(3)-1:), intent(in ) :: p
    real(rp), dimension(lo(1):  ,lo(2):  ,lo(3):  ), intent(out) :: dvdt
    integer :: i,j,k
    !
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP SHARED(lo,hi,dyc,bforce,p,dvdt)
    do k=lo(3),hi(3)
      do j=lo(2),hi(2)
        do i=lo(1),hi(1)
          dvdt(i,j,k) = - ( p(i,j+1,k)-p(i,j,k) )/dyc(j) + bforce
        end do
      end do
    end do
    !$OMP END PARALLEL DO
  end subroutine momy_p
  !
  subroutine momz_p(lo,hi,dzc,bforce,p,dwdt)
    implicit none
    integer , intent(in), dimension(3) :: lo,hi
    real(rp), intent(in), dimension(lo(3)-1:) :: dzc
    real(rp), intent(in) :: bforce
    real(rp), dimension(lo(1)-1:,lo(2)-1:,lo(3)-1:), intent(in ) :: p
    real(rp), dimension(lo(1):  ,lo(2):  ,lo(3):  ), intent(out) :: dwdt
    integer :: i,j,k
    !
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP SHARED(lo,hi,dzc,bforce,p,dwdt)
    do k=lo(3),hi(3)
      do j=lo(2),hi(2)
        do i=lo(1),hi(1)
          dwdt(i,j,k) = - ( p(i,j,k+1)-p(i,j,k) )/dzc(k) + bforce
        end do
      end do
    end do
    !$OMP END PARALLEL DO
  end subroutine momz_p
end module mod_mom


C     文件头，定义函数参数
      SUBROUTINE DFLUX(FLUX,SOL,JSTEP,JINC,TIME,NOEL,NPT,COORDS,JLTYP,
     1                 TEMP,PRESS,SNAME)
C
      INCLUDE 'ABA_PARAM.INC'

C     定义基本数组，坐标，热通量值，时间
      DIMENSION COORDS(3),FLUX(2),TIME(2)
      CHARACTER*80 SNAME
C     定义热源参数，注意单位统一
      u=380.0    !电压
      i=2.0      !电流
      effi=0.8   !焊接效率
      v=0.005    !焊接速度
      q=u*i*effi     !热输入大小
      d=v*TIME(2)    !热源中心移动距离
C     定义坐标
      x=COORDS(1)
      y=COORDS(2)
      z=COORDS(3)
C     定义焊接起点
      x0=-0.0035
      y0=0.001
      z0=0.03
C       定义热源参数
        a=0.002
	  b=0.002
	  c=0.002
	  aa=0.004     !双椭球各方向半径
	  f1=1.0       !前半球份额
	  PI=3.1415926

      beta=45.0    !旋转角度，本例为绕z轴旋转,逆时针为正，z轴负方向为前进方向
	  betahudu=beta/180.0*PI  !将角度转换为弧度制

	  heat1=6.0*sqrt(3.0)*q/(a*b*c*PI*sqrt(PI))*f1         !前半部分热输入
	  heat2=6.0*sqrt(3.0)*q/(aa*b*c*PI*sqrt(PI))*(2.0-f1)  !后半部分热输入
C       T型接头的高斯坐标xy平面需要沿z轴逆时针旋转45度，需要进行相应的坐标旋转变换处理
C	    此时x'=x*cos(betahudu)+y*sin(betahudu) ,
C       y'=Y*cos(betahudu)-X*sin(betahudu).将上述两式带入形状方程
	  shape1=exp(-3.0*((x-x0)*cos(betahudu)+(y-y0)*sin(betahudu))**2/a**2-3.0*((y-y0)*cos(betahudu)-
     $     (x-x0)*sin(betahudu))**2/b**2-3.0*((z-z0+d))**2/c**2)
      shape2=exp(-3.0*((x-x0)*cos(betahudu)+(y-y0)*sin(betahudu))**2/aa**2-3.0*((y-y0)*cos(betahudu)-
     $     (x-x0)*sin(betahudu))**2/b**2-3.0*((z-z0+d))**2/c**2)

C     JLTYP＝1，表示为体热源
      JLTYP=1
	  IF(z .GE.(z0-d)) THEN      !热源移动方向为z轴负方向
	  FLUX(1)=heat1*shape1       !前半部分热通量
	  ELSE
	  FLUX(1)=heat2*shape2       !后半部分热通量
	  ENDIF
      RETURN
      END


MODULE fuga_mod
!
! Contains data for calculating the fugacity for different pressures
!
! Acc_factor		real    accentric factor
! k			real 	binary parameter in fugacity calculation
! T_crit		real    critical temperature
! Temp			real    temperature
! beta			real    1 / (k_b Temp)
! P_crit		real    critical pressure
! Press(i)              real    Pressure
! Presspoint            integer number of pressure points to calculate the
!				adsorption isotherm
! fugacity              real    fugacity

 Use diverses
 IMPLICIT NONE
 SAVE
!
 REAL(kind = realkind)                             :: Temp, beta
 REAL(kind = realkind), DIMENSION(:), ALLOCATABLE  :: Acc_factor
 REAL(kind = realkind), DIMENSION(:), ALLOCATABLE  :: P_crit, T_crit
 REAL(kind = realkind), DIMENSION(:), ALLOCATABLE  :: fugacity
 REAL(kind = realkind), DIMENSION(:), ALLOCATABLE  :: Press
 REAL(kind = realkind), DIMENSION(:,:), ALLOCATABLE:: k
 INTEGER                                           :: Presspoint
!
 END MODULE fuga_mod


!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
!! 3D oil reservoir Simulator project
!! by Mehrdad Gharib Shirangi From Spring 2010 until Fall 2010
!! mehrdad.ghsh@gmail.com
!! Copy Right by Mehrdad Gharib Shirangi
!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

Subroutine con_chek
! this sub checks the converegence at each time step
!!
Use globalvar
Use Well
Use Trans
Use Mat_Calc
!-------------------------------------Variable Declaration Part-------------------------------------------------------
Implicit None

integer :: i_well , i, j , k , alfa, B_index
real*8 :: Oil_division , W_division , Nomenator_new ,  Nomenator_past , Denomenator1 , Vb , MS , WNom_new, WNom_past , W_Denom
real*8 :: X	, WMS

!----------------
MS = 1d-5 ! convergence criteria
WMS = 1d-5
Nomenator_new = 0
Nomenator_past = 0
Denomenator1 = 0

WNom_new = 0
WNom_past = 0
W_Denom = 0

Do k=1,Nz
   Do j=1,Ny
      Do i=1,Nx
         alfa = (k-1) * Nx * Ny + (j-1) * Nx + i
         Vb = Deltax(i)*Deltay(j)*Deltaz(alfa)
         X = C_Rock * ( pressure(alfa) - P_ref )
	     Nomenator_new = Nomenator_new + Vb * phi(alfa) * ( 1 +  X + 1.0 / 2.0 * X**2 ) * ( 1 - Sw(alfa) ) / ( alfac * B_o( alfa ) )
         WNom_new = WNom_new + Vb * phi(alfa) * ( 1 +  X + 1.0 / 2.0 * X**2 ) * ( Sw(alfa) ) / ( alfac * B_w(alfa) )
         X = C_Rock * ( past_p(alfa) - P_ref )
         Nomenator_past = Nomenator_past + Vb * phi(alfa) * ( 1 + X + 1.0 / 2.0 * X**2 )  * ( 1 - Past_Sw(alfa) ) / ( alfac * B_f( past_p(alfa) , 'o' ) )
         WNom_past = WNom_past + Vb * phi(alfa) * (1 + X + 1.0 / 2.0 * X**2 )  * ( Past_Sw(alfa) ) / ( alfac * B_f( past_pw(alfa), 'w' ) ) !  past_p(alfa) - PCO_Sw( Past_Sw(alfa))
      EndDo
   EndDo
EndDo

call Calc_rate

Do i_well = 1, Nwell
    if ( W_type(i_well) == 'prod') then
        Denomenator1 = Denomenator1 + oilrate (i_well) * d_time
    EndIf
EndDo

Oil_division = abs(Nomenator_new  -  Nomenator_past) / Denomenator1

Do i_well = 1, Nwell
    W_Denom = W_Denom + waterrate (i_well) * d_time
EndDo

if (W_Denom .NE. 0.0) then
	W_division = abs(WNom_new  -  WNom_past) /abs(W_Denom)
Else
	W_division = abs(WNom_new  -  WNom_past)
EndIF

call calc_RHS
!!    Open(1,DEFAULTFILE='.\sim_output\' , FILE='convergence.DAT', status='unknown', access = 'append')
			!Write(1,'(1X ," Time          BHP")')
			!write(1,'(I3,2x, F15.5)') time , pressure(Ntotal + iWell)
!!    write(1,'(F15.8,I3,<3>(2x,F15.8))') time, j_Ensemble, Oil_Division, W_division, maxFCN
!!    close(1)
				write(*,*) '-------------------------------------------'
				write(*,*) ' Ensemble Number :' , j_Ens !!j_Ensemble
				write(*,*) 't=', time ,',OMB=', Oil_Division , ',W MB=',W_Division , 'M-RHS=',maxFCN , ', iteration # ',i_iter
				write(*,*) '-------------------------------'

if (maxFCN < MRHS) then
	If (Denomenator1 < 1.0) Then  !! There is no production in Res
		if ( ( abs ( W_Division - 1 ) < OMB/100.0)) then
			Converged = .True.
		EndIf
	Else
		if ( ( abs ( Oil_Division - 1 ) < OMB)) then
			Converged = .True.
		Elseif (maxFCN < MRHS) then
			if ( ( abs ( Oil_Division - 1 ) < MOMB)) then
				Converged = .True.
			EndIf
		EndIf
	EndIf
EndIf

!if (maxFCN < 5.0d-1) then
!	IF (d_time .LE. 1.0) then
!		if ((i_iter > 10 )) then
!			Converged = .True.
!		EndIF
!	EndIF
	if ((i_iter > M_ITER )) then
		Converged = .True.
	Endif
!ElseIF((i_iter > 30 )) then
!	Converged = .True.
!Endif

if (converged ) then
	write(*,*) '-------------------------------------------'
	write(*,*) ' Ensemble Number :' , j_Ens !!! j_Ensemble 'MAP Estimate'
	write(*,*) '--C O N V E R G E D -- '
	write(*,*) '-------------------------------------------'
EndIf

EndSubroutine con_chek


!
! SEISMIC_CPML Version 1.1.3, July 2018.
!
! Copyright CNRS, France.
! Contributor: Dimitri Komatitsch, komatitsch aT lma DOT cnrs-mrs DOT fr
!
! This software is a computer program whose purpose is to solve
! the two-dimensional heterogeneous isotropic viscoacoustic wave equation
! using a finite-difference method with Convolutional Perfectly Matched
! Layer (C-PML) conditions.
!
! This program is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 3 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License along
! with this program; if not, write to the Free Software Foundation, Inc.,
! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
!
! The full text of the license is available in file "LICENSE".

  program seismic_CPML_2D_viscoacoust_fourth

! 2D finite-difference code in velocity and pressure formulation
! with Convolutional-PML (C-PML) absorbing conditions for an heterogeneous isotropic viscoacoustic medium

! Dimitri Komatitsch, CNRS, Marseille, July 2018.

! A fourth-order spatially-staggered grid formulation is used:
!
!            ^ y
!            |
!            |
!
!            +-------------------+
!            |                   |
!            |                   |
!            |                   |
!            |                   |
!            |        v_y        |
!            +---------+         |
!            |         |         |
!            |         |         |
!            |         |         |
!            |         |         |
!            |         |         |
!            +---------+---------+  ---> x
!           v_x    pressure
!                  R_dot (viscoacoustic memory variable)
!

! The C-PML implementation is based in part on formulas given in Roden and Gedney (2000).
! If you use this code for your own research, please cite some (or all) of these
! articles:
!
! @ARTICLE{MaKoEz08,
! author = {Roland Martin and Dimitri Komatitsch and Abdela\^aziz Ezziani},
! title = {An unsplit convolutional perfectly matched layer improved at grazing
! incidence for seismic wave equation in poroelastic media},
! journal = {Geophysics},
! year = {2008},
! volume = {73},
! pages = {T51-T61},
! number = {4},
! doi = {10.1190/1.2939484}}
!
! @ARTICLE{MaKo09,
! author = {Roland Martin and Dimitri Komatitsch},
! title = {An unsplit convolutional perfectly matched layer technique improved
! at grazing incidence for the viscoelastic wave equation},
! journal = {Geophysical Journal International},
! year = {2009},
! volume = {179},
! pages = {333-344},
! number = {1},
! doi = {10.1111/j.1365-246X.2009.04278.x}}
!
! @ARTICLE{MaKoGe08,
! author = {Roland Martin and Dimitri Komatitsch and Stephen D. Gedney},
! title = {A variational formulation of a stabilized unsplit convolutional perfectly
! matched layer for the isotropic or anisotropic seismic wave equation},
! journal = {Computer Modeling in Engineering and Sciences},
! year = {2008},
! volume = {37},
! pages = {274-304},
! number = {3}}
!
! @ARTICLE{KoMa07,
! author = {Dimitri Komatitsch and Roland Martin},
! title = {An unsplit convolutional {P}erfectly {M}atched {L}ayer improved
!          at grazing incidence for the seismic wave equation},
! journal = {Geophysics},
! year = {2007},
! volume = {72},
! number = {5},
! pages = {SM155-SM167},
! doi = {10.1190/1.2757586}}
!
! The original CPML technique for Maxwell's equations is described in:
!
! @ARTICLE{RoGe00,
! author = {J. A. Roden and S. D. Gedney},
! title = {Convolution {PML} ({CPML}): {A}n Efficient {FDTD} Implementation
!          of the {CFS}-{PML} for Arbitrary Media},
! journal = {Microwave and Optical Technology Letters},
! year = {2000},
! volume = {27},
! number = {5},
! pages = {334-339},
! doi = {10.1002/1098-2760(20001205)27:5 < 334::AID-MOP14>3.0.CO;2-A}}

!
! To display the 2D results as color images, use:
!
!   " display image*.gif " or " gimp image*.gif "
!
! or
!
!   " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vx*.gif allfiles_Vx.gif "
!   " montage -geometry +0+3 -rotate 90 -tile 1x21 image*Vy*.gif allfiles_Vy.gif "
!   then " display allfiles_Vx.gif " or " gimp allfiles_Vx.gif "
!   then " display allfiles_Vy.gif " or " gimp allfiles_Vy.gif "
!

! IMPORTANT : all our CPML codes work fine in single precision as well (which is significantly faster).
!             If you want you can thus force automatic conversion to single precision at compile time
!             or change all the declarations and constants in the code from double precision to single.

  implicit none

! include viscoacoustic attenuation or not
  logical, parameter :: VISCOACOUSTIC_ATTENUATION = .true.

! flags to add PML layers to the edges of the grid
  logical, parameter :: USE_PML_XMIN = .true.
  logical, parameter :: USE_PML_XMAX = .true.
  logical, parameter :: USE_PML_YMIN = .true.
  logical, parameter :: USE_PML_YMAX = .true.

! total number of grid points in each direction of the grid
  integer, parameter :: NX = 2001
  integer, parameter :: NY = 2001

! size of a grid cell
  double precision, parameter :: DELTAX = 1.5d0
  double precision, parameter :: DELTAY = DELTAX

! thickness of the PML layer in grid points
  integer, parameter :: NPOINTS_PML = 10

! P-velocity and density
! the unrelaxed value is the value at frequency = 0 (the relaxed value would be the value at frequency = +infinity)
  double precision, parameter :: cp_unrelaxed = 2000.d0
  double precision, parameter :: density = 2000.d0

! Time step in seconds.
! The CFL stability number for the O(2,2) algorithm is 1 / sqrt(2) = 0.707
! i.e. one must choose  cp * deltat / deltax < 0.707.
! For the O(2,4) algorithm used here it is a bit more restrictive,
! it is cp * deltat / deltax < 0.606  (see Levander 1988 eq (7)).
! However this only ensures that the scheme is stable. To have a scheme that is both stable and accurate,
! for O(2,4) some numerical tests show that one needs to take about half of that,
! i.e. choose deltat so that cp * deltat / deltax is equal to about 0.30 or so. (or any value below; but not above).
! Since the time scheme is only second order, this also depends on how many time steps are performed in total
! (i.e. what the value of NSTEP below is); for large values of NSTEP, of course numerical errors will start to accumulate.
  double precision, parameter :: DELTAT = 2.2d-4

! total number of time steps
  integer, parameter :: NSTEP = 3600

! parameters for the source
  double precision, parameter :: f0 = 35.d0
  double precision, parameter :: t0 = 1.20d0 / f0
  double precision, parameter :: factor = 1.d0

! source (in pressure, thus at a gridpoint rather than half a grid cell away)
  double precision, parameter :: xsource = 1500.d0
  double precision, parameter :: ysource = 1500.d0
  integer, parameter :: ISOURCE = xsource / DELTAX + 1
  integer, parameter :: JSOURCE = ysource / DELTAY + 1

! receivers
  integer, parameter :: NREC = 1
!! DK DK I use 2301 here instead of 2300 in order to fall exactly on a grid point
  double precision, parameter :: xdeb = 2301.d0   ! first receiver x in meters
  double precision, parameter :: ydeb = 2301.d0   ! first receiver y in meters
  double precision, parameter :: xfin = 2301.d0   ! last receiver x in meters
  double precision, parameter :: yfin = 2301.d0   ! last receiver y in meters

! to compute energy curves for the whole medium (optional, but useful e.g. to produce
! energy variation figures for articles); but expensive option, thus off by default
  logical, parameter :: COMPUTE_ENERGY = .false.

! display information on the screen from time to time
  integer, parameter :: IT_DISPLAY = 200

! compute some constants once and for all for the fourth-order spatial scheme
! These coefficients are given for instance by Levander, Geophysics, vol. 53(11), p. 1436, equation (A-2)
  double precision, parameter :: NINE_OVER_8_DELTAX = 9.d0 / (8.d0*DELTAX)
  double precision, parameter :: NINE_OVER_8_DELTAY = 9.d0 / (8.d0*DELTAY)
  double precision, parameter :: ONE_OVER_24_DELTAX = 1.d0 / (24.d0*DELTAX)
  double precision, parameter :: ONE_OVER_24_DELTAY = 1.d0 / (24.d0*DELTAY)

! value of PI
  double precision, parameter :: PI = 3.141592653589793238462643d0

! zero
  double precision, parameter :: ZERO = 0.d0

! large value for maximum
  double precision, parameter :: HUGEVAL = 1.d+30

! threshold above which we consider that the code became unstable
  double precision, parameter :: STABILITY_THRESHOLD = 1.d+25

! main arrays
! in order to be able to use a fourth-order spatial operator on the edges of the model
! here we define the arrays with size (0:NX+1,0:NY+1) instead of size (NX,NY) as in the second-order case
  double precision, dimension(0:NX+1,0:NY+1) :: vx,vy,pressure,kappa_unrelaxed,rho

! to interpolate material parameters or velocity at the right location in the staggered grid cell
  double precision kappa_half_x,rho_half_x_half_y,vy_interpolated

! for evolution of total energy in the medium
  double precision, dimension(NSTEP) :: total_energy_kinetic,total_energy_potential

! power to compute d0 profile
  double precision, parameter :: NPOWER = 2.d0

! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-11
  double precision, parameter :: K_MAX_PML = 1.d0
  double precision, parameter :: ALPHA_MAX_PML = 2.d0*PI*(f0/2.d0) ! from Festa and Vilotte

! arrays for the memory variables
! could declare these arrays in PML only to save a lot of memory, but proof of concept only here
  double precision, dimension(NX,NY) :: &
      memory_dvx_dx, &
      memory_dvx_dy, &
      memory_dvy_dx, &
      memory_dvy_dy, &
      memory_dpressure_dx, &
      memory_dpressure_dy

  double precision :: &
      value_dvx_dx, &
      value_dvy_dy, &
      value_dpressure_dx, &
      value_dpressure_dy

! 1D arrays for the damping profiles
  double precision, dimension(NX) :: d_x,K_x,alpha_x,a_x,b_x,d_x_half,K_x_half,alpha_x_half,a_x_half,b_x_half, &
                                     one_over_K_x,one_over_K_x_half
  double precision, dimension(NY) :: d_y,K_y,alpha_y,a_y,b_y,d_y_half,K_y_half,alpha_y_half,a_y_half,b_y_half, &
                                     one_over_K_y,one_over_K_y_half

  double precision :: thickness_PML_x,thickness_PML_y,xoriginleft,xoriginright,yoriginbottom,yorigintop
  double precision :: Rcoef,d0_x,d0_y,xval,yval,abscissa_in_PML,abscissa_normalized

! for the source
  double precision :: a,t,pressure_source_term

! for receivers
  double precision xspacerec,yspacerec,distval,dist
  integer, dimension(NREC) :: ix_rec,iy_rec
  double precision, dimension(NREC) :: xrec,yrec
  integer :: myNREC

! for seismograms
  double precision, dimension(NSTEP,NREC) :: sisvx,sisvy,sispressure

  integer :: i,j,it,irec

  double precision :: Courant_number,velocnorm,pressurenorm

! for attenuation (viscoacousticity)

! attenuation quality factor Qkappa to use
  double precision, parameter :: QKappa = 65.d0

! number of Zener standard linear solids in parallel
  integer, parameter :: N_SLS = 3

! attenuation constants
  double precision, dimension(N_SLS) :: tau_epsilon_kappa,tau_sigma_kappa,one_over_tau_sigma_kappa, &
         HALF_DELTAT_over_tau_sigma_kappa,multiplication_factor_tau_sigma_kappa,DELTAT_delta_relaxed_over_tau_sigma_without_Kappa

! memory variable for attenuation
  double precision, dimension(NX,NY,N_SLS) :: memory_variable_R_dot,memory_variable_R_dot_old
  integer :: i_sls
  double precision :: sum_of_memory_variables_kappa

! this defines the typical frequency range in which we use optimization to find the tau values that fit a given Q in that band
  double precision :: f_min_attenuation,f_max_attenuation

!---
!--- program starts here
!---

  print *
  print *,'2D viscoacoustic finite-difference code in velocity and pressure formulation with C-PML'
  print *

! display size of the model
  print *
  print *,'NX = ',NX
  print *,'NY = ',NY
  print *
  print *,'size of the model along X = ',(NX - 1) * DELTAX
  print *,'size of the model along Y = ',(NY - 1) * DELTAY
  print *
  print *,'Total number of grid points = ',NX * NY
  print *

! for attenuation (viscoacousticity)
  if (VISCOACOUSTIC_ATTENUATION) then

  print *,'QKappa quality factor used for attenuation = ',QKappa
  print *,'Number of Zener standard linear solids used to mimic the viscoacoustic behavior (N_SLS) = ',N_SLS
  print *

! this defines the typical frequency range in which we use optimization to find the tau values that fit a given Q in that band
! f_min and f_max are computed as : f_max/f_min=12 and (log(f_min)+log(f_max))/2 = log(f0)
  f_min_attenuation = exp(log(f0)-log(12.d0)/2.d0)
  f_max_attenuation = 12.d0 * f_min_attenuation

! call the SolvOpt() nonlinear optimization routine to compute the tau_epsilon and tau_sigma values from a given Q factor
  call compute_attenuation_coeffs(N_SLS,QKappa,f0,f_min_attenuation,f_max_attenuation,tau_epsilon_kappa,tau_sigma_kappa)

  else

! dummy values in the non-dissipative case
    tau_epsilon_kappa(:) = 1.d0
    tau_sigma_kappa(:) = 1.d0

  endif

! precompute the inverse once and for all, to save computation time in the time loop below
! (on computers, a multiplication is very significantly cheaper than a division)
  one_over_tau_sigma_kappa(:) = 1.d0 / tau_sigma_kappa(:)
  HALF_DELTAT_over_tau_sigma_kappa(:) = 0.5d0 * DELTAT / tau_sigma_kappa(:)
  multiplication_factor_tau_sigma_kappa(:) = 1.d0 / (1.d0 + 0.5d0 * DELTAT * one_over_tau_sigma_kappa(:))

! compute DELTAT_delta_relaxed_over_tau_sigma_without_Kappa, which is a term
! needed to compute the evolution of the viscoacoustic memory variables
  if (VISCOACOUSTIC_ATTENUATION) then
    DELTAT_delta_relaxed_over_tau_sigma_without_Kappa(:) = (DELTAT / sum(tau_epsilon_kappa(:) / tau_sigma_kappa(:))) * &
                        (tau_epsilon_kappa(:)/tau_sigma_kappa(:) - 1.d0) / tau_sigma_kappa(:)
  else
    DELTAT_delta_relaxed_over_tau_sigma_without_Kappa(:) = ZERO
  endif

!--- define profile of absorption in PML region

! thickness of the PML layer in meters
  thickness_PML_x = NPOINTS_PML * DELTAX
  thickness_PML_y = NPOINTS_PML * DELTAY

! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf
  Rcoef = 0.001d0

! check that NPOWER is okay
  if (NPOWER < 1) stop 'NPOWER must be greater than 1'

! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf
  d0_x = - (NPOWER + 1) * cp_unrelaxed * log(Rcoef) / (2.d0 * thickness_PML_x)
  d0_y = - (NPOWER + 1) * cp_unrelaxed * log(Rcoef) / (2.d0 * thickness_PML_y)

  print *,'d0_x = ',d0_x
  print *,'d0_y = ',d0_y
  print *

  d_x(:) = ZERO
  d_x_half(:) = ZERO
  K_x(:) = 1.d0
  K_x_half(:) = 1.d0
  alpha_x(:) = ZERO
  alpha_x_half(:) = ZERO
  a_x(:) = ZERO
  a_x_half(:) = ZERO

  d_y(:) = ZERO
  d_y_half(:) = ZERO
  K_y(:) = 1.d0
  K_y_half(:) = 1.d0
  alpha_y(:) = ZERO
  alpha_y_half(:) = ZERO
  a_y(:) = ZERO
  a_y_half(:) = ZERO

! damping in the X direction

! origin of the PML layer (position of right edge minus thickness, in meters)
  xoriginleft = thickness_PML_x
  xoriginright = (NX-1)*DELTAX - thickness_PML_x

  do i = 1,NX

! abscissa of current grid point along the damping profile
    xval = DELTAX * dble(i-1)

!---------- left edge
    if (USE_PML_XMIN) then

! define damping profile at the grid points
      abscissa_in_PML = xoriginleft - xval
      if (abscissa_in_PML >= ZERO) then
        abscissa_normalized = abscissa_in_PML / thickness_PML_x
        d_x(i) = d0_x * abscissa_normalized**NPOWER
! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2
        K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER
        alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)
      endif

! define damping profile at half the grid points
      abscissa_in_PML = xoriginleft - (xval + DELTAX/2.d0)
      if (abscissa_in_PML >= ZERO) then
        abscissa_normalized = abscissa_in_PML / thickness_PML_x
        d_x_half(i) = d0_x * abscissa_normalized**NPOWER
! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2
        K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER
        alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)
      endif

    endif

!---------- right edge
    if (USE_PML_XMAX) then

! define damping profile at the grid points
      abscissa_in_PML = xval - xoriginright
      if (abscissa_in_PML >= ZERO) then
        abscissa_normalized = abscissa_in_PML / thickness_PML_x
        d_x(i) = d0_x * abscissa_normalized**NPOWER
! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2
        K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER
        alpha_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)
      endif

! define damping profile at half the grid points
      abscissa_in_PML = xval + DELTAX/2.d0 - xoriginright
      if (abscissa_in_PML >= ZERO) then
        abscissa_normalized = abscissa_in_PML / thickness_PML_x
        d_x_half(i) = d0_x * abscissa_normalized**NPOWER
! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2
        K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER
        alpha_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)
      endif

    endif

! just in case, for -5 at the end
    if (alpha_x(i) < ZERO) alpha_x(i) = ZERO
    if (alpha_x_half(i) < ZERO) alpha_x_half(i) = ZERO

    b_x(i) = exp(- (d_x(i) / K_x(i) + alpha_x(i)) * DELTAT)
    b_x_half(i) = exp(- (d_x_half(i) / K_x_half(i) + alpha_x_half(i)) * DELTAT)

! this to avoid division by zero outside the PML
    if (abs(d_x(i)) > 1.d-6) a_x(i) = d_x(i) * (b_x(i) - 1.d0) / (K_x(i) * (d_x(i) + K_x(i) * alpha_x(i)))
    if (abs(d_x_half(i)) > 1.d-6) a_x_half(i) = d_x_half(i) * &
      (b_x_half(i) - 1.d0) / (K_x_half(i) * (d_x_half(i) + K_x_half(i) * alpha_x_half(i)))

  enddo

! damping in the Y direction

! origin of the PML layer (position of right edge minus thickness, in meters)
  yoriginbottom = thickness_PML_y
  yorigintop = (NY-1)*DELTAY - thickness_PML_y

  do j = 1,NY

! abscissa of current grid point along the damping profile
    yval = DELTAY * dble(j-1)

!---------- bottom edge
    if (USE_PML_YMIN) then

! define damping profile at the grid points
      abscissa_in_PML = yoriginbottom - yval
      if (abscissa_in_PML >= ZERO) then
        abscissa_normalized = abscissa_in_PML / thickness_PML_y
        d_y(j) = d0_y * abscissa_normalized**NPOWER
! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2
        K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER
        alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)
      endif

! define damping profile at half the grid points
      abscissa_in_PML = yoriginbottom - (yval + DELTAY/2.d0)
      if (abscissa_in_PML >= ZERO) then
        abscissa_normalized = abscissa_in_PML / thickness_PML_y
        d_y_half(j) = d0_y * abscissa_normalized**NPOWER
! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2
        K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER
        alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)
      endif

    endif

!---------- top edge
    if (USE_PML_YMAX) then

! define damping profile at the grid points
      abscissa_in_PML = yval - yorigintop
      if (abscissa_in_PML >= ZERO) then
        abscissa_normalized = abscissa_in_PML / thickness_PML_y
        d_y(j) = d0_y * abscissa_normalized**NPOWER
! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2
        K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER
        alpha_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)
      endif

! define damping profile at half the grid points
      abscissa_in_PML = yval + DELTAY/2.d0 - yorigintop
      if (abscissa_in_PML >= ZERO) then
        abscissa_normalized = abscissa_in_PML / thickness_PML_y
        d_y_half(j) = d0_y * abscissa_normalized**NPOWER
! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2
        K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER
        alpha_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)
      endif

    endif

    b_y(j) = exp(- (d_y(j) / K_y(j) + alpha_y(j)) * DELTAT)
    b_y_half(j) = exp(- (d_y_half(j) / K_y_half(j) + alpha_y_half(j)) * DELTAT)

! this to avoid division by zero outside the PML
    if (abs(d_y(j)) > 1.d-6) a_y(j) = d_y(j) * (b_y(j) - 1.d0) / (K_y(j) * (d_y(j) + K_y(j) * alpha_y(j)))
    if (abs(d_y_half(j)) > 1.d-6) a_y_half(j) = d_y_half(j) * &
      (b_y_half(j) - 1.d0) / (K_y_half(j) * (d_y_half(j) + K_y_half(j) * alpha_y_half(j)))

  enddo

! precompute the inverse once and for all, to save computation time in the time loop below
! (on computers, a multiplication is very significantly cheaper than a division)
  one_over_K_x(:) = 1.d0 / K_x(:)
  one_over_K_x_half(:) = 1.d0 / K_x_half(:)
  one_over_K_y(:) = 1.d0 / K_y(:)
  one_over_K_y_half(:) = 1.d0 / K_y_half(:)

! compute the Lame parameter and density
  do j = 1,NY
    do i = 1,NX
      rho(i,j) = density
      kappa_unrelaxed(i,j) = density*cp_unrelaxed*cp_unrelaxed
    enddo
  enddo

! print position of the source
  print *,'Position of the source:'
  print *
  print *,'x = ',xsource
  print *,'y = ',ysource
  print *

! define location of receivers
  print *,'There are ',nrec,' receivers'
  print *
  if (NREC > 1) then
! this is to avoid a warning with GNU gfortran at compile time about division by zero when NREC = 1
    myNREC = NREC
    xspacerec = (xfin-xdeb) / dble(myNREC-1)
    yspacerec = (yfin-ydeb) / dble(myNREC-1)
  else
    xspacerec = 0.d0
    yspacerec = 0.d0
  endif
  do irec=1,nrec
    xrec(irec) = xdeb + dble(irec-1)*xspacerec
    yrec(irec) = ydeb + dble(irec-1)*yspacerec
  enddo

! find closest grid point for each receiver
  do irec=1,nrec
    dist = HUGEVAL
    do j = 1,NY
    do i = 1,NX
      distval = sqrt((DELTAX*dble(i-1) - xrec(irec))**2 + (DELTAY*dble(j-1) - yrec(irec))**2)
      if (distval < dist) then
        dist = distval
        ix_rec(irec) = i
        iy_rec(irec) = j
      endif
    enddo
    enddo
    print *,'receiver ',irec,' x_target,y_target = ',xrec(irec),yrec(irec)
    print *,'closest grid point found at distance ',dist,' in i,j = ',ix_rec(irec),iy_rec(irec)
    print *
  enddo

! check the Courant stability condition for the explicit time scheme
! R. Courant, K. O. Friedrichs and H. Lewy (1928)
! For this O(2,4) scheme, when DELTAX == DELTAY the Courant number is given by Levander, Geophysics, vol. 53(11), p. 1427,
! equation (7) and is equal to 0.606 (it is thus smaller than that of the O(2,2) scheme, which is 1/sqrt(2) = 0.707,
! i.e. when switching to a fourth-order spatial scheme one needs a time step that is about 0.707 / 0.606 = 1.167 times smaller.
  if (DELTAX == DELTAY) then
    Courant_number = cp_unrelaxed * DELTAT / DELTAX
    print *,'Courant number is ',Courant_number
    print *,' (the maximum possible value is 0.606; in practice for accuracy reasons a value not larger than 0.30 is recommended)'
    print *
    if (Courant_number > 0.606) stop 'time step is too large, simulation will be unstable'
  endif

! suppress old files (can be commented out if "call system" is missing in your compiler)
  call system('rm -f Vx_*.dat Vy_*.dat image*.pnm image*.gif')

! initialize arrays
  vx(:,:) = ZERO
  vy(:,:) = ZERO
  pressure(:,:) = ZERO
  memory_variable_R_dot(:,:,:) = ZERO
  memory_variable_R_dot_old(:,:,:) = ZERO

! PML
  memory_dvx_dx(:,:) = ZERO
  memory_dvx_dy(:,:) = ZERO
  memory_dvy_dx(:,:) = ZERO
  memory_dvy_dy(:,:) = ZERO
  memory_dpressure_dx(:,:) = ZERO
  memory_dpressure_dy(:,:) = ZERO

! initialize seismograms
  sisvx(:,:) = ZERO
  sisvy(:,:) = ZERO
  sispressure(:,:) = ZERO

! initialize total energy
  total_energy_kinetic(:) = ZERO
  total_energy_potential(:) = ZERO

  if (VISCOACOUSTIC_ATTENUATION) then
    print *,'adding VISCOACOUSTIC_ATTENUATION (i.e., running a viscoacoustic simulation)'
  else
    print *,'not adding VISCOACOUSTIC_ATTENUATION (i.e., running a purely acoustic simulation)'
  endif
  print *

!---
!---  beginning of time loop
!---

  do it = 1,NSTEP

!-----------------------------------------------------------------------
! compute pressure and update memory variables for C-PML
! also update memory variables for viscoacoustic attenuation if needed
!-----------------------------------------------------------------------

! we purposely leave this "if" test outside of the loops to make sure the compiler can optimize these loops;
! with an "if" test inside most compilers cannot
  if (.not. VISCOACOUSTIC_ATTENUATION) then

    do j = 2,NY
      do i = 1,NX-1

! interpolate material parameters at the right location in the staggered grid cell
        kappa_half_x = 0.5d0 * (kappa_unrelaxed(i+1,j) + kappa_unrelaxed(i,j))

        value_dvx_dx = (vx(i+1,j) - vx(i,j)) * NINE_OVER_8_DELTAX + (vx(i-1,j) - vx(i+2,j)) * ONE_OVER_24_DELTAX
        value_dvy_dy = (vy(i,j) - vy(i,j-1)) * NINE_OVER_8_DELTAY + (vy(i,j-2) - vy(i,j+1)) * ONE_OVER_24_DELTAY

        memory_dvx_dx(i,j) = b_x_half(i) * memory_dvx_dx(i,j) + a_x_half(i) * value_dvx_dx
        memory_dvy_dy(i,j) = b_y(j) * memory_dvy_dy(i,j) + a_y(j) * value_dvy_dy

        value_dvx_dx = value_dvx_dx * one_over_K_x_half(i) + memory_dvx_dx(i,j)
        value_dvy_dy = value_dvy_dy * one_over_K_y(j) + memory_dvy_dy(i,j)

        pressure(i,j) = pressure(i,j) - kappa_half_x * (value_dvx_dx + value_dvy_dy) * DELTAT

      enddo
    enddo

  else

! the present becomes the past for the memory variables.
! in C or C++ we could replace this with an exchange of pointers on the arrays
! in order to avoid a memory copy of the whole array.
    memory_variable_R_dot_old(:,:,:) = memory_variable_R_dot(:,:,:)

    do j = 2,NY
      do i = 1,NX-1

! interpolate material parameters at the right location in the staggered grid cell
        kappa_half_x = 0.5d0 * (kappa_unrelaxed(i+1,j) + kappa_unrelaxed(i,j))

        value_dvx_dx = (vx(i+1,j) - vx(i,j)) * NINE_OVER_8_DELTAX + (vx(i-1,j) - vx(i+2,j)) * ONE_OVER_24_DELTAX
        value_dvy_dy = (vy(i,j) - vy(i,j-1)) * NINE_OVER_8_DELTAY + (vy(i,j-2) - vy(i,j+1)) * ONE_OVER_24_DELTAY

        memory_dvx_dx(i,j) = b_x_half(i) * memory_dvx_dx(i,j) + a_x_half(i) * value_dvx_dx
        memory_dvy_dy(i,j) = b_y(j) * memory_dvy_dy(i,j) + a_y(j) * value_dvy_dy

        value_dvx_dx = value_dvx_dx * one_over_K_x_half(i) + memory_dvx_dx(i,j)
        value_dvy_dy = value_dvy_dy * one_over_K_y(j) + memory_dvy_dy(i,j)

! use the Auxiliary Differential Equation form, which is second-order accurate in time if implemented following
! eq (14) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994), which is what we do here
        sum_of_memory_variables_kappa = 0.d0
        do i_sls = 1,N_SLS
! this average of the two terms comes from eq (14) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994)
          memory_variable_R_dot(i,j,i_sls) = (memory_variable_R_dot_old(i,j,i_sls) + &
               (value_dvx_dx + value_dvy_dy) * kappa_unrelaxed(i,j) * DELTAT_delta_relaxed_over_tau_sigma_without_Kappa(i_sls) - &
               memory_variable_R_dot_old(i,j,i_sls) * HALF_DELTAT_over_tau_sigma_kappa(i_sls)) &
                     * multiplication_factor_tau_sigma_kappa(i_sls)

          sum_of_memory_variables_kappa = sum_of_memory_variables_kappa + &
                     memory_variable_R_dot(i,j,i_sls) + memory_variable_R_dot_old(i,j,i_sls)
        enddo

        pressure(i,j) = pressure(i,j) + (- kappa_half_x * (value_dvx_dx + value_dvy_dy) + &
! this average of the two terms comes from eq (13) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994)
                     0.5d0 * sum_of_memory_variables_kappa) * DELTAT

      enddo
    enddo

  endif

! add the source (pressure located at a given grid point)
  a = pi*pi*f0*f0
  t = dble(it-1)*DELTAT

! Gaussian
! pressure_source_term = - factor * exp(-a*(t-t0)**2) / (2.d0 * a)

! first derivative of a Gaussian
  pressure_source_term = factor * (t-t0)*exp(-a*(t-t0)**2)

! Ricker source time function (second derivative of a Gaussian)
! pressure_source_term = factor * (1.d0 - 2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2)

! to get the right amplitude of the force, we need to divide by the area of a grid cell
! (we checked that against the analytical solution in a homogeneous medium for a pressure source)
  pressure_source_term = pressure_source_term / (DELTAX * DELTAY)

! define location of the source
  i = ISOURCE
  j = JSOURCE

! the pressure source is added to d(pressure)/dt in this split pressure / velocity scheme
! and that is why we need to select the first derivative of a Gaussian as a source time wavelet
! above instead of a Ricker (i.e. a second derivative) added to d2(pressure)/dt2
! as in the unsplit equation written in pressure only.
! Since the formula is d(pressure)/dt = (pressure_new - pressure_old) / DELTAT = pressure_source_term
! we also need to multiply by DELTAT here to avoid having an amplitude of the seismogram
! that varies when one changes the time step, i.e. we write:
! pressure_new = pressure_old + pressure_source_term * DELTAT at the source grid point
  pressure(i,j) = pressure(i,j) + pressure_source_term * DELTAT

!--------------------------------------------------------
! compute velocity and update memory variables for C-PML
!--------------------------------------------------------

  do j = 2,NY
    do i = 2,NX

      value_dpressure_dx = (pressure(i,j) - pressure(i-1,j)) * NINE_OVER_8_DELTAX + &
                                   (pressure(i-2,j) - pressure(i+1,j)) * ONE_OVER_24_DELTAX

      memory_dpressure_dx(i,j) = b_x(i) * memory_dpressure_dx(i,j) + a_x(i) * value_dpressure_dx

      value_dpressure_dx = value_dpressure_dx * one_over_K_x(i) + memory_dpressure_dx(i,j)

      vx(i,j) = vx(i,j) - value_dpressure_dx * DELTAT / rho(i,j)

    enddo
  enddo

  do j = 1,NY-1
    do i = 1,NX-1

!     interpolate density at the right location in the staggered grid cell
      rho_half_x_half_y = 0.25d0 * (rho(i,j) + rho(i+1,j) + rho(i+1,j+1) + rho(i,j+1))

      value_dpressure_dy = (pressure(i,j+1) - pressure(i,j)) * NINE_OVER_8_DELTAY + &
                                   (pressure(i,j-1) - pressure(i,j+2)) * ONE_OVER_24_DELTAY

      memory_dpressure_dy(i,j) = b_y_half(j) * memory_dpressure_dy(i,j) + a_y_half(j) * value_dpressure_dy

      value_dpressure_dy = value_dpressure_dy * one_over_K_y_half(j) + memory_dpressure_dy(i,j)

      vy(i,j) = vy(i,j) - value_dpressure_dy * DELTAT / rho_half_x_half_y

    enddo
  enddo

! Dirichlet conditions (rigid boundaries) on the edges or at the bottom of the PML layers
  vx(1,:) = ZERO
  vx(NX,:) = ZERO

  vx(:,1) = ZERO
  vx(:,NY) = ZERO

  vy(1,:) = ZERO
  vy(NX,:) = ZERO

  vy(:,1) = ZERO
  vy(:,NY) = ZERO

! store seismograms
  do irec = 1,NREC

! beware here that the two components of the velocity vector are not defined at the same point
! in a staggered grid, and thus the two components of the velocity vector are recorded at slightly different locations,
! vy is staggered by half a grid cell along X and along Y with respect to vx
    sisvx(it,irec) = vx(ix_rec(irec),iy_rec(irec))
    sisvy(it,irec) = vy(ix_rec(irec),iy_rec(irec))
    sispressure(it,irec) = pressure(ix_rec(irec),iy_rec(irec))
  enddo

! compute total energy in the medium (without the PML layers)
  if (COMPUTE_ENERGY) then

! compute kinetic energy first, defined as 1/2 rho ||v||^2
    total_energy_kinetic(it) = ZERO
    do j = NPOINTS_PML+1, NY-NPOINTS_PML
      do i = NPOINTS_PML+1, NX-NPOINTS_PML
! interpolate vy back at the location of vx, to be able to use both at the same location
        vy_interpolated = 0.25d0 * (vy(i,j) + vy(i-1,j) + vy(i-1,j-1) + vy(i,j-1))
        total_energy_kinetic(it) = total_energy_kinetic(it) + 0.5d0 * rho(i,j) * (vx(i,j)**2 + vy_interpolated**2)
      enddo
    enddo

! add potential energy, defined as 1/2 pressure^2 / Kappa
    total_energy_potential(it) = ZERO
    do j = NPOINTS_PML+1, NY-NPOINTS_PML
      do i = NPOINTS_PML+1, NX-NPOINTS_PML
! interpolate material parameters at the right location in the staggered grid cell
        kappa_half_x = 0.5d0 * (kappa_unrelaxed(i+1,j) + kappa_unrelaxed(i,j))
        total_energy_potential(it) = total_energy_potential(it) + 0.5d0 * pressure(i,j)**2 / kappa_half_x
      enddo
    enddo

  endif

! output information
  if (mod(it,IT_DISPLAY) == 0 .or. it == 5) then

! print maximum of pressure and of norm of velocity
    pressurenorm = maxval(abs(pressure))
    velocnorm = maxval(sqrt(vx**2 + vy**2))
    print *,'Time step # ',it,' out of ',NSTEP
    print *,'Time: ',sngl((it-1)*DELTAT),' seconds'
    print *,'Max absolute value of pressure = ',pressurenorm
    print *,'Max norm velocity vector V (m/s) = ',velocnorm
    if (COMPUTE_ENERGY) print *,'total energy = ',total_energy_kinetic(it) + total_energy_potential(it)
    print *
! check stability of the code, exit if unstable
    if (pressurenorm > STABILITY_THRESHOLD .or. velocnorm > STABILITY_THRESHOLD) stop 'code became unstable and blew up'

!   call create_color_image(vx,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &
!                        NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,1)
!   call create_color_image(vy,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &
!                        NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,2)
    call create_color_image(pressure,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &
                         NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,3)

! save the part of the seismograms that has been computed so far, so that users can monitor the progress of the simulation
    call write_seismograms(sisvx,sisvy,sispressure,NSTEP,NREC,DELTAT,t0)

  endif

  enddo   ! end of time loop

! save seismograms
  call write_seismograms(sisvx,sisvy,sispressure,NSTEP,NREC,DELTAT,t0)

  if (COMPUTE_ENERGY) then

! save total energy
    open(unit=20,file='energy.dat',status='unknown')
    do it = 1,NSTEP
      write(20,*) sngl(dble(it-1)*DELTAT),sngl(total_energy_kinetic(it)), &
         sngl(total_energy_potential(it)),sngl(total_energy_kinetic(it) + total_energy_potential(it))
    enddo
    close(20)

! create script for Gnuplot for total energy
    open(unit=20,file='plot_energy',status='unknown')
    write(20,*) '# set term x11'
    write(20,*) 'set term postscript landscape monochrome dashed "Helvetica" 22'
    write(20,*)
    write(20,*) 'set xlabel "Time (s)"'
    write(20,*) 'set ylabel "Total energy"'
    write(20,*)
    write(20,*) 'set output "cpml_total_energy_semilog.eps"'
    write(20,*) 'set logscale y'
    write(20,*) 'plot "energy.dat" us 1:2 t ''Ec'' w l lc 1, "energy.dat" us 1:3 &
                & t ''Ep'' w l lc 3, "energy.dat" us 1:4 t ''Total energy'' w l lc 4'
    write(20,*) 'pause -1 "Hit any key..."'
    write(20,*)
    close(20)

  endif

! create script for Gnuplot
  open(unit=20,file='plotgnu',status='unknown')
  write(20,*) 'set term x11'
  write(20,*) '# set term postscript landscape monochrome dashed "Helvetica" 22'
  write(20,*)
  write(20,*) 'set xlabel "Time (s)"'
  write(20,*) 'set ylabel "Amplitude (m / s)"'
  write(20,*)

  write(20,*) 'set output "v_sigma_Vx_receiver_001.eps"'
  write(20,*) 'plot "Vx_file_001.dat" t ''Vx C-PML'' w l lc 1'
  write(20,*) 'pause -1 "Hit any key..."'
  write(20,*)

  write(20,*) 'set output "v_sigma_Vy_receiver_001.eps"'
  write(20,*) 'plot "Vy_file_001.dat" t ''Vy C-PML'' w l lc 1'
  write(20,*) 'pause -1 "Hit any key..."'
  write(20,*)

  write(20,*) 'set output "v_sigma_Vx_receiver_002.eps"'
  write(20,*) 'plot "Vx_file_002.dat" t ''Vx C-PML'' w l lc 1'
  write(20,*) 'pause -1 "Hit any key..."'
  write(20,*)

  write(20,*) 'set output "v_sigma_Vy_receiver_002.eps"'
  write(20,*) 'plot "Vy_file_002.dat" t ''Vy C-PML'' w l lc 1'
  write(20,*) 'pause -1 "Hit any key..."'
  write(20,*)

  close(20)

  print *
  print *,'End of the simulation'
  print *

  end program seismic_CPML_2D_viscoacoust_fourth

!----
!----  save the seismograms in ASCII text format
!----

  subroutine write_seismograms(sisvx,sisvy,sispressure,nt,nrec,DELTAT,t0)

  implicit none

  integer nt,nrec
  double precision DELTAT,t0

  double precision sisvx(nt,nrec)
  double precision sisvy(nt,nrec)
  double precision sispressure(nt,nrec)

  integer irec,it

  character(len=100) file_name

! pressure
  do irec=1,nrec
    write(file_name,"('pressure_file_',i3.3,'.dat')") irec
    open(unit=11,file=file_name,status='unknown')
    do it=1,nt
! in the scheme of eq (13) of Robertsson, Blanch and Symes, Geophysics, vol. 59(9), pp 1444-1456 (1994)
! pressure is defined at time t + DELTAT/2, i.e. staggered in time with respect to velocity.
! Here we must thus take this shift of DELTAT/2 into account to save the seismograms at the right time
      write(11,*) sngl(dble(it-1)*DELTAT - t0 + DELTAT/2.d0),' ',sngl(sispressure(it,irec))
    enddo
    close(11)
  enddo

! X component of velocity
  do irec=1,nrec
    write(file_name,"('Vx_file_',i3.3,'.dat')") irec
    open(unit=11,file=file_name,status='unknown')
    do it=1,nt
      write(11,*) sngl(dble(it-1)*DELTAT - t0),' ',sngl(sisvx(it,irec))
    enddo
    close(11)
  enddo

! Y component of velocity
  do irec=1,nrec
    write(file_name,"('Vy_file_',i3.3,'.dat')") irec
    open(unit=11,file=file_name,status='unknown')
    do it=1,nt
      write(11,*) sngl(dble(it-1)*DELTAT - t0),' ',sngl(sisvy(it,irec))
    enddo
    close(11)
  enddo

  end subroutine write_seismograms

!----
!----  routine to create a color image of a given vector component
!----  the image is created in PNM format and then converted to GIF
!----

  subroutine create_color_image(image_data_2D,NX,NY,it,ISOURCE,JSOURCE,ix_rec,iy_rec,nrec, &
              NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,field_number)

  implicit none

! non linear display to enhance small amplitudes for graphics
  double precision, parameter :: POWER_DISPLAY = 0.30d0

! amplitude threshold above which we draw the color point
  double precision, parameter :: cutvect = 0.01d0

! use black or white background for points that are below the threshold
  logical, parameter :: WHITE_BACKGROUND = .true.

! size of cross and square in pixels drawn to represent the source and the receivers
  integer, parameter :: width_cross = 5, thickness_cross = 1, size_square = 3

  integer NX,NY,it,field_number,ISOURCE,JSOURCE,NPOINTS_PML,nrec
  logical USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX

! in order to be able to use a fourth-order spatial operator on the edges of the model
! here we define the array with size (0:NX+1,0:NY+1) instead of size (NX,NY) as in the second-order case
  double precision, dimension(0:NX+1,0:NY+1) :: image_data_2D

  integer, dimension(nrec) :: ix_rec,iy_rec

  integer :: ix,iy,irec

  character(len=100) :: file_name,system_command

  integer :: R, G, B

  double precision :: normalized_value,max_amplitude

! open image file and create system command to convert image to more convenient format
! use the "convert" command from ImageMagick http://www.imagemagick.org
  if (field_number == 1) then
    write(file_name,"('image',i6.6,'_Vx.pnm')") it
    write(system_command,"('convert image',i6.6,'_Vx.pnm image',i6.6,'_Vx.gif ; rm image',i6.6,'_Vx.pnm')") it,it,it
  else if (field_number == 2) then
    write(file_name,"('image',i6.6,'_Vy.pnm')") it
    write(system_command,"('convert image',i6.6,'_Vy.pnm image',i6.6,'_Vy.gif ; rm image',i6.6,'_Vy.pnm')") it,it,it
  else if (field_number == 3) then
    write(file_name,"('image',i6.6,'_pressure.pnm')") it
    write(system_command,"('convert image',i6.6,'_pressure.pnm image',i6.6,'_pressure.gif ; rm image',i6.6,'_pressure.pnm')") &
                               it,it,it
  endif

  open(unit=27, file=file_name, status='unknown')

  write(27,"('P3')") ! write image in PNM P3 format

  write(27,*) NX,NY ! write image size
  write(27,*) '255' ! maximum value of each pixel color

! compute maximum amplitude
  max_amplitude = maxval(abs(image_data_2D))

! image starts in upper-left corner in PNM format
  do iy=NY,1,-1
    do ix=1,NX

! define data as vector component normalized to [-1:1] and rounded to nearest integer
! keeping in mind that amplitude can be negative
    normalized_value = image_data_2D(ix,iy) / max_amplitude

! suppress values that are outside [-1:+1] to avoid small edge effects
    if (normalized_value < -1.d0) normalized_value = -1.d0
    if (normalized_value > 1.d0) normalized_value = 1.d0

! draw an orange cross to represent the source
    if ((ix >= ISOURCE - width_cross .and. ix <= ISOURCE + width_cross .and. &
        iy >= JSOURCE - thickness_cross .and. iy <= JSOURCE + thickness_cross) .or. &
       (ix >= ISOURCE - thickness_cross .and. ix <= ISOURCE + thickness_cross .and. &
        iy >= JSOURCE - width_cross .and. iy <= JSOURCE + width_cross)) then
      R = 255
      G = 157
      B = 0

! display two-pixel-thick black frame around the image
  else if (ix <= 2 .or. ix >= NX-1 .or. iy <= 2 .or. iy >= NY-1) then
      R = 0
      G = 0
      B = 0

! display edges of the PML layers
  else if ((USE_PML_XMIN .and. ix == NPOINTS_PML) .or. &
          (USE_PML_XMAX .and. ix == NX - NPOINTS_PML) .or. &
          (USE_PML_YMIN .and. iy == NPOINTS_PML) .or. &
          (USE_PML_YMAX .and. iy == NY - NPOINTS_PML)) then
      R = 255
      G = 150
      B = 0

! suppress all the values that are below the threshold
    else if (abs(image_data_2D(ix,iy)) <= max_amplitude * cutvect) then

! use a black or white background for points that are below the threshold
      if (WHITE_BACKGROUND) then
        R = 255
        G = 255
        B = 255
      else
        R = 0
        G = 0
        B = 0
      endif

! represent regular image points using red if value is positive, blue if negative
    else if (normalized_value >= 0.d0) then
      R = nint(255.d0*normalized_value**POWER_DISPLAY)
      G = 0
      B = 0
    else
      R = 0
      G = 0
      B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY)
    endif

! draw a green square to represent the receivers
  do irec = 1,nrec
    if ((ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. &
        iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square) .or. &
       (ix >= ix_rec(irec) - size_square .and. ix <= ix_rec(irec) + size_square .and. &
        iy >= iy_rec(irec) - size_square .and. iy <= iy_rec(irec) + size_square)) then
! use dark green color
      R = 30
      G = 180
      B = 60
    endif
  enddo

! write color pixel
    write(27,"(i3,' ',i3,' ',i3)") R,G,B

    enddo
  enddo

! close file
  close(27)

! call the system to convert image to Gif (can be commented out if "call system" is missing in your compiler)
! call system(system_command)

  end subroutine create_color_image

!
!---- include the SolvOpt() routine that is used to compute the tau_epsilon and tau_sigma values from a given Q attenuation factor
!

include "attenuation_model_with_SolvOpt.f90"


!=======================================================================
      SUBROUTINE ORTHNRM(N, LIM, ORTHO, KPASS, NNCV, SCRA1, BASIS, RESTART)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
!=======================================================================
!
!       It orthogonalizes the new NNCV basis vectors starting from the
!       kpass+1, to the previous vectors of the basis and to themselves.
!       A Gram-Schmidt method is followed after which the residuals
!       should be orthogonal to the BASIS. Because of machine arithmetic
!       errors this orthogonality may be lost, and a reorthogonalization
!       procedure is adopted whenever orthogonality loss is above a
!       ORTHO. If after some reorthogonalizations the procedure does not
!       converge to orthogonality, the basis is collapsed to the
!       current eigenvector approximations.
!
!       Subroutines called:
!       DAXPY, DDOT, DSCAL
!-----------------------------------------------------------------------
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:04:22  11/16/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE ddot_I
      USE daxpy_I
      USE dcopy_I
      USE dscal_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: N
      INTEGER , INTENT(IN) :: LIM
      INTEGER , INTENT(IN) :: KPASS
      INTEGER , INTENT(INOUT) :: NNCV
      REAL(DOUBLE) , INTENT(IN) :: ORTHO
      LOGICAL , INTENT(OUT) :: RESTART
      REAL(DOUBLE) , INTENT(INOUT) :: SCRA1(N)
      REAL(DOUBLE)  :: BASIS(N*LIM)
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: ICUR, IV, IBSTART, I
      REAL(DOUBLE) :: DPREV, DCUR
!-----------------------------------------------
!-----------------------------------------------------------------------
!   on entry
!   --------
!   N           The order of the matrix A
!   LIM         The limit on the size of the expanding Basis
!   ORTHO       The orthogonality threshold
!   KPASS       The number of basis vectors already in Basis
!   NNCV        The number of new vectors in the basis
!   SCRA1       Scratch vector of size N
!   BASIS       the expanding basis having kpass vectors
!
!   on exit
!   -------
!   BASIS       the new basis orthonormalized
!   RESTART     Logical, if true the algoritm will collapse BASIS.
!-----------------------------------------------------------------------
!
! ORTHOGONALIZATION
!
      RESTART = .FALSE.
      ICUR = KPASS*N + 1
!
!       .. do iv=1,nncv
      IV = 1
   30 CONTINUE
      DPREV = 1.D+7
    5 CONTINUE
      DCUR = 0.D0
      IBSTART = 1
      DO I = 1, KPASS + IV - 1
         SCRA1(I) = DDOT(N,BASIS(IBSTART),1,BASIS(ICUR),1)
         DCUR = MAX(DCUR,ABS(SCRA1(I)))
         IBSTART = IBSTART + N
      END DO
      IBSTART = 1
      DO I = 1, KPASS + IV - 1
         CALL DAXPY (N, (-SCRA1(I)),BASIS(IBSTART), 1, BASIS(ICUR), 1)
         IBSTART = IBSTART + N
      END DO

      IF (DCUR >= ORTHO) THEN
         IF (DCUR > DPREV) THEN
            RESTART = .TRUE.
!                ..Adjust the number of added vectors.
            NNCV = IV - 1
            RETURN
         ELSE
            DPREV = DCUR
            GO TO 5
         ENDIF
      ENDIF
!
! NORMALIZATION
!
      SCRA1(1) = DDOT(N,BASIS(ICUR),1,BASIS(ICUR),1)
      SCRA1(1) = SQRT(SCRA1(1))
      IF (SCRA1(1) < 1D-14) THEN
         CALL DCOPY (N, BASIS(N*(NNCV-1)+1), 1, BASIS(ICUR), 1)
         NNCV = NNCV - 1
      ELSE
         CALL DSCAL (N, 1/SCRA1(1), BASIS(ICUR), 1)
         ICUR = ICUR + N
         IV = IV + 1
      ENDIF
      IF (IV <= NNCV) GO TO 30

      RETURN
      END SUBROUTINE ORTHNRM