!
! 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 viscoelastic 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_viscoelast_second

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

! Dimitri Komatitsch, CNRS, Marseille, July 2018.

! The second-order staggered-grid formulation of Madariaga (1976) and Virieux (1986) is used:
!
!            ^ y
!            |
!            |
!
!            +-------------------+
!            |                   |
!            |                   |
!            |                   |
!            |                   |
!            |        v_y        |
!   sigma_xy +---------+         |
!        e13 |         |         |
!    (memory |         |         |
!  variable) |         |         |
!            |         |         |
!            |         |         |
!            +---------+---------+  ---> x
!           v_x    sigma_xx
!                  sigma_yy
!                  e1 (viscoelastic memory variable)
!                  e11 (viscoelastic 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 viscoelastic attenuation or not
  logical, parameter :: VISCOELASTIC_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 :: cs_unrelaxed = cp_unrelaxed / 1.732d0
  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 = 5200

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

! source (force)
  double precision, parameter :: xsource = 1500.d0
  double precision, parameter :: ysource = 1500.d0
  integer, parameter :: ISOURCE = xsource / DELTAX + 1
  integer, parameter :: JSOURCE = ysource / DELTAY + 1
! angle of source force in degrees and clockwise, with respect to the vertical (Y) axis
  double precision, parameter :: ANGLE_FORCE = 0.d0

! 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 second-order spatial scheme
  double precision, parameter :: ONE_OVER_DELTAX = 1.d0 / DELTAX
  double precision, parameter :: ONE_OVER_DELTAY = 1.d0 / DELTAY

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

! conversion from degrees to radians
  double precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0

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

  double precision, parameter :: TWO_THIRDS = 2.d0 / 3.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
  double precision, dimension(NX,NY) :: vx,vy,sigma_xx,sigma_yy,sigma_xy,lambda_unrelaxed,mu_unrelaxed,rho

! to interpolate material parameters or velocity at the right location in the staggered grid cell
  double precision :: lambda_half_x,mu_half_x,lambda_plus_mu_half_x,lambda_plus_two_mu_half_x,mu_half_y
  double precision :: rho_half_x_half_y,vy_interpolated

! for evolution of total energy in the medium
  double precision :: epsilon_xx,epsilon_yy,epsilon_xy
  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_dsigma_xx_dx, &
      memory_dsigma_yy_dy, &
      memory_dsigma_xy_dx, &
      memory_dsigma_xy_dy

  double precision :: &
      value_dvx_dx, &
      value_dvx_dy, &
      value_dvy_dx, &
      value_dvy_dy, &
      value_dsigma_xx_dx, &
      value_dsigma_yy_dy, &
      value_dsigma_xy_dx, &
      value_dsigma_xy_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,force_x,force_y,force_source_term

! for receivers
! Please note something important: the two components of the velocity vector are not defined at the same location,
! Vy is half a grid cell away from Vx (see ASCII figure at the beginning of this program).
! Thus this means there are "two receivers" rather than one, one recording Vx and another one, half a grid cell away, recording Vy.
! If you need to use both components in real applications (and of course we will),
! you will need to interpolate Vy to the location of Vx using:
!
! 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))
!
  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

! for attenuation (viscoelasticity)

! attenuation quality factors Qp and Qs to use
! BEWARE: we use Qp and Qs here, not QKappa and Qmu.
! BEWARE: While Qmu is always equal to Qs, QKappa is not equal to Qp,
! BEWARE: to convert from one to the other if your input data have Qkappa and Qmu you can use
! BEWARE: the program conversion_between_Qp_Qs_and_Qkappa_Qmu_from_Dahlen_Tromp_959_960_in_3D_and_in_2D_plane_strain.f90
! BEWARE: that is included in this software package.
  double precision, parameter :: Qp = 65.d0
  double precision, parameter :: Qs = 55.d0

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

! attenuation constants
  double precision, dimension(N_SLS) :: tau_epsilon_nu1,tau_sigma_nu1,one_over_tau_sigma_nu1, &
                           HALF_DELTAT_over_tau_sigma_nu1,multiplication_factor_tau_sigma_nu1,DELTAT_phi_nu1
  double precision, dimension(N_SLS) :: tau_epsilon_nu2,tau_sigma_nu2,one_over_tau_sigma_nu2, &
                           HALF_DELTAT_over_tau_sigma_nu2,multiplication_factor_tau_sigma_nu2,DELTAT_phi_nu2

! memory variable and other arrays for attenuation
  double precision, dimension(NX,NY,N_SLS) :: memory_variable_R_e1_dot,memory_variable_R_e1_dot_old
  double precision, dimension(NX,NY,N_SLS) :: memory_variable_R_e11_dot,memory_variable_R_e11_dot_old
  double precision, dimension(NX,NY,N_SLS) :: memory_variable_R_e13_dot,memory_variable_R_e13_dot_old
  integer :: i_sls
  double precision :: sum_of_memory_variables_e1,sum_of_memory_variables_e11,sum_of_memory_variables_e13

! 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 viscoelastic finite-difference code in velocity and stress 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 (viscoelasticity)
  if (VISCOELASTIC_ATTENUATION) then

  print *,'Qp quality factor used for attenuation = ',Qp
  print *,'Qs quality factor used for attenuation = ',Qs
  print *,'Number of Zener standard linear solids used to mimic the viscoelastic 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
  print *,'Values for Qp:'
  print *
  call compute_attenuation_coeffs(N_SLS,Qp,f0,f_min_attenuation,f_max_attenuation,tau_epsilon_nu1,tau_sigma_nu1)
  print *,'Values for Qs:'
  print *
  call compute_attenuation_coeffs(N_SLS,Qs,f0,f_min_attenuation,f_max_attenuation,tau_epsilon_nu2,tau_sigma_nu2)

  else

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

    tau_epsilon_nu2(:) = 1.d0
    tau_sigma_nu2(:) = 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_nu1(:) = 1.d0 / tau_sigma_nu1(:)
  one_over_tau_sigma_nu2(:) = 1.d0 / tau_sigma_nu2(:)

  HALF_DELTAT_over_tau_sigma_nu1(:) = 0.5d0 * DELTAT / tau_sigma_nu1(:)
  HALF_DELTAT_over_tau_sigma_nu2(:) = 0.5d0 * DELTAT / tau_sigma_nu2(:)

  multiplication_factor_tau_sigma_nu1(:) = 1.d0 / (1.d0 + 0.5d0 * DELTAT * one_over_tau_sigma_nu1(:))
  multiplication_factor_tau_sigma_nu2(:) = 1.d0 / (1.d0 + 0.5d0 * DELTAT * one_over_tau_sigma_nu2(:))

  ! use the right formula with 1/N included
  DELTAT_phi_nu1(:) = DELTAT * (1.d0 - tau_epsilon_nu1(:)/tau_sigma_nu1(:)) / tau_sigma_nu1(:) / sum(tau_epsilon_nu1/tau_sigma_nu1)
  DELTAT_phi_nu2(:) = DELTAT * (1.d0 - tau_epsilon_nu2(:)/tau_sigma_nu2(:)) / tau_sigma_nu2(:) / sum(tau_epsilon_nu2/tau_sigma_nu2)

!--- 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
      mu_unrelaxed(i,j) = density*cs_unrelaxed*cs_unrelaxed
      lambda_unrelaxed(i,j) = density*cp_unrelaxed*cp_unrelaxed - 2.d0*mu_unrelaxed(i,j)
    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,2) scheme, when DELTAX == DELTAY the Courant number is 1/sqrt(2) = 0.707
  if (DELTAX == DELTAY) then
    Courant_number = cp_unrelaxed * DELTAT / DELTAX
    print *,'Courant number is ',Courant_number
    print *,' (the maximum possible value is 1/sqrt(2) = 0.707; &
                  &in practice for accuracy reasons a value not larger than 0.30 is recommended)'
    print *
    if (Courant_number > 1.d0/sqrt(2.d0)) 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_file*.dat Vy_file*.dat image*.pnm image*.gif')

! initialize arrays
  vx(:,:) = ZERO
  vy(:,:) = ZERO
  sigma_xx(:,:) = ZERO
  sigma_yy(:,:) = ZERO
  sigma_xy(:,:) = ZERO
  memory_variable_R_e1_dot(:,:,:) = ZERO
  memory_variable_R_e1_dot_old(:,:,:) = ZERO
  memory_variable_R_e11_dot(:,:,:) = ZERO
  memory_variable_R_e11_dot_old(:,:,:) = ZERO
  memory_variable_R_e13_dot(:,:,:) = ZERO
  memory_variable_R_e13_dot_old(:,:,:) = ZERO

! PML
  memory_dvx_dx(:,:) = ZERO
  memory_dvx_dy(:,:) = ZERO
  memory_dvy_dx(:,:) = ZERO
  memory_dvy_dy(:,:) = ZERO
  memory_dsigma_xx_dx(:,:) = ZERO
  memory_dsigma_yy_dy(:,:) = ZERO
  memory_dsigma_xy_dx(:,:) = ZERO
  memory_dsigma_xy_dy(:,:) = ZERO

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

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

  if (VISCOELASTIC_ATTENUATION) then
    print *,'adding VISCOELASTIC_ATTENUATION (i.e., running a viscoelastic simulation)'
  else
    print *,'not adding VISCOELASTIC_ATTENUATION (i.e., running a purely elastic simulation)'
  endif
  print *

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

  do it = 1,NSTEP

!-----------------------------------------------------------------------
! compute the stress tensor and update memory variables for C-PML
! also update memory variables for viscoelastic 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. VISCOELASTIC_ATTENUATION) then

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

! interpolate material parameters at the right location in the staggered grid cell
      lambda_half_x = 0.5d0 * (lambda_unrelaxed(i+1,j) + lambda_unrelaxed(i,j))
      mu_half_x = 0.5d0 * (mu_unrelaxed(i+1,j) + mu_unrelaxed(i,j))
      lambda_plus_two_mu_half_x = lambda_half_x + 2.d0 * mu_half_x

      value_dvx_dx = (vx(i+1,j) - vx(i,j)) * ONE_OVER_DELTAX
      value_dvy_dy = (vy(i,j) - vy(i,j-1)) * ONE_OVER_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 / K_x_half(i) + memory_dvx_dx(i,j)
      value_dvy_dy = value_dvy_dy / K_y(j) + memory_dvy_dy(i,j)

      sigma_xx(i,j) = sigma_xx(i,j) + (lambda_plus_two_mu_half_x * value_dvx_dx + lambda_half_x * value_dvy_dy) * DELTAT

      sigma_yy(i,j) = sigma_yy(i,j) + (lambda_half_x * value_dvx_dx + lambda_plus_two_mu_half_x * value_dvy_dy) * DELTAT

      enddo
    enddo

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

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

        value_dvy_dx = (vy(i,j) - vy(i-1,j)) * ONE_OVER_DELTAX
        value_dvx_dy = (vx(i,j+1) - vx(i,j)) * ONE_OVER_DELTAY

        memory_dvy_dx(i,j) = b_x(i) * memory_dvy_dx(i,j) + a_x(i) * value_dvy_dx
        memory_dvx_dy(i,j) = b_y_half(j) * memory_dvx_dy(i,j) + a_y_half(j) * value_dvx_dy

        value_dvy_dx = value_dvy_dx / K_x(i) + memory_dvy_dx(i,j)
        value_dvx_dy = value_dvx_dy / K_y_half(j) + memory_dvx_dy(i,j)

        sigma_xy(i,j) = sigma_xy(i,j) + mu_half_y * (value_dvy_dx + value_dvx_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_e1_dot_old(:,:,:) = memory_variable_R_e1_dot(:,:,:)
    memory_variable_R_e11_dot_old(:,:,:) = memory_variable_R_e11_dot(:,:,:)
    memory_variable_R_e13_dot_old(:,:,:) = memory_variable_R_e13_dot(:,:,:)

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

! interpolate material parameters at the right location in the staggered grid cell
        lambda_half_x = 0.5d0 * (lambda_unrelaxed(i+1,j) + lambda_unrelaxed(i,j))
        mu_half_x = 0.5d0 * (mu_unrelaxed(i+1,j) + mu_unrelaxed(i,j))
        lambda_plus_mu_half_x = lambda_half_x + mu_half_x
        lambda_plus_two_mu_half_x = lambda_half_x + 2.d0 * mu_half_x

        value_dvx_dx = (vx(i+1,j) - vx(i,j)) * ONE_OVER_DELTAX
        value_dvy_dy = (vy(i,j) - vy(i,j-1)) * ONE_OVER_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 / K_x_half(i) + memory_dvx_dx(i,j)
        value_dvy_dy = value_dvy_dy / 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_e1 = 0.d0
        sum_of_memory_variables_e11 = 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_e1_dot(i,j,i_sls) = (memory_variable_R_e1_dot_old(i,j,i_sls) + &
                   (value_dvx_dx + value_dvy_dy) * DELTAT_phi_nu1(i_sls) - &
                   memory_variable_R_e1_dot_old(i,j,i_sls) * HALF_DELTAT_over_tau_sigma_nu1(i_sls)) &
                      * multiplication_factor_tau_sigma_nu1(i_sls)

          memory_variable_R_e11_dot(i,j,i_sls) = (memory_variable_R_e11_dot_old(i,j,i_sls) + &
                   0.5d0 * (value_dvx_dx - value_dvy_dy) * DELTAT_phi_nu2(i_sls) - &
                   memory_variable_R_e11_dot_old(i,j,i_sls) * HALF_DELTAT_over_tau_sigma_nu2(i_sls)) &
                      * multiplication_factor_tau_sigma_nu2(i_sls)

          sum_of_memory_variables_e1 = sum_of_memory_variables_e1 + &
                      memory_variable_R_e1_dot(i,j,i_sls) + memory_variable_R_e1_dot_old(i,j,i_sls)

          sum_of_memory_variables_e11 = sum_of_memory_variables_e11 + &
                      memory_variable_R_e11_dot(i,j,i_sls) + memory_variable_R_e11_dot_old(i,j,i_sls)
        enddo

        sigma_xx(i,j) = sigma_xx(i,j) + &
           (lambda_plus_two_mu_half_x * value_dvx_dx + lambda_half_x * value_dvy_dy &
! use the right formula with 1/N included
! i.e. use the unrelaxed moduli here (see Carcione's book, third edition, equation (3.189))
! 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 * lambda_plus_mu_half_x * sum_of_memory_variables_e1 + mu_half_x * sum_of_memory_variables_e11)) * DELTAT

        sigma_yy(i,j) = sigma_yy(i,j) + &
           (lambda_half_x * value_dvx_dx + lambda_plus_two_mu_half_x * value_dvy_dy &
! use the right formula with 1/N included
! i.e. use the unrelaxed moduli here (see Carcione's book, third edition, equation (3.189))
! 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 * lambda_plus_mu_half_x * sum_of_memory_variables_e1 - mu_half_x * sum_of_memory_variables_e11)) * DELTAT

      enddo
    enddo

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

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

        value_dvy_dx = (vy(i,j) - vy(i-1,j)) * ONE_OVER_DELTAX
        value_dvx_dy = (vx(i,j+1) - vx(i,j)) * ONE_OVER_DELTAY

        memory_dvy_dx(i,j) = b_x(i) * memory_dvy_dx(i,j) + a_x(i) * value_dvy_dx
        memory_dvx_dy(i,j) = b_y_half(j) * memory_dvx_dy(i,j) + a_y_half(j) * value_dvx_dy

        value_dvy_dx = value_dvy_dx / K_x(i) + memory_dvy_dx(i,j)
        value_dvx_dy = value_dvx_dy / K_y_half(j) + memory_dvx_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_e13 = 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_e13_dot(i,j,i_sls) = (memory_variable_R_e13_dot_old(i,j,i_sls) + &
                   (value_dvy_dx + value_dvx_dy) * DELTAT_phi_nu2(i_sls) - &
                   memory_variable_R_e13_dot_old(i,j,i_sls) * HALF_DELTAT_over_tau_sigma_nu2(i_sls)) &
                      * multiplication_factor_tau_sigma_nu2(i_sls)

          sum_of_memory_variables_e13 = sum_of_memory_variables_e13 + &
                      memory_variable_R_e13_dot(i,j,i_sls) + memory_variable_R_e13_dot_old(i,j,i_sls)
        enddo

        sigma_xy(i,j) = sigma_xy(i,j) + mu_half_y * (value_dvy_dx + value_dvx_dy &
! use the right formula with 1/N included
! i.e. use the unrelaxed moduli here (see Carcione's book, third edition, equation (3.189))
! 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_e13) * DELTAT

      enddo
    enddo

  endif

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

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

      value_dsigma_xx_dx = (sigma_xx(i,j) - sigma_xx(i-1,j)) * ONE_OVER_DELTAX
      value_dsigma_xy_dy = (sigma_xy(i,j) - sigma_xy(i,j-1)) * ONE_OVER_DELTAY

      memory_dsigma_xx_dx(i,j) = b_x(i) * memory_dsigma_xx_dx(i,j) + a_x(i) * value_dsigma_xx_dx
      memory_dsigma_xy_dy(i,j) = b_y(j) * memory_dsigma_xy_dy(i,j) + a_y(j) * value_dsigma_xy_dy

      value_dsigma_xx_dx = value_dsigma_xx_dx / K_x(i) + memory_dsigma_xx_dx(i,j)
      value_dsigma_xy_dy = value_dsigma_xy_dy / K_y(j) + memory_dsigma_xy_dy(i,j)

      vx(i,j) = vx(i,j) + (value_dsigma_xx_dx + value_dsigma_xy_dy) * 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_dsigma_xy_dx = (sigma_xy(i+1,j) - sigma_xy(i,j)) * ONE_OVER_DELTAX
      value_dsigma_yy_dy = (sigma_yy(i,j+1) - sigma_yy(i,j)) * ONE_OVER_DELTAY

      memory_dsigma_xy_dx(i,j) = b_x_half(i) * memory_dsigma_xy_dx(i,j) + a_x_half(i) * value_dsigma_xy_dx
      memory_dsigma_yy_dy(i,j) = b_y_half(j) * memory_dsigma_yy_dy(i,j) + a_y_half(j) * value_dsigma_yy_dy

      value_dsigma_xy_dx = value_dsigma_xy_dx / K_x_half(i) + memory_dsigma_xy_dx(i,j)
      value_dsigma_yy_dy = value_dsigma_yy_dy / K_y_half(j) + memory_dsigma_yy_dy(i,j)

      vy(i,j) = vy(i,j) + (value_dsigma_xy_dx + value_dsigma_yy_dy) * DELTAT / rho_half_x_half_y

    enddo
  enddo

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

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

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

! Ricker source time function (second derivative of a Gaussian)
  force_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 force source)
  force_source_term = force_source_term / (DELTAX * DELTAY)

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

  force_x = sin(ANGLE_FORCE * DEGREES_TO_RADIANS) * force_source_term
  force_y = cos(ANGLE_FORCE * DEGREES_TO_RADIANS) * force_source_term

! 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))

! we want seismograms to be representing velocity, for the case of the seismic wave equation
! representing displacement for a Ricker (i.e., second derivative of a Gaussian) source in displacement.
! Since the force source is added to d(velocity)/dt in this split velocity and stress scheme
! we need to select the second derivative of a Gaussian as a source time wavelet
! by analogy with a Ricker (i.e. a second derivative) added to d2(displacement)/dt2
! as in the unsplit equation written in displacement only.
! Since the formula is d(velocity)/dt = (velocity_new - velocity_old) / DELTAT = force_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:
! velocity_new = velocity_old + force_source_term * DELTAT at the source grid point
  vx(i,j) = vx(i,j) + force_x * DELTAT / rho(i,j)
  vy(i,j) = vy(i,j) + force_y * DELTAT / rho_half_x_half_y

! 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))

! from L. S. Bennethum, Compressibility Moduli for Porous Materials Incorporating Volume Fraction,
! J. Engrg. Mech., vol. 132(11), p. 1205-1214 (2006), below equation (5):
! for a 3D isotropic solid, pressure is defined in terms of the trace of the stress tensor as
! p = -1/3 (t11 + t22 + t33) where t is the Cauchy stress tensor.

! to compute pressure in 3D in an elastic solid, one uses pressure = - trace(sigma) / 3
! sigma_ij = lambda delta_ij trace(epsilon) + 2 mu epsilon_ij
!          = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_ij
! sigma_xx = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_xx
! sigma_yy = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_yy
! sigma_zz = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_zz
! pressure = - trace(sigma) / 3 = - (lambda + 2/3 mu) trace(epsilon) = - kappa * trace(epsilon)
!
! to compute pressure in 2D in an elastic solid in the plane strain convention i.e. in the P-SV case,
! one still uses pressure = - trace(sigma) / 3 but taking into account the fact
! that the off-plane strain epsilon_zz is zero by definition of the plane strain convention
! but thus the off-plane stress sigma_zz is not equal to zero,
! one has instead:  sigma_zz = lambda * (epsilon_xx + epsilon_yy), thus
! sigma_ij = lambda delta_ij trace(epsilon) + 2 mu epsilon_ij
!          = lambda (epsilon_xx + epsilon_yy) + 2 mu epsilon_ij
! sigma_xx = lambda (epsilon_xx + epsilon_yy) + 2 mu epsilon_xx
! sigma_yy = lambda (epsilon_xx + epsilon_yy) + 2 mu epsilon_yy
! sigma_zz = lambda * (epsilon_xx + epsilon_yy)
! pressure = - trace(sigma) / 3 = - (lambda + 2*mu/3) (epsilon_xx + epsilon_yy)

    i = ix_rec(irec)
    j = iy_rec(irec)

! interpolate material parameters at the right location in the staggered grid cell
    lambda_half_x = 0.5d0 * (lambda_unrelaxed(i+1,j) + lambda_unrelaxed(i,j))
    mu_half_x = 0.5d0 * (mu_unrelaxed(i+1,j) + mu_unrelaxed(i,j))
    epsilon_xx = ((lambda_half_x + 2.d0*mu_half_x) * sigma_xx(i,j) - lambda_half_x * &
      sigma_yy(i,j)) / (4.d0 * mu_half_x * (lambda_half_x + mu_half_x))
    epsilon_yy = ((lambda_half_x + 2.d0*mu_half_x) * sigma_yy(i,j) - lambda_half_x * &
      sigma_xx(i,j)) / (4.d0 * mu_half_x * (lambda_half_x + mu_half_x))

    sispressure(it,irec) = - (lambda_half_x + TWO_THIRDS*mu_half_x) * (epsilon_xx + epsilon_yy)

  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 epsilon_ij sigma_ij
    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
        lambda_half_x = 0.5d0 * (lambda_unrelaxed(i+1,j) + lambda_unrelaxed(i,j))
        mu_half_x = 0.5d0 * (mu_unrelaxed(i+1,j) + mu_unrelaxed(i,j))
        mu_half_y = 0.5d0 * (mu_unrelaxed(i,j+1) + mu_unrelaxed(i,j))
        epsilon_xx = ((lambda_half_x + 2.d0*mu_half_x) * sigma_xx(i,j) - lambda_half_x * &
          sigma_yy(i,j)) / (4.d0 * mu_half_x * (lambda_half_x + mu_half_x))
        epsilon_yy = ((lambda_half_x + 2.d0*mu_half_x) * sigma_yy(i,j) - lambda_half_x * &
          sigma_xx(i,j)) / (4.d0 * mu_half_x * (lambda_half_x + mu_half_x))
        epsilon_xy = sigma_xy(i,j) / (2.d0 * mu_half_y)
        total_energy_potential(it) = total_energy_potential(it) + &
          0.5d0 * (epsilon_xx * sigma_xx(i,j) + epsilon_yy * sigma_yy(i,j) + 2.d0 * epsilon_xy * sigma_xy(i,j))
      enddo
    enddo

  endif

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

! print maximum of norm of velocity
    velocnorm = maxval(sqrt(vx**2 + vy**2))
    print *,'Time step # ',it,' out of ',NSTEP
    print *,'Time: ',sngl((it-1)*DELTAT),' seconds'
    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 (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)

! 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_viscoelast_second

!----
!----  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_half_a_grid_cell_away_from_Vx_',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

  double precision, dimension(NX,NY) :: 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 LEVELS
*
*
*       Histograms of block time-step levels.
*       -------------------------------------
*
      INCLUDE 'common6.h'
      INTEGER  IHIST(32),IHISTR(32)
*
*
*       Initialize histogram counters.
      DO 10 J = 1,32
          IHIST(J) = 0
          IHISTR(J) = 0
   10 CONTINUE
*
*       Loop over all single particles & c.m.
      JMAX = 0
      JMAXR = 0
      FAC = 1.0/LOG(1.9999999)
      DO 20 I = IFIRST,NTOT
          IF (BODY(I).EQ.0.0D0) GO TO 20
          J = 1 - LOG(STEP(I))*FAC
          J = MAX(J,1)    ! watch out for SMAX increasing to 2.0.
          IHIST(J) = IHIST(J) + 1
          JMAX = MAX(J,JMAX)
          J = 1 - LOG(STEPR(I))*FAC
          J = MAX(J,1)
          IHISTR(J) = IHISTR(J) + 1
          JMAXR = MAX(J,JMAXR)
   20 CONTINUE
*
*       Print histograms of block-steps (STEPR with KZ(33) > 1).
      JMAX = MIN(JMAX,27)
      WRITE (6,30)  (IHIST(J),J=1,JMAX)
   30 FORMAT (' #6  STEP   ',12I6,5I5,10I4)
*
      IF (KZ(33).GT.1) THEN
          JMAXR = MIN(JMAXR,27)
          WRITE (6,35)  (IHISTR(J),J=1,JMAXR)
   35     FORMAT (' #7  STEPR  ',10I6,5I5,10I4)
      END IF
*
      RETURN
*
      END


subroutine lsf_gh(x,n,xcenter,par,npar,lsf)

!replicates APOGEE's lsf_gh.pro

use share, only: dp

implicit none

!input/output
real(dp), intent(in)    :: x(n)	   ! pixel location array
real(dp), intent(in)    :: par(npar)!param. array
real(dp), intent(in)    :: xcenter ! position of the lsf center
integer, intent(in)     :: n,npar
real(dp), intent(out)   :: lsf(n)  ! lsf array

!locals
integer,parameter       :: maxporder=5
integer					:: i,j
real(dp)				:: binsize = 0.0_dp    ! width of a pixel in x units  -- par(1)
real(dp)				:: xoffset = 0.0_dp, xcenter1 = 0.0_dp
integer, parameter	    :: Horder  = 5         ! highest allowed hermite order
integer					:: AHorder             ! actual highest hermite order -- par(3)
integer					:: Porder(Horder+1)    ! polynomial order for variation with x
								               ! of each parameter -- par(4:Horder+4)
integer					:: cstart(Horder+2)
real(dp)				:: GHcoefs(Horder+1)   ! There are Porder[i]+1
								               ! coefficients for parameter i.
								               ! The Hermite parameters start with H2
								               ! since we fix H1=1.
real(dp)				:: coefarr(Horder+1,maxporder+1)
real(dp)                :: cpar(npar-(Horder+4)+1)
real(dp)				:: inpar(Horder+4)

binsize=par(1)
xoffset=par(2)
AHorder = floor(par(3))
Porder(1:AHorder+1) = floor(par(4:AHorder+4))

!write(*,*)'binsize,xoffset,AHorder=',binsize,xoffset,AHorder
!write(*,*)'Porder=',Porder(1:AHorder+1)

!checks
if (binsize > 0.1) then
        write(*,*) 'lsf_gh: WARNING'
        write(*,*) 'binsize =',binsize,'> 0  '
        write(*,*)' -- but no binning will be used in building the LSF kernel'
endif
if (maxval(Porder(1:AHorder+1)) > maxporder) then
        write(*,*) 'lsf_gh: ERROR'
        write(*,*) 'maxval(Porder) = ',maxval(Porder),' > maxporder=',maxporder
        stop
endif

cpar = par(AHorder+4+1:npar+1)
cstart(:)=0
do i=1,AHorder+1
	cstart(i+1)=cstart(i)+Porder(i)+1
enddo

!write(*,*)'cpar=',cpar
!write(*,*)'cstart=',cstart

coefarr(:,:)=0._dp
do i=1,AHorder+1
	coefarr(i,:)=0._dp
	coefarr(i,1:Porder(i)+1)= cpar(cstart(i)+1:cstart(i)+Porder(i)+1)
	!write(*,*)i,'coefarr(i,1:porder(i)+1)',coefarr(i,1:Porder(i)+1)
enddo

Xcenter1 = xcenter+xoffset

GHcoefs(:)=0._dp
do i=1,AHorder+1
	!write(*,*)'i=',i
	GHcoefs(i) = 0.0_dp
	do j=1,Porder(i)+1
		GHcoefs(i)=GHcoefs(i)+coefarr(i,j)*Xcenter1**(j-1)
	enddo
	!write(*,*)'GHcoefs(',i,')=',GHcoefs(i)
enddo

inpar(:) = 0.0_dp
inpar(1) = 1.0_dp
inpar(2) = Xcenter
inpar(3) = GHcoefs(1)
inpar(4) = 1.0_dp

!write(*,*)'xcenter,xoffset,xcenter1=',xcenter,xoffset,xcenter1

if (Horder > 0) then
	do i=1,AHorder
		inpar(4+i)=GHcoefs(i+1)
	enddo
endif

!write(*,*)'n,AHorder+4=',n,AHorder+4
!write(*,*)'inpar=',inpar(1:AHorder+4)

call gausshermite(x,n,inpar(1:AHorder+4),AHorder+4,lsf)

end subroutine lsf_gh


      PROGRAM PRINTRANDOM

      INTEGER N
      INTEGER SEED
      REAL RANDX

      SEED = 128
      RANDX = 0

      N = 0
 10   CALL RANDOM(SEED, RANDX)
      PRINT *, RANDX
      N = N + 1
      IF (N.LT.5) GOTO 10

      END

* --------------------------------------------
* Psuedo random number generator
* --------------------------------------------

      SUBROUTINE RANDOM(SEED, RANDX)

      INTEGER SEED
      REAL RANDX

      SEED = 2045*SEED + 1
      SEED = SEED - (SEED/1048576)*1048576
      RANDX = REAL(SEED + 1)/1048577.0
      RETURN

      END

* --------------------------------------------


c-----------------------------------------------------------------------
      program test

      include 'ceedf.h'

      integer ceed,err
      integer x,y
      integer r

      integer ne
      parameter(ne=3)

      real*8 a(2*ne)
      real*8 yy(2*ne)
      real*8 diff
      integer*8 yoffset

      character arg*32

      call getarg(1,arg)
      call ceedinit(trim(arg)//char(0),ceed,err)

      call ceedvectorcreate(ceed,2*ne,x,err)

      do i=1,2*ne
        a(i)=10+i-1
      enddo

      call ceedvectorsetarray(x,ceed_mem_host,ceed_use_pointer,a,err)

      call ceedelemrestrictioncreateidentity(ceed,ne,2,2*ne,1,r,err)

      call ceedvectorcreate(ceed,2*ne,y,err);
      call ceedvectorsetvalue(y,0.d0,err);
      call ceedelemrestrictionapply(r,ceed_notranspose,
     $  ceed_notranspose,x,y,ceed_request_immediate,err)

      call ceedvectorgetarrayread(y,ceed_mem_host,yy,yoffset,err)
      do i=1,ne*2
        diff=10+i-1-yy(yoffset+i)
        if (abs(diff) > 1.0D-15) then
          write(*,*) 'Error in restricted array y(',i,')=',yy(yoffset+i)
        endif
      enddo
      call ceedvectorrestorearrayread(y,yy,yoffset,err)

      call ceedvectordestroy(x,err)
      call ceedvectordestroy(y,err)
      call ceedelemrestrictiondestroy(r,err)
      call ceeddestroy(ceed,err)

      end
c-----------------------------------------------------------------------


program test
      integer::a(10,20)
      integer::b(10,20)
      a = 1
      b = 2
      a(1:5:2,1) = b(1:5:2,2) + b(3:7:2,11)
      PRINT *,a (:,1)
end program test


subroutine init
  ! Subroutine called from main.f90 to initialize the problem
  use globdata
  use alloc_mod
  use io, only: read_input, print_array
  implicit none
  include "mpif.h"
  integer :: i, j, info

  ! Read input on master and broadcast
  if ( rank == 0 ) call read_input('inputfile.txt')
  call MPI_Bcast(lx   , 1, MPI_Double_precision, 0, MPI_comm_world, info)
  call MPI_Bcast(ly   , 1, MPI_Double_precision, 0, MPI_comm_world, info)
  call MPI_Bcast(d    , 1, MPI_Double_precision, 0, MPI_comm_world, info)
  call MPI_Bcast(nx   , 1, MPI_Integer, 0, MPI_comm_world, info)
  call MPI_Bcast(ny   , 1, MPI_Integer, 0, MPI_comm_world, info)
  call MPI_Bcast(n_max, 1, MPI_Integer, 0, MPI_comm_world, info)

  ! Calculate local number of grid points
  nx_loc = nint(real(nx)/real(pnum))
  ny_loc = ny

  ! Since 'nint' may round up check if sum of local slabs exceeds glob. points
  if (nx_loc*pnum > nx) nx_loc = floor(real(nx)/real(pnum))

  if ( rank == pnum-1 ) then
    nx_loc = nx-(pnum-1)*nx_loc ! if remainder is present, give to last proc
  endif

  ! Add ghost layers
  if ( pnum > 1 ) then
    if ( rank == 0 .or. rank == pnum-1 ) then
      nx_loc = nx_loc + 1
    else
      nx_loc = nx_loc + 2
    endif
  endif

  ! Allocate temperature fields
  call alloc_field(    T, nx_loc, ny, info); if ( info .ne. 0 ) goto 2
  call alloc_field(T_old, nx_loc, ny, info); if ( info .ne. 0 ) goto 2

  ! Collect field sizes on the root processor
  allocate(field_sizes(pnum*2))
  call MPI_Gather((/size(T,1), size(T,2)/), 2, MPI_Integer, field_sizes, 2, &
    MPI_Integer, 0, MPI_Comm_world, info)

  ! Set initial conditions
  T = 1
  if ( pnum > 1 ) then
    if ( rank == 0 ) then
      do j = 2, nx_loc
        do i = 2, ny_loc-1
          T(i,j) = 0
        enddo
      enddo
    elseif ( rank == pnum-1 ) then
      do j = 1, nx_loc-1
        do i = 2, ny_loc-1
          T(i,j) = 0
        enddo
      enddo
    else
      do j = 1, nx_loc
        do i = 2, ny_loc-1
          T(i,j) = 0
        enddo
      enddo
    endif
  else
    do j = 2, nx_loc-1
      do i = 2, ny_loc-1
        T(i,j) = 0
      enddo
    enddo
  endif

  ! Initiate the n-1 field
  T_old = T

  ! Define grid spacing
  dx = real(lx)/real(nx-1)
  dy = real(ly)/real(ny-1)

  ! Time increment
  dt = min(dx,dy)**2/(4.0_mkd*d)

  ! Set global iteration start variable
  n_start = 1

  return

  ! Error handling
  2 write(*,'(a)') 'ERROR allocation failed in subroutine "init"'
  stop 1

end subroutine init


! PR libfortran/47757
! { dg-do run { target fortran_large_int } }

  integer(16) :: a16(2,2)
  logical :: mask(2,2)
  logical :: mask2
  a16 = 0
  mask2 = .true.
  mask = reshape([.true.,.true.,.false.,.true.],[2,2])
  print *, iany(a16, dim=1, mask=mask)
  print *, iall(a16, dim=1, mask=mask)
  print *, iparity(a16, dim=1, mask=mask)
  print *, iany(a16, dim=1, mask=mask2)
  print *, iall(a16, dim=1, mask=mask2)
  print *, iparity(a16, dim=1, mask=mask2)
end


** Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
** See https://llvm.org/LICENSE.txt for license information.
** SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

*   Allocatable arrays

	program bq35
	parameter (NT=24)
	common m,mm,n,nn
	data m/1/, mm/3/, n/1/, nn/5/
	integer result(3,8), expect(3,8)
	common /result/result
	data expect /
     +   1, 2, 3, 2, 4, 6, 3, 6,
     +   9, 4, 8, 12, 5, 10, 15, 6,
     +   12, 18, 7, 14, 21, 8, 16, 24 /

	call sub()
	call check(result, expect, NT)
	end
	subroutine sub()
	common m,mm,n,nn
	allocatable ia(:,:)
	allocate (ia(2,2))
	nn = 8
	deallocate (ia)
	allocate (ia(m:mm,n:nn))
	do i = m, mm
	    do j = n, nn
		ia(i,j) = j*i
	    enddo
	enddo
	call pr(ia)
	end
	subroutine pr(ia)
	dimension ia(3,8)
	integer result(3,8)
	common /result/result
	do i = 1, 3
	    do j = 1, 8
		result(i,j) = ia(i,j)
	    enddo
	enddo
	end


!==================================================================================================================================!
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!==================================================================================================================================!
program bigmat
use M_matrix, only  : lala
use M_CLI2, only : set_args, lget, sget, iget, expressions=>unnamed          ! add command-line parser module
implicit none
character(len=:),allocatable :: help_text(:)
character(len=:),allocatable :: version_text(:)
integer                      :: i
logical                      :: echo
logical                      :: markdown
   call setup()
   ! define command arguments,default values and crack command line
   call set_args('lala --markdown F -noecho F',help_text,version_text )
   echo=.not.lget('noecho')
   if(size(expressions).eq.0)then
      call lala(echo=echo)                           ! CALL LALA interactively with default scratch space
   else
      call lala(200000,echo=echo)                    ! CALL LALA to initialize it and set scratch space size
      do i=1,size(expressions)
         call lala(expressions(i))                   ! CALL LALA
      enddo
   endif
   stop
contains
subroutine setup()
help_text=[ CHARACTER(LEN=128) :: &
'NAME',&
'   lala(1f) - interpret matrix expressions using a shell-like interface',&
'',&
'SYNOPSIS',&
'    lala [expression(s)] | [ --help| --version]',&
'',&
'DESCRIPTION',&
'   lala(1) is an interactive computer program that serves as a convenient',&
'   "laboratory" for computations involving matrices. It provides easy',&
'   access to matrix software developed by the LINPACK and EISPACK',&
'   projects. The capabilities range from standard tasks such as solving',&
'   simultaneous linear equations and inverting matrices, through symmetric',&
'   and nonsymmetric eigenvalue problems, to fairly sophisticated matrix',&
'   tools such as the singular value decomposition.',&
'',&
'OPTIONS',&
'    --help         display this help and exit',&
'    --version      output version information and exit',&
'    expression(s)  if expressions are supplied they are evaluated and the',&
'                   program terminates.',&
'',&
'AUTHOR',&
'    This is heavily based on a program from the Department of Computer',&
'    Science, University of New Mexico, by Cleve Moler.',&
'',&
'EXAMPLES',&
'  Sample commands',&
'',&
'    # Example 1: introductory usage:',&
'    lala',&
'    a=<1 2 3;5 4 6;7 8 9>',&
'    b=<5;6;7>',&
'    a*b',&
'    b*a',&
'    det(a)',&
'    quit',&
'',&
'   An explanation of Example 1:',&
'',&
'    // For this session the <> character is the LALA prompt.',&
'     <> A=<1 2 3;5 4 6;7 8 9>            <---  you enter this',&
'     A     =                             <---  LALA response',&
'         1.    2.    3.',&
'         5.    4.    6.',&
'         7.    8.    9.',&
'     <> b=<5;6;7>',&
'     b     =',&
'         5.',&
'         6.',&
'         7.',&
'',&
'     <> A*b             <--- you enter "multiply A and b"',&
'',&
'     ANS   =            <--- LALA response',&
'        38.',&
'        91.',&
'       146.',&
'',&
'     <> b*A             <---you enter "multiply b and A"',&
'        /--ERROR                         <--- LALA response',&
'     INCOMPATIBLE FOR MULTIPLICATION',&
'',&
'     <> det(A)         <--- Take the determinant of A',&
'',&
'     ANS   =           <---LALA response',&
'',&
'        18.',&
'',&
'     <> quit           <--- you quit LALA',&
'',&
'     total flops        34',&
'     ADIOS',&
'    // --------------------------------------',&
'',&
'   Example 2: Simple looping and conditionals are also available',&
'',&
'    lala',&
'    //Eigenvalue sensitivity example. See section 8 of the Users'' Guide.',&
'    B = <3 0 7; 0 2 0; 0 0 1>',&
'    L = <1 0 0; 2 1 0; -3 4 1>,  M = L\L''',&
'    A = M*B/M',&
'    A = round(A)',&
'    <X,D> = eig(A)',&
'    long,  diag(D),  short',&
'    cond(X)',&
'    X = X/diag(X(3,:)),  cond(X)',&
'    Y = inv(X''),  Y''*A*X',&
'    for j = 1:3, c(j) = norm(Y(:,j))*norm(X(:,j));',&
'    C',&
'    E = -1.e-6*Y(:,1)*X(:,1)''',&
'    eig(A + .4*E),  eig(A + .5*E)',&
'    r = .4;  s = .5;',&
'    while s-r > 1.e-14, t = (r+s)/2; d = eig(A+t*E); ...',&
'      if imag(d(1))=0, r = t; else, s = t;',&
'    long,  t = r',&
'    A+t*e,  eig(A+t*E)',&
'    <X,D> = eig(A+t*E);  X = X/diag(X(3,:))',&
'    short,  cond(X)',&
'    // --------------------------------------',&
'',&
'   Use the HELP command for further information.',&
'   For example, to enter HELP on the entire manual,',&
'   display directions for using HELP and',&
'   place a User manual in the file "lala.userguide.txt",',&
'   enter',&
'',&
'    lala',&
'    <>help manual',&
'    continue ...',&
'    h // show directions for using "help"',&
'    w lala.userguide.txt',&
'    continue ...',&
'    q',&
'    quit',&
'']
!>
!!##NAME
!!    lala(1f) - interpret matrix expressions using a shell-like interface
!!
!!##SYNOPSIS
!!
!!     lala [expression(s)] | [ --help| --version]
!!
!!##DESCRIPTION
!!    lala(1) is an interactive computer program that serves as a convenient
!!    "laboratory" for computations involving matrices. It provides easy
!!    access to matrix software developed by the LINPACK and EISPACK
!!    projects. The capabilities range from standard tasks such as solving
!!    simultaneous linear equations and inverting matrices, through symmetric
!!    and nonsymmetric eigenvalue problems, to fairly sophisticated matrix
!!    tools such as the singular value decomposition.
!!
!!##OPTIONS
!!     --help         display this help and exit
!!     --version      output version information and exit
!!     expression(s)  if expressions are supplied they are evaluated and the
!!                    program terminates.
!!
!!##AUTHOR
!!     This is heavily based on a program from the Department of Computer
!!     Science, University of New Mexico, by Cleve Moler.
!!
!!##EXAMPLES
!!
!!   Sample commands
!!
!!     # Example 1: introductory usage:
!!     lala
!!     a=<1 2 3;5 4 6;7 8 9>
!!     b=<5;6;7>
!!     a*b
!!     b*a
!!     det(a)
!!     quit
!!
!!    An explanation of Example 1:
!!
!!     // For this session the <> character is the LALA prompt.
!!      <> A=<1 2 3;5 4 6;7 8 9>            <---  you enter this
!!      A     =                             <---  LALA response
!!          1.    2.    3.
!!          5.    4.    6.
!!          7.    8.    9.
!!      <> b=<5;6;7>
!!      b     =
!!          5.
!!          6.
!!          7.
!!
!!      <> A*b             <--- you enter "multiply A and b"
!!
!!      ANS   =            <--- LALA response
!!         38.
!!         91.
!!        146.
!!
!!      <> b*A             <---you enter "multiply b and A"
!!         /--ERROR                         <--- LALA response
!!      INCOMPATIBLE FOR MULTIPLICATION
!!
!!      <> det(A)         <--- Take the determinant of A
!!
!!      ANS   =           <---LALA response
!!
!!         18.
!!
!!      <> quit           <--- you quit LALA
!!
!!      total flops        34
!!      ADIOS
!!     // --------------------------------------
!!
!!    Example 2: Simple looping and conditionals are also available
!!
!!     lala
!!     //Eigenvalue sensitivity example. See section 8 of the Users' Guide.
!!     B = <3 0 7; 0 2 0; 0 0 1>
!!     L = <1 0 0; 2 1 0; -3 4 1>,  M = L\L'
!!     A = M*B/M
!!     A = round(A)
!!     <X,D> = eig(A)
!!     long,  diag(D),  short
!!     cond(X)
!!     X = X/diag(X(3,:)),  cond(X)
!!     Y = inv(X'),  Y'*A*X
!!     for j = 1:3, c(j) = norm(Y(:,j))*norm(X(:,j));
!!     C
!!     E = -1.e-6*Y(:,1)*X(:,1)'
!!     eig(A + .4*E),  eig(A + .5*E)
!!     r = .4;  s = .5;
!!     while s-r > 1.e-14, t = (r+s)/2; d = eig(A+t*E); ...
!!       if imag(d(1))=0, r = t; else, s = t;
!!     long,  t = r
!!     A+t*e,  eig(A+t*E)
!!     <X,D> = eig(A+t*E);  X = X/diag(X(3,:))
!!     short,  cond(X)
!!     // --------------------------------------
!!
!!    Use the HELP command for further information.
!!    For example, to enter HELP on the entire manual,
!!    display directions for using HELP and
!!    place a User manual in the file "lala.userguide.txt",
!!    enter
!!
!!     lala
!!     <>help manual
!!     continue ...
!!     h // show directions for using "help"
!!     w lala.userguide.txt
!!     continue ...
!!     q
!!     quit
version_text=[ CHARACTER(LEN=128) :: &
'PRODUCT:        GPF (General Purpose Fortran) utilities and examples',&
'PROGRAM:        lala(1)',&
'DESCRIPTION:    interpret matrix operations using a shell-like interface',&
'VERSION:        1.0, 19910403',&
'AUTHOR:         John S. Urban; heavily based on the original by Cleve Moler',&
'HOME PAGE:      http://www.urbanjost.altervista.org/index.html',&
'']
end subroutine setup
end program bigmat
!==================================================================================================================================!
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!==================================================================================================================================!


module problem_tagging_module

  use amrex_fort_module, only : rt => amrex_real
  implicit none

  public

contains

  subroutine set_problem_tags(lo, hi, tag,tagl1,tagl2,tagh1,tagh2, &
                              state,state_l1,state_l2,state_h1,state_h2,&
                              set,clear,&
                              dx,problo,time,level) bind(C, name="set_problem_tags")

    use meth_params_module, only: URHO, NVAR, UFS
    use probdata_module, only: H_min, cutoff_density

    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer         ,intent(in   ) :: lo(2),hi(2)
    integer         ,intent(in   ) :: state_l1,state_l2,state_h1,state_h2
    integer         ,intent(in   ) :: tagl1,tagl2,tagh1,tagh2
    real(rt)        ,intent(in   ) :: state(state_l1:state_h1,state_l2:state_h2, NVAR)
    integer         ,intent(inout) :: tag(tagl1:tagh1,tagl2:tagh2)
    real(rt)        ,intent(in   ) :: problo(2),dx(2),time
    integer         ,intent(in   ) :: level,set,clear

    integer :: i, j

    ! Tag on regions of with H > H_min and rho < cutoff_density.
    ! Note that H is the first species variable and so is in index UFS of the state array.

    do j = lo(2), hi(2)
       do i = lo(1), hi(1)
          if ( state(i,j,URHO) > cutoff_density .and. state(i,j,UFS) > H_min) then
             tag(i,j) = set
          endif
       enddo
    enddo

  end subroutine set_problem_tags

end module problem_tagging_module


      SUBROUTINE TRCO32(CO3,CN,NBNN,XL )
      IMPLICIT REAL*8 (A-H,O-Z)
CC    CALCUL DES COORDONNEES DES NOEUDS D'UNE FACE DANS LE PLAN
CC    DE CETTE FACE
CC    ON PREND LE NOEUD 1 COMME ORIGINE
CC             LE VECTEUR 12 (NORMALISE) COMME AXE DES X
CE    CO3 : COORDONNEES DANS LE REPERE 3D
CE    CN : NORMALE A LA FACE
CE    NBNN : NOMBRE DE NOEUDS DE LA FACE
CS    XL  : COORDONNEES DANS LE REPERE 2D (LA FACE)
C
C     OPERATIONS : 1 RACINE, 3 **, 3 /, 12 OU 18 *
C
      DIMENSION CO3(8,3),CN(3),XL(8,3)
C
C     VECTEUR 12
      X12 = CO3(2,1) - CO3(1,1)
      Y12 = CO3(2,2) - CO3(1,2)
      Z12 = CO3(2,3) - CO3(1,3)
C     LONGUEUR 12
      XM = DSQRT(X12**2 + Y12**2 + Z12**2)
C     AXE X
      XCX = X12/XM
      XCY = Y12/XM
      XCZ = Z12/XM
C     AXE Y (X VECT CN)
      YCX = XCY*CN(3) - XCZ*CN(2)
      YCY = XCZ*CN(1) - XCX*CN(3)
      YCZ = XCX*CN(2) - XCY*CN(1)
C     PREMIER NOEUD (ORIGINE)
      XL (1,1) = 0.
      XL (1,2) = 0.
C     DEUXIEME NOEUD (12 DANS (X,Y))
      XL (2,1) = XM
      XL (2,2) = 0.
C     TROISIEME NOEUD (13 SCAL X , 13 SCAL Y)
      XL (3,1) = (CO3(3,1) - CO3(1,1))*XCX
     1         + (CO3(3,2) - CO3(1,2))*XCY
     2         + (CO3(3,3) - CO3(1,3))*XCZ
      XL (3,2) = (CO3(3,1) - CO3(1,1))*YCX
     1         + (CO3(3,2) - CO3(1,2))*YCY
     2         + (CO3(3,3) - CO3(1,3))*YCZ
      IF (NBNN.EQ.3)                           RETURN
C     QUATRIEME NOEUD (14 SCAL X , 14 SCAL Y)
      XL (4,1) = (CO3(4,1) - CO3(1,1))*XCX
     1         + (CO3(4,2) - CO3(1,2))*XCY
     2         + (CO3(4,3) - CO3(1,3))*XCZ
      XL (4,2) = (CO3(4,1) - CO3(1,1))*YCX
     1         + (CO3(4,2) - CO3(1,2))*YCY
     2         + (CO3(4,3) - CO3(1,3))*YCZ
                                               RETURN
      END


!----------------------------------------------------------------------------- best with 100 columns

!> polyhedron and polygon finite element grid module
module modPolyFeGrid
  use modPolyGrid
  private

  ! constants
  integer,parameter::DIMS=3 !< dimensions

  !> polyhedron and polygon finite volume grid type
  type,extends(polyGrid),public::polyFeGrid
    double precision,allocatable::invJ(:,:,:,:) !< inverse mapping Jacobian at quadrature points
    double precision,allocatable::detJ(:,:) !< determinant of mapping Jacobian at quadrature points
  contains
    procedure,public::clear=>clearPolyFeGrid
    procedure,public::up=>upPolyFeGrid
    final::purgePolyFeGrid
  end type

contains

  !> clear this polyFeGrid
  elemental subroutine clearPolyFeGrid(this)
    class(polyFeGrid),intent(inout)::this !< this polyFeGrid

    call this%polyGrid%clear()
    if(allocated(this%invJ)) deallocate(this%invJ)
    if(allocated(this%detJ)) deallocate(this%detJ)
  end subroutine

  !> update this polyFeGrid
  subroutine upPolyFeGrid(this)
    use modSMQ
    class(polyFeGrid),intent(inout)::this !< this polyFeGrid
    double precision,allocatable::invJ(:,:,:,:)
    double precision,allocatable::detJ(:,:)
    double precision::Jacobian(DIMS,DIMS)
    integer,parameter::MAX_QP_PER_E=11 !< maximum 11 quadrature points per element
    integer::nQp

    if(.not.this%isUp)then
      call initSMQ()
      call this%polyGrid%up()
      allocate(invJ(DIMS,DIMS,MAX_QP_PER_E,this%nE))
      allocate(detJ(MAX_QP_PER_E,this%nE))
      nQp=0
      do i=1,this%nE
        select case(this%sE(i))
        case(TET)
          n=size(TET_QW)
          nQp=max(n,nQp)
          do j=1,n
            Jacobian=mapJTet(this%pN(:,this%iNE(1:this%nNE(i),i)),TET_QP(:,j))
            call findInvDet3by3(Jacobian,invJ(:,:,j,i),detJ(j,i))
          end do
        case(TET10)
          n=size(TET10_QW)
          nQp=max(n,nQp)
          do j=1,n
            Jacobian=mapJTet10(this%pN(:,this%iNE(1:this%nNE(i),i)),TET10_QP(:,j))
            call findInvDet3by3(Jacobian,invJ(:,:,j,i),detJ(j,i))
          end do
        case(TRI)
          n=size(TRI_QW)
          nQp=max(n,nQp)
          do j=1,n
            Jacobian(1:2,:)=mapJTri(this%pN(:,this%iNE(1:this%nNE(i),i)),TRI_QP(:,j))
            ! save d(xi)/d(xx1) cross d(xi)/d(yy1) at the 3rd row
            Jacobian(3,1)=Jacobian(1,2)*Jacobian(2,3)-Jacobian(1,3)*Jacobian(2,2)
            Jacobian(3,2)=Jacobian(1,3)*Jacobian(2,1)-Jacobian(1,1)*Jacobian(2,3)
            Jacobian(3,3)=Jacobian(1,1)*Jacobian(2,2)-Jacobian(1,2)*Jacobian(2,1)
            invJ(:,:,j,i)=0d0 ! Jacobian is non-square
            detJ(j,i)=norm2(Jacobian(3,:)) ! magnitude of d(xi)/d(xx1) cross d(xi)/d(yy1)
          end do
        case(TRI6)
          n=size(TRI6_QW)
          nQp=max(n,nQp)
          do j=1,n
            Jacobian(1:2,:)=mapJTri6(this%pN(:,this%iNE(1:this%nNE(i),i)),TRI6_QP(:,j))
            ! save d(xi)/d(xx1) cross d(xi)/d(yy1) at the 3rd row
            Jacobian(3,1)=Jacobian(1,2)*Jacobian(2,3)-Jacobian(1,3)*Jacobian(2,2)
            Jacobian(3,2)=Jacobian(1,3)*Jacobian(2,1)-Jacobian(1,1)*Jacobian(2,3)
            Jacobian(3,3)=Jacobian(1,1)*Jacobian(2,2)-Jacobian(1,2)*Jacobian(2,1)
            invJ(:,:,j,i)=0d0 ! Jacobian is non-square
            detJ(j,i)=norm2(Jacobian(3,:)) ! magnitude of d(xi)/d(xx1) cross d(xi)/d(yy1)
          end do
        case default
        end select
      end do
      if(allocated(this%invJ)) deallocate(this%invJ)
      if(allocated(this%detJ)) deallocate(this%detJ)
      allocate(this%invJ,source=invJ(:,:,1:nQp,:))
      allocate(this%detJ,source=detJ(1:nQp,:))
      deallocate(invJ)
      deallocate(detJ)
    end if
  contains

    !> find inverse and determinant of 3 by 3 matrix
    subroutine findInvDet3by3(A,invA,detA)
      double precision,intent(in)::A(3,3) !< 3 by 3 matrix
      double precision,intent(inout)::invA(3,3) !< inverse of A
      double precision,intent(inout)::detA !< determinant of A

      detA=A(1,1)*A(2,2)*A(3,3)-A(1,1)*A(2,3)*A(3,2)-A(1,2)*A(2,1)*A(3,3)&
      &    +A(1,2)*A(2,3)*A(3,1)+A(1,3)*A(2,1)*A(3,2)-A(1,3)*A(2,2)*A(3,1)
      invA(1,1)=(A(2,2)*A(3,3)-A(2,3)*A(3,2))
      invA(2,1)=-(A(2,1)*A(3,3)-A(2,3)*A(3,1))
      invA(3,1)=(A(2,1)*A(3,2)-A(2,2)*A(3,1))
      invA(1,2)=-(A(1,2)*A(3,3)-A(1,3)*A(3,2))
      invA(2,2)=(A(1,1)*A(3,3)-A(1,3)*A(3,1))
      invA(3,2)=-(A(1,1)*A(3,2)-A(1,2)*A(3,1))
      invA(1,3)=(A(1,2)*A(2,3)-A(1,3)*A(2,2))
      invA(2,3)=-(A(1,1)*A(2,3)-A(1,3)*A(2,1))
      invA(3,3)=(A(1,1)*A(2,2)-A(1,2)*A(2,1))
      invA(:,:)=invA(:,:)/detA
    end subroutine

  end subroutine

  !> destructor of polyFeGrid
  elemental subroutine purgePolyFeGrid(this)
    type(polyFeGrid),intent(inout)::this !< this polyFeGrid

    call this%clear()
  end subroutine

end module


program main
use io, only: stdout
use test, only: test_value
use tri_disloc
implicit none
double precision :: disp(3), strain(3,3), tri_coord(3,4), sta_coord(3), slip(3)
double precision :: origin(3), normal(3), pointOfInterest(3), depthOfPlaneAtPoint
double precision :: p1(3), p2(3), p3(3), p4(3), p5(3), p6(3),center(3)
double precision :: strike(3), updip(3)

y1=1.0d0
y2=2.0d0
y3=3.0d0
a=4.0d0
b=0.32d0
nu=0.25d0
B1=0.1d0
B2=0.2d0
B3=0.3d0

call angular_disloc_vars()
call test_value(sinb,0.31456656061611776d0,'angular_disloc_vars(): sinb')
call test_value(cosb,0.94923541808244083d0,'angular_disloc_vars(): cosb')
call test_value(cotb,3.0175979806093984d0,'angular_disloc_vars(): cotb')
call test_value(z1,5.5357362340875405d-003,'angular_disloc_vars(): z1')
call test_value(z3,3.1622728148634400d0,'angular_disloc_vars(): z3')
call test_value(y3bar,11.000000000000000d0,'angular_disloc_vars(): y3bar')
call test_value(z1bar,4.4094675848597360d0,'angular_disloc_vars(): z1bar')
call test_value(z3bar,10.127023038290732d0,'angular_disloc_vars(): z3bar')
call test_value(R,3.7416573867739413d0,'angular_disloc_vars(): R')
call test_value(R2,14.000000000000000d0,'angular_disloc_vars(): R2')
call test_value(R3,52.383203414835180d0,'angular_disloc_vars(): R3')
call test_value(R5,733.36484780769251d0,'angular_disloc_vars(): R5')
call test_value(Rbar,11.224972160321824d0,'angular_disloc_vars(): Rbar')
call test_value(R2bar,126.00000000000000d0,'angular_disloc_vars(): R2bar')
call test_value(R3bar,1414.3464922005498d0,'angular_disloc_vars(): R3bar')
call test_value(R4bar,15876.000000000000d0,'angular_disloc_vars(): R4bar')
call test_value(R5bar,178207.65801726928d0,'angular_disloc_vars(): R5bar')
call test_value(F,1.0152035956202865d0,'angular_disloc_vars(): F')
call test_value(Fbar,2.9255063385751567d-002,'angular_disloc_vars(): Fbar')
write(stdout,*) 'subroutine angular_disloc_vars() passed unit test'
write(stdout,*)

pointOfInterest(1) = 7.5d0
pointOfInterest(2) = 3.6d0
pointOfInterest(3) = 3.2d0
origin(1) =  1.5d0
origin(2) = -2.7d0
origin(3) =  3.2d0
normal(1) =  0.6d0
normal(2) = -0.69282032d0
normal(3) = -0.4d0
call verticalLinePlaneIntersect(depthOfPlaneAtPoint,pointOfInterest,origin,normal)
call test_value(depthOfPlaneAtPoint,1.28807996d0,'verticalLinePlaneIntersect()')
write(stdout,*) 'subroutine verticalLinePlaneIntersect() passed unit test'
write(stdout,*)

call test_value(v1B1(),0.035526830150259d0,'v1B1()')
call test_value(v2B1(),0.007506783445002d0,'v2B1()')
call test_value(v3B1(),0.003462691554128d0,'v3B1()')
call test_value(v1B2(),0.010574942146227d0,'v1B2()')
call test_value(v2B2(),0.120415543165994d0,'v2B2()')
call test_value(v3B2(),-0.001863937837612d0,'v3B2()')
call test_value(v1B3(),0.003083428958074d0,'v1B3()')
call test_value(v2B3(),-0.074712144051146d0,'v2B3()')
call test_value(v3B3(),0.099928400921349d0,'v3B3()')
write(stdout,*) 'functions viBj() for displacements passed unit tests'
write(stdout,*)

call ang_disloc_disp(disp,y1,y2,y3,a,b,nu,B1,B2,B3)
call test_value(disp(1),0.006592700131694d0,'ang_disloc_disp(): disp(1)')
call test_value(disp(2),0.002420143762355d0,'ang_disloc_disp(): disp(2)')
call test_value(disp(3),0.029952001864295d0,'ang_disloc_disp(): disp(3)')
write(stdout,*) 'subroutine ang_disloc_disp() passed unit test'
write(stdout,*)

call test_value(e11_termB1a(),0.008400368790923d0,'e11_termB1a()')
call test_value(e11_termB1b(),5.858996497052338d-06,'e11_termB1b()')
call test_value(e11_termB2a(),0.021993745473790d0,'e11_termB2a()')
call test_value(e11_termB2b(),6.367379316451323d-05,'e11_termB2b()')
call test_value(e11_termB3a(),(-0.014208301891610d0),'e11_termB3a()')
call test_value(e11_termB3b(),1.690248925356104d-04,'e11_termB3b()')
call test_value(e22_termB1a(),(-0.020631844330829d0),'e22_termB1a()')
call test_value(e22_termB1b(),6.527964013639348d-06,'e22_termB1b()')
call test_value(e22_termB2a(),(-0.041802214117666d0),'e22_termB2a()')
call test_value(e22_termB2b(),3.614748844589103d-04,'e22_termB2b()')
call test_value(e22_termB3a(),0.009510531315538d0,'e22_termB3a()')
call test_value(e22_termB3b(),5.062474014402907d-04,'e22_termB3b()')
call test_value(e33_termB1a(),0.004012383803250d0,'e33_termB1a()')
call test_value(e33_termB1b(),(-5.173267965506375d-05),'e33_termB1b()')
call test_value(e33_termB2a(),(0.001589791985872d0),'e33_termB2a()')
call test_value(e33_termB2b(),(-0.001669794447960d0),'e33_termB2b()')
call test_value(e33_termB3a(),0.020233119241681d0,'e33_termB3a()')
call test_value(e33_termB3b(),(-0.001419832184834d0),'e33_termB3b()')
call test_value(e12_termB1a(),(-0.008579559459718d0),'e12_termB1a()')
call test_value(e12_termB1b(),0.023064656529654d0,'e12_termB1b()')
call test_value(e12_termB2a(),(-0.006203119918170d0),'e12_termB2a()')
call test_value(e12_termB2b(),(-0.018531757523155d0),'e12_termB2b()')
call test_value(e12_termB3a(),6.131170880527790d-04,'e12_termB3a()')
call test_value(e12_termB3b(),(-5.409727323827170d-04),'e12_termB3b()')
call test_value(e13_termB1a(),0.004475322868068d0,'e13_termB1a()')
call test_value(e13_termB1b(),(-0.007189035380886d0),'e13_termB1b()')
call test_value(e13_termB2a(),1.032714122351998d-04,'e13_termB2a()')
call test_value(e13_termB2b(),2.438873637085293d-04,'e13_termB2b()')
call test_value(e13_termB3a(),0.001970489774467d0,'e13_termB3a()')
call test_value(e13_termB3b(),(-0.004134810449308d0),'e13_termB3b()')
call test_value(e23_termB1a(),(-5.876101709989005d-04),'e23_termB1a()')
call test_value(e23_termB1b(),7.070956009099477d-04,'e23_termB1b()')
call test_value(e23_termB2a(),0.020210757289498d0,'e23_termB2a()')
call test_value(e23_termB2b(),(-0.003151829718226d0),'e23_termB2b()')
call test_value(e23_termB3a(),(-0.002693279090971d0),'e23_termB3a()')
call test_value(e23_termB3b(),(-0.010174116926604d0),'e23_termB3b()')
write(stdout,*) 'functions eij_termBk() for strains passed unit tests'
write(stdout,*)

call ang_disloc_strain(strain,y1,y2,y3,a,b,nu,B1,B2,B3)
call test_value(strain(1,1),1.0403235324105481d-3,'ang_disloc_strain(): strain(1,1)')
call test_value(strain(1,2),-3.4768224745703653d-3,'ang_disloc_strain(): strain(1,2)')
call test_value(strain(1,3),-8.5123569854524128d-4,'ang_disloc_strain(): strain(1,3)')
call test_value(strain(2,1),-3.4768224745703653d-3,'ang_disloc_strain(): strain(2,1)')
call test_value(strain(2,2),-7.3456458682292997d-3,'ang_disloc_strain(): strain(2,2)')
call test_value(strain(2,3),-4.3648474802720008d-4,'ang_disloc_strain(): strain(2,3)')
call test_value(strain(3,1),-8.5123569854524128d-4,'ang_disloc_strain(): strain(3,1)')
call test_value(strain(3,2),-4.3648474802720008d-4,'ang_disloc_strain(): strain(3,2)')
call test_value(strain(3,3),6.0240507369960488d-3,'ang_disloc_strain(): strain(3,3)')
write(stdout,*) 'subroutine ang_disloc_strain() passed unit test'
write(stdout,*)

! Example in Meade (2007), Figure 7
tri_coord(1,1) = 20.0d0
tri_coord(2,1) = 50.0d0
tri_coord(3,1) = 5.0d0
tri_coord(1,2) = 80.0d0
tri_coord(2,2) = 80.0d0
tri_coord(3,2) = 0.0d0
tri_coord(1,3) = 50.0d0
tri_coord(2,3) = 30.0d0
tri_coord(3,3) = 20.0d0
tri_coord(:,4) = 0.0d0
sta_coord(1) = 1.0d0
sta_coord(2) = 2.0d0
sta_coord(3) = 3.0d0
slip(1) = -0.8d0
slip(2) = 0.2d0
slip(3) = 0.6d0
call tri_disloc_disp(disp,sta_coord,tri_coord,nu, slip)
call test_value(disp(1),0.018484710048163d0,'tri_disloc_disp(): disp(1)')
call test_value(disp(2),0.024890597153371d0,'tri_disloc_disp(): disp(2)')
call test_value(disp(3),-1.195473671420089d-4,'tri_disloc_disp(): disp(3)')
write(stdout,*) 'subroutine tri_disloc_strain() passed unit test'
write(stdout,*)

call tri_disloc_strain(strain,sta_coord,tri_coord,nu, slip)
call test_value(strain(1,1),4.466731272802531d-4,'tri_disloc_strain(): strain(1,1)')
call test_value(strain(2,2),3.342701850596506d-4,'tri_disloc_strain(): strain(2,2)')
call test_value(strain(3,3),-2.531425586976375d-4,'tri_disloc_strain(): strain(3,3)')
call test_value(strain(1,2),7.153107700399887d-4,'tri_disloc_strain(): strain(1,2)')
call test_value(strain(1,3),-9.831385046414070d-5,'tri_disloc_strain(): strain(1,3)')
call test_value(strain(2,3),-9.961453222958287d-5,'tri_disloc_strain(): strain(2,3)')
write(stdout,*) 'subroutine tri_disloc_strain() passed unit test'
write(stdout,*)

sta_coord(1) = 51.0d0
sta_coord(2) = 52.0d0
sta_coord(3) = 45.0d0
call tri_disloc_disp(disp,sta_coord,tri_coord,nu, slip)
call test_value(disp(1),-0.005500148465194d0,'tri_disloc_disp(): disp(1)')
call test_value(disp(2),-0.009000676865995d0,'tri_disloc_disp(): disp(2)')
call test_value(disp(3),-0.022649202364603d0,'tri_disloc_disp(): disp(3)')
write(stdout,*) 'subroutine tri_disloc_strain() passed unit test'
write(stdout,*)

call tri_disloc_strain(strain,sta_coord,tri_coord,nu, slip)
call test_value(strain(1,1),-3.930417208817573d-4,'tri_disloc_strain(): strain(1,1)')
call test_value(strain(2,2),-6.756624218076405d-4,'tri_disloc_strain(): strain(2,2)')
call test_value(strain(3,3),0.001610270039414d0,'tri_disloc_strain(): strain(3,3)')
call test_value(strain(1,2),-1.833690817949515d-4,'tri_disloc_strain(): strain(1,2)')
call test_value(strain(1,3),-2.461216982562142d-4,'tri_disloc_strain(): strain(1,3)')
call test_value(strain(2,3),1.335040694307682d-4,'tri_disloc_strain(): strain(2,3)')
write(stdout,*) 'subroutine tri_disloc_strain() passed unit test'
write(stdout,*)

p1(1) =  -4.4600515603497746d0
p1(2) =  -8.6569884424234189d-2
p1(3) =   5.0199612757737722d0
p2(1) =  -9.5108247453189811d0
p2(2) =  -8.4314941422125749d0
p2(3) =  -8.1220467753405305d0
p3(1) =  -7.2401514824260911d0
p3(2) =  -5.2259626871753104d0
p3(3) =   7.2451208789322159d0
call tri_center(center,p1,p2,p3)
call test_value(center(1),-7.0703425960316153d0,'tri_center(): center(1)')
call test_value(center(2),-4.5813422379373732d0,'tri_center(): center(2)')
call test_value(center(3), 1.3810117931218191d0,'tri_center(): center(3)')
write(stdout,*) 'subroutine tri_center() passed unit test'
write(stdout,*)

call tri_geometry(normal,strike,updip,p1,p2,p3)
call test_value(normal(1), 0.87409206677578921d0,'tri_geometry(): normal(1)')
call test_value(normal(2),-0.48495276544177424d0,'tri_geometry(): normal(2)')
call test_value(normal(3), 2.7997751516951008d-2,'tri_geometry(): normal(3)')
call test_value(strike(1), 0.48514294821244353d0,'tri_geometry(): strike(1)')
call test_value(strike(2), 0.87443485737917515d0,'tri_geometry(): strike(2)')
call test_value(strike(3),                   0d0,'tri_geometry(): strike(3)')
call test_value(updip(1),-2.4482209854662641d-2,'tri_geometry(): updip(1)')
call test_value(updip(2), 1.3582911714253024d-2,'tri_geometry(): updip(2)')
call test_value(updip(3), 0.99960798611755564d0,'tri_geometry(): updip(3)')
write(stdout,*) 'subroutine tri_geometry() passed unit test'
write(stdout,*)

call tri_geo2cart(p4,p5,p6,p1,p2,p3,'km')
call test_value(p4(1), 290.54853475303207d0,'tri_geo2cart(): point1(1)')
call test_value(p4(2), 499.43977645236936d0,'tri_geo2cart(): point1(2)')
call test_value(p4(3), 5.0199612757737722d0,'tri_geo2cart(): point1(3)')
call test_value(p5(1),-268.63732246707610d0,'tri_geo2cart(): point2(1)')
call test_value(p5(2),-428.70221439679267d0,'tri_geo2cart(): point2(2)')
call test_value(p5(3),-8.1220467753405305d0,'tri_geo2cart(): point2(3)')
call test_value(p6(1),-18.803795453256310d0,'tri_geo2cart(): point3(1)')
call test_value(p6(2),-71.680853403417458d0,'tri_geo2cart(): point3(2)')
call test_value(p6(3), 7.2451208789322159d0,'tri_geo2cart(): point3(3)')
write(stdout,*) 'subroutine tri_geo2cart() passed unit test'
write(stdout,*)

write(stdout,*) 'tri_disloc unit test passed'
end

! subroutine test_value(value,string)
! implicit none
! double precision :: value
! character(len=*) :: string
! if (dabs(value).gt.1.0d-10) then
!     write(0,*) 'tri_disloc unit test failed for '//trim(string)
!     stop
! else
!     write(0,*) 'tri_disloc unit test passed for '//trim(string)
! endif
! return
! end


C=======================================================================
C  ML_NFACT, Subroutine
C
C  Determines N deficiency factor for Pearl Millet
C-----------------------------------------------------------------------
C  Revision history
C
C  1. Written
C  2  Modified by
C  3. Header revision and minor changes             P.W.W.      2-8-93
C  4. Modified                                      W.T.B.     June 94
C  5. Converted to modular format                   W.D.B.     7-31-02
C-----------------------------------------------------------------------
C  INPUT  : None
C
C  LOCAL  :
C
C  OUTPUT :
C-----------------------------------------------------------------------
C  Called : ML_GROSUB
C
C  Calls  : None
C-----------------------------------------------------------------------
C                         DEFINITIONS
C
C         :
C=======================================================================

      SUBROUTINE ML_NFACT (
     & AGEFAC, CNSD1, CNSD2, ISTAGE, NDEF3, NFAC,
     & NSTRES, RANC, RCNP, TANC, TCNP, TMNC, XSTAGE)

      IMPLICIT  NONE
      SAVE

      REAL AGEFAC
      REAL CNSD1
      REAL CNSD2
      INTEGER ISTAGE
      REAL NDEF3
      REAL NFAC
      REAL NSTRES
      REAL RANC
      REAL RCNP
      REAL TANC
      REAL TCNP
      REAL TMNC
      REAL XSTAGE

      TCNP = 8.276 - 1.485*XSTAGE+0.0711*XSTAGE*XSTAGE
      TCNP = AMIN1 (TCNP,5.0)
      !
      ! TMNC as calculated in Version 2.1 ... WTB 8-1-94
      !
      TMNC = 1.2 - 0.05 * XSTAGE
      IF (XSTAGE .LT. 5.0) THEN
         TMNC = 2.0 - 0.28 * XSTAGE
      ENDIF

      IF (XSTAGE .GE. 8.0) THEN
         TMNC = TCNP * 0.65
      ENDIF
      TMNC = TMNC*0.01
      TCNP = TCNP*0.01
      RCNP = 2.5 - 0.125*XSTAGE
      RCNP = RCNP*0.01
      IF (XSTAGE .LT. 0.2) THEN
         TANC = TCNP
         RANC = RCNP
      ENDIF
      NFAC = 1.0 - (TCNP-TANC)/(TCNP-TMNC)
      NFAC = AMIN1 (NFAC,1.0)
      IF (ISTAGE .EQ. 3 .OR. ISTAGE .EQ. 4) THEN
         NFAC = 1.0 - 2.0*EXP(-3.5*NFAC)
      ENDIF
      NFAC   = AMIN1 (NFAC,1.0)
      NFAC   = AMAX1 (NFAC,0.001)
      NSTRES = 1.0
      AGEFAC = 1.0
      NDEF3  = 1.0
      AGEFAC = NFAC
      NSTRES = NFAC * 1.2 + 0.2
      IF (NFAC .LT. 0.3) THEN
         NDEF3 = 2.33*NFAC + 0.3
      ENDIF
      NSTRES = AMIN1 (NSTRES,1.0)
      AGEFAC = AMIN1 (AGEFAC,1.0)
      NDEF3  = AMIN1 (NDEF3, 1.0)
      CNSD1  = CNSD1 + 1.0 - NSTRES
      CNSD2  = CNSD2 + 1.0 - AGEFAC

      RETURN
      END SUBROUTINE ML_NFACT


      subroutine cinit (cc)
c-----------------------------------------------------------------------
c This routine computes and loads the vector of initial values.
c-----------------------------------------------------------------------
      double precision cc
      dimension cc(*)
      integer ns, mx, my, mxns
      integer i, ici, ioff, iyoff, jx, jy
      double precision ax,ay,acoef,bcoef,dx,dy,alph,diff,cox,coy
      double precision argx, argy, x, y
      common /pcom1/ ax, ay, acoef(20,20), bcoef(20), dx, dy, alph,
     1               diff(20), cox(20), coy(20), ns, mx, my, mxns
c
        do 20 jy = 1,my
          y = (jy-1)*dy
          argy = 16.0d0*y*y*(ay-y)*(ay-y)
          iyoff = mxns*(jy-1)
          do 10 jx = 1,mx
            x = (jx-1)*dx
            argx = 16.0d0*x*x*(ax-x)*(ax-x)
            ioff = iyoff + ns*(jx-1)
            do 5 i = 1,ns
              ici = ioff + i
              cc(ici) = 10.0d0 + i*argx*argy
  5           continue
 10         continue
 20       continue
      return
c------------  end of subroutine cinit  --------------------------------
      end


!==============================================================================!
  real function Field_Mod_Prandtl_Number(flow, c)
!------------------------------------------------------------------------------!
!   Computes laminar Prandtl number for cell "c"                               !
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Field_Type), target :: flow
  integer                  :: c
!==============================================================================!

  Field_Mod_Prandtl_Number = flow % viscosity(c) * flow % capacity(c)  &
                           / flow % conductivity(c)

  end function