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

C $Id: shapef.f,v 1.3 2007/10/17 18:43:50 gdsjaar Exp $
      SUBROUTINE SHAPEF (ITYPE,SP,TP,RP,SOLN,BVALUE)
C
C     ******************************************************************
C
C     SUBROUTINE TO EVALUATE THE SOLUTION AT A POINT (SP,TP,RP)
C     WITHIN AN ELEMENT
C
C     Called by INTRPE & INTRPN
C
C     ******************************************************************
C
C  SP     INT  The KSI isoparametric coord of the point in the element
C  TP     INT  The ETA isoparametric coord of the point in the element
C  RP     INT  The PHI isoparametric coord of the point in the element
C  SOLN   REAL The variables at the nodes of the element
C  BVALUE REAL The value of the variable at the point inside the element
C
C     ******************************************************************
C
      DIMENSION SOLN(*)
C
C     ******************************************************************
C
C     SELECT TYPE OF ELEMENT
C
      GO TO (10, 20, 30, 40, 50, 60, 70, 80, 90, 100, 110, 120), ITYPE
C
C     3-NODE TRIANGLE
C
   10 CONTINUE
      PP=1.-SP-TP
      BVALUE=SOLN(1)*SP+SOLN(2)*TP+SOLN(3)*PP
      RETURN
C
C     6-NODE TRIANGLE
C
   20 CONTINUE
      PP=1.-SP-TP
      BVALUE=SOLN(1)*SP*(2.*SP-1.)+SOLN(2)*TP*(2.*TP-1.)+
     1       SOLN(3)*PP*(2.*PP-1.)+SOLN(4)*4.*SP*TP+
     2       SOLN(5)*4.*TP*PP+SOLN(6)*4.*SP*PP
      RETURN
C
C     4-NODE QUADRILATERAL
C
   30 CONTINUE
      BVALUE=.25*(SOLN(1)*(1.-SP)*(1.-TP)+SOLN(2)*(1.+SP)*(1.-TP)+
     1            SOLN(3)*(1.+SP)*(1.+TP)+SOLN(4)*(1.-SP)*(1.+TP))
      RETURN
C
C     8-NODE QUADRILATERAL
C
   40 CONTINUE
      BVALUE=.25*(SOLN(1)*(1.-SP)*(1.-TP)*(-SP-TP-1.)+
     1            SOLN(2)*(1.+SP)*(1.-TP)*(SP-TP-1.)+
     2            SOLN(3)*(1.+SP)*(1.+TP)*(SP+TP-1.)+
     3            SOLN(4)*(1.-SP)*(1.+TP)*(-SP+TP-1.))+
     4       .50*(SOLN(5)*(1.-SP*SP)*(1.-TP)+
     5            SOLN(6)*(1.+SP)*(1.-TP*TP)+
     6            SOLN(7)*(1.-SP*SP)*(1.+TP)+
     7            SOLN(8)*(1.-SP)*(1.-TP*TP))
      RETURN
C
C     9-NODE QUADRILATERAL
C
   50 CONTINUE
      BVALUE=.25*(SOLN(1)*(1.-SP)*(1.-TP)*(SP*TP)+
     1            SOLN(2)*(1.+SP)*(1.-TP)*(-SP*TP)+
     2            SOLN(3)*(1.+SP)*(1.+TP)*(SP*TP)+
     3            SOLN(4)*(1.-SP)*(1.+TP)*(-SP*TP))+
     4       .50*(SOLN(5)*(1.-SP*SP)*(1.-TP)*(-TP)+
     5            SOLN(6)*(1.+SP)*(1.-TP*TP)*SP+
     6            SOLN(7)*(1.-SP*SP)*(1.+TP)*TP+
     7            SOLN(8)*(1.-SP)*(1.-TP*TP)*(-SP))+
     8            SOLN(9)*(1.-SP*SP)*(1.-TP*TP)
      RETURN
C
C     4-NODE TETRAHEDRON
C
   60 CONTINUE
      PP=1.-SP-TP-RP
C      BVALUE=SOLN(1)*SP+SOLN(2)*TP+SOLN(3)*RP+SOLN(4)*PP
C fix gww 8/24/00 - probably same fix for 10-node tet but not done yet
C     merlin had opposite nodal order (left hand rule for + volume)
C
      BVALUE=SOLN(1)*SP+SOLN(2)*TP+SOLN(3)*PP+SOLN(4)*RP
      RETURN
C
C     10-NODE TETRAHEDRON
C
   70 CONTINUE
      PP=1.-SP-TP-RP
      BVALUE=  SOLN(1)*SP*(2.*SP-1.)+SOLN(2)*TP*(2.*TP-1.)+
     1         SOLN(3)*RP*(2.*RP-1.)+SOLN(4)*PP*(2.*PP-1.)+
     2     4.*(SOLN(5)*SP*TP+SOLN(6)*TP*RP+SOLN(7)*RP*SP+
     3         SOLN(8)*SP*PP+SOLN(9)*TP*PP+SOLN(10)*RP*PP)
      RETURN
C
C     6-NODE PRISM
C
   80 CONTINUE
      PP=1.-SP-TP
      BVALUE=(SOLN(1)*SP+SOLN(2)*TP+SOLN(3)*PP)*.5*(1.-RP)+
     1       (SOLN(4)*SP+SOLN(5)*TP+SOLN(6)*PP)*.5*(1.+RP)
      RETURN
C
C     15-NODE PRISM
C
   90 CONTINUE
      PP=1.-SP-TP
      AA=1.-RP
      BB=1.+RP
      CC=1.-RP**2
      BVALUE=.5*(SOLN(1)*SP*((2.*SP-1.)*AA-CC)+
     1           SOLN(2)*TP*((2.*TP-1.)*AA-CC)+
     2           SOLN(3)*PP*((2.*PP-1.)*AA-CC)+
     3           SOLN(4)*SP*((2.*SP-1.)*BB-CC)+
     4           SOLN(5)*TP*((2.*TP-1.)*BB-CC)+
     5           SOLN(6)*PP*((2.*PP-1.)*BB-CC))+
     6    2.*AA*(SOLN(7)*SP*TP+SOLN(8)*TP*PP+SOLN(9)*PP*SP)+
     7          (SOLN(10)*SP+SOLN(11)*TP+SOLN(12)*PP)*CC+
     8    2.*BB*(SOLN(13)*SP*TP+SOLN(14)*TP*PP+SOLN(15)*PP*SP)
      RETURN
C
C     8-NODE HEX
C
  100 CONTINUE
      BVALUE=.125*(SOLN(1)*(1.-SP)*(1.-TP)*(1.-RP)+
     1             SOLN(2)*(1.+SP)*(1.-TP)*(1.-RP)+
     2             SOLN(3)*(1.+SP)*(1.+TP)*(1.-RP)+
     3             SOLN(4)*(1.-SP)*(1.+TP)*(1.-RP)+
     4             SOLN(5)*(1.-SP)*(1.-TP)*(1.+RP)+
     5             SOLN(6)*(1.+SP)*(1.-TP)*(1.+RP)+
     6             SOLN(7)*(1.+SP)*(1.+TP)*(1.+RP)+
     7             SOLN(8)*(1.-SP)*(1.+TP)*(1.+RP))
      RETURN
C
C     20-NODE HEX
C
  110 CONTINUE
      AA=.125*(SOLN(1)*(1.-SP)*(1.-TP)*(1.-RP)*(-SP-TP-RP-2.)+
     1         SOLN(2)*(1.+SP)*(1.-TP)*(1.-RP)*(SP-TP-RP-2.)+
     2         SOLN(3)*(1.+SP)*(1.+TP)*(1.-RP)*(SP+TP-RP-2.)+
     3         SOLN(4)*(1.-SP)*(1.+TP)*(1.-RP)*(-SP+TP-RP-2.)+
     4         SOLN(5)*(1.-SP)*(1.-TP)*(1.+RP)*(-SP-TP+RP-2.)+
     5         SOLN(6)*(1.+SP)*(1.-TP)*(1.+RP)*(SP-TP+RP-2.)+
     6         SOLN(7)*(1.+SP)*(1.+TP)*(1.+RP)*(SP+TP+RP-2.)+
     7         SOLN(8)*(1.-SP)*(1.+TP)*(1.+RP)*(-SP+TP+RP-2.))
      BB=.250*(SOLN(9)*(1.-SP**2)*(1.-TP)*(1.-RP)+
     1         SOLN(10)*(1.+SP)*(1.-TP**2)*(1.-RP)+
     2         SOLN(11)*(1.-SP**2)*(1.+TP)*(1.-RP)+
     3         SOLN(12)*(1.-SP)*(1.-TP**2)*(1.-RP)+
     4         SOLN(13)*(1.-SP)*(1.-TP)*(1.-RP**2)+
     5         SOLN(14)*(1.+SP)*(1.-TP)*(1.-RP**2)+
     6         SOLN(15)*(1.+SP)*(1.+TP)*(1.-RP**2)+
     7         SOLN(16)*(1.-SP)*(1.+TP)*(1.-RP**2)+
     8         SOLN(17)*(1.-SP**2)*(1.-TP)*(1.+RP)+
     9         SOLN(18)*(1.+SP)*(1.-TP**2)*(1.+RP)+
     $         SOLN(19)*(1.-SP**2)*(1.+TP)*(1.+RP)+
     $         SOLN(20)*(1.-SP)*(1.-TP**2)*(1.+RP))
      BVALUE=AA+BB
      RETURN
C
C     27-NODE HEX
C
  120 CONTINUE
      AA=.125*(-SOLN(1)*SP*TP*RP*(1.-SP)*(1.-TP)*(1.-RP)
     1         +SOLN(2)*SP*TP*RP*(1.+SP)*(1.-TP)*(1.-RP)
     2         -SOLN(3)*SP*TP*RP*(1.+SP)*(1.+TP)*(1.-RP)
     3         +SOLN(4)*SP*TP*RP*(1.-SP)*(1.+TP)*(1.-RP)
     4         +SOLN(5)*SP*TP*RP*(1.-SP)*(1.-TP)*(1.+RP)
     5         -SOLN(6)*SP*TP*RP*(1.+SP)*(1.-TP)*(1.+RP)
     6         +SOLN(7)*SP*TP*RP*(1.+SP)*(1.+TP)*(1.+RP)
     7         -SOLN(8)*SP*TP*RP*(1.-SP)*(1.+TP)*(1.+RP))
      BB=.250*(+SOLN (9)*TP*RP*(1.-SP**2)*(1.-TP)*(1.-RP)
     1         -SOLN(10)*SP*RP*(1.+SP)*(1.-TP**2)*(1.-RP)
     2         -SOLN(11)*TP*RP*(1.-SP**2)*(1.+TP)*(1.-RP)
     3         +SOLN(12)*SP*RP*(1.-SP)*(1.-TP**2)*(1.-RP)
     4         +SOLN(13)*SP*TP*(1.-SP)*(1.-TP)*(1.-RP**2)
     5         -SOLN(14)*SP*TP*(1.+SP)*(1.-TP)*(1.-RP**2)
     6         +SOLN(15)*SP*TP*(1.+SP)*(1.+TP)*(1.-RP**2)
     7         -SOLN(16)*SP*TP*(1.-SP)*(1.+TP)*(1.-RP**2))
      CC=.250*(-SOLN(17)*TP*RP*(1.-SP**2)*(1.-TP)*(1.+RP)
     1         +SOLN(18)*SP*RP*(1.+SP)*(1.-TP**2)*(1.+RP)
     2         +SOLN(19)*TP*RP*(1.-SP**2)*(1.+TP)*(1.+RP)
     3         -SOLN(20)*SP*RP*(1.-SP)*(1.-TP**2)*(1.+RP))+.500*(-SOLN(2
     41)*TP*(1.-SP**2)*(1.-TP)*(1.-RP**2)                        +SOLN(2
     52)*SP*(1.+SP)*(1.-TP**2)*(1.-RP**2)                        +SOLN(2
     63)*TP*(1.-SP**2)*(1.+TP)*(1.-RP**2)                        -SOLN(2
     74)*SP*(1.-SP)*(1.-TP**2)*(1.-RP**2)                        -SOLN(2
     85)*RP*(1.-SP**2)*(1.-TP**2)*(1.-RP)                        +SOLN(2
     96)*RP*(1.-SP**2)*(1.-TP**2)*(1.+RP))+SOLN(27)*(1.-SP**2)*(1.-TP**2
     $)*(1.-RP**2)
      BVALUE=AA+BB+CC
      RETURN
C
      END


!***********************************/
!	Name:移動先の格子を補間するための補間データ提供元格子検索
!	Alias:OFindDestination
!	Description:
!	Type:Geom,CellCenter
!	Input:Geom,CC
!	Output:CC%PrimitiveVariable
!	Note:1~3次元すべてに対応済み
!	Author:Akitaka Toyota
!	Date:2017.11.16
!	Update:2017.11.16
!	Other:
!***********************************/
subroutine InterpolationOfGlobalGrid(CC,Geom,LG)
    use StructVar_Mod
    use FrequentOperation
    implicit none
    type(CellCenter), intent(inout) :: CC
    type(Geometry), intent(in) :: Geom
    !type(UnstructuredGrid), intent(in) :: UG
    type(LocalGrids), intent(in) :: LG
    type(DonorElement), pointer :: DE
!    type(MoveGrid), intent(inout) :: MG

    integer :: iGlobalCellNumber
    integer :: iCenterX, iCenterY
    double precision :: AreaSum
    double precision, allocatable :: Moment(:)

!    write(6,*) "Cell value interpolation of Global Grid"
    allocate(Moment(4))
    CC%InterpolatedQuantity = CC%ConservedQuantity !補間処理が入らない格子はすべて前段階の値で上書き

    do iCenterY=1, Geom%CellNumber(2)
        do iCenterX=1, Geom%CellNumber(1)
            iGlobalCellNumber = Local2Global(iCenterX,iCenterY,Geom%CellNumber(1))

            DE => LG%GG%GDE(iGlobalCellNumber)%DE
            if(associated(DE)) then !そもそも補間の必要がない格子に関してはこのあとの処理はスルーで

                if(DE%Grid > 0) then
                    AreaSum = 0.0d0 !初期化
                    Moment = 0.0d0
                    do while(associated(DE)) !次のレコードがなくなるまで続行
                        AreaSum = AreaSum + DE%SharedArea !面積の総和計算
                        Moment(1:3) = Moment(1:3) + LG%CC(DE%Grid)%ConservedQuantity(1:3,DE%Cell,1,1) * DE%SharedArea !面積×保存量の総和計算
                        Moment(4) = Moment(4) + LG%CC(DE%Grid)%ConservedQuantity(5,DE%Cell,1,1) * DE%SharedArea !面積×保存量の総和計算 !StructEulerは4番にエネルギー入れてるため
                        DE => DE%Next !次のレコードへ

                    end do
                    CC%InterpolatedQuantity(:,iCenterX,iCenterY,1) = Moment/AreaSum

                else
                    !CC%InterpolatedQuantity(:,iCenterX,iCenterY,1) = 0.0d0 !物体の内部
                end if
            end if
        end do
    end do

    CC%ConservedQuantity = CC%InterpolatedQuantity

    return
end subroutine InterpolationOfGlobalGrid


PROGRAM test_colon
IMPLICIT NONE
REAL, DIMENSION(8) :: x
INTEGER :: i
x = (/ 1.1, 2.2, 3.3, 4.4, 5.5, 6.6, 7.7, 8.8 /)

WRITE (*,100) (i, x(i), i = 1, 8)
100 FORMAT (/,1X,'The output values are: '/, &
          3(5X,'X(',I2,') = ',F10.4))

WRITE (*,200) (i, x(i), i = 1, 8)
200 FORMAT (/,1X,'The output values are: '/,
          3(:,5X,'X(',I2,') = ',F10.4))

END PROGRAM test_colon


! =====================================================================
! subroutine RHSP
!
! This subroutine computes the matrix-vector multiplication required to
! construct the right-hand side vector of the Peaceman-Rachford step
! involving the angular kinetic energy terms. It has been modified for
! imaginary time propagation.
! ---------------------------------------------------------------------
      subroutine RHSP(nRP,nR,nP,dT,TPD,TPO,V,U,UT)
      implicit none

      integer :: nRP
      integer :: nR
      integer :: nP
      double precision :: dT
      double precision :: TPD(nR)
      double precision :: TPO(nR)
      double precision :: V(nRP)
      double complex :: U(nRP)
      double complex :: UT(nRP)

      integer :: i
      integer :: j
      integer :: k

      k = 0
      do j = 1, nR
         k = k + 1
         UT(k) = dcmplx(0.5d0*dT*TPO(j),0.0d0)*U(k+nP-1)
         UT(k) = UT(k)+dcmplx(1.0d0-0.5d0*dT*TPD(j)- 0.25d0*dT*V(k),0.0d0)*U(k)
         UT(k) = UT(k)+dcmplx(0.5d0*dT*TPO(j),0.0d0)*U(k+1)
         do i = 2, nP-1
            k = k + 1
            UT(k) = dcmplx(0.5d0*dT*TPO(j),0.0d0)*U(k-1)
            UT(k) = UT(k)+dcmplx(1.0d0-0.5d0*dT*TPD(j)- 0.25d0*dT*V(k),0.0d0)*U(k)
            UT(k) = UT(k)+dcmplx(0.5d0*dT*TPO(j),0.0d0)*U(k+1)
         enddo
         k = k + 1
         UT(k) = dcmplx(0.5d0*dT*TPO(j),0.0d0)*U(k-1)
         UT(k) = UT(k)+dcmplx(1.0d0-0.5d0*dT*TPD(j)- 0.25d0*dT*V(k),0.0d0)*U(k)
         UT(k) = UT(k)+dcmplx(0.5d0*dT*TPO(j),0.0d0)*U(k-nP+1)
      enddo

      do k = 1, nRP
         U(k) = UT(k)
      enddo

      return
      end
! =====================================================================


!< Henrick alpha coefficients object.
module wenoof_alpha_coefficients_m
!< Henrick alpha coefficients object.
!<
!< @note The provided WENO alpha coefficient implements the alpha coefficients defined in *Mapped weighted essentially
!< non-oscillatory schemes: Achieving optimal order near critical points*, Andrew K. Henrick, Tariq D. Aslam, Joseph M. Powers, JCP,
!< 2005, vol. 207, pp. 542-567, doi:10.1016/j.jcp.2005.01.023

use penf, only : I_P, R_P
use wenoof_alpha_coefficients
use wenoof_alpha_coefficients_js
use wenoof_alpha_coefficients_z
use wenoof_base_object

implicit none
private
public :: alpha_coefficients_m
public :: alpha_coefficients_m_constructor
public :: create_alpha_coefficients_m_constructor

type, extends(alpha_coefficients_constructor) :: alpha_coefficients_m_constructor
  !< Henrick alpha coefficients object constructor.
  character(len=:), allocatable :: base_type !< Base alpha coefficient type.
endtype alpha_coefficients_m_constructor

type, extends(alpha_coefficients) :: alpha_coefficients_m
  !< Henrick alpha coefficients object.
  !<
  !< @note The provided WENO alpha coefficient implements the alpha coefficients defined in *Mapped weighted essentially
  !< non-oscillatory schemes: Achieving optimal order near critical points*, Andrew K. Henrick, Tariq D. Aslam, Joseph M. Powers,
  !< JCP, 2005, vol. 207, pp. 542-567, doi:10.1016/j.jcp.2005.01.023.
  class(alpha_coefficients), allocatable :: alpha_base !< Base alpha coefficients to be re-mapped.
  contains
    ! deferred public methods
    procedure, pass(self) :: compute     !< Compute alpha coefficients.
    procedure, nopass     :: description !< Return alpha coefficients string-description.
    ! public methods
    procedure, pass(self) :: create  !< Create alpha coefficients.
    procedure, pass(self) :: destroy !< Destroy alpha coefficients.
endtype alpha_coefficients_m

contains
  ! public non TBP
  subroutine create_alpha_coefficients_m_constructor(S, constructor)
  !< Create alpha coefficients constructor.
  !<
  !< #TODO add actual M support (this is a copy of simple JS).
  integer(I_P),                                       intent(in)  :: S           !< Stencils dimension.
  class(alpha_coefficients_constructor), allocatable, intent(out) :: constructor !< Alpha coefficients constructor.

  allocate(alpha_coefficients_m_constructor :: constructor)
  constructor%S = S
  endsubroutine create_alpha_coefficients_m_constructor

  ! deferred public methods
  pure subroutine compute(self, S, weight_opt, IS, eps, f1, f2)
  !< Compute alpha coefficients.
  class(alpha_coefficients_m), intent(inout) :: self                       !< Alpha coefficients.
  integer(I_P),                intent(in)    :: S                          !< Number of stencils used.
  real(R_P),                   intent(in)    :: weight_opt(1: 2, 0: S - 1) !< Optimal weight of the stencil.
  real(R_P),                   intent(in)    :: IS(1: 2, 0: S - 1)         !< Smoothness indicators of the stencils.
  real(R_P),                   intent(in)    :: eps                        !< Parameter for avoiding divided by zero.
  integer(I_P),                intent(in)    :: f1, f2                     !< Faces to be computed.
  integer(I_P)                               :: f, s1                      !< Counters.

  self%alpha_tot = 0._R_P
  call self%alpha_base%compute(S=S, weight_opt=weight_opt, IS=IS, eps=eps, f1=f1, f2=f2)
  do s1=0, S - 1 ! stencil loops
    do f=f1, f2 ! 1 => left interface (i-1/2), 2 => right interface (i+1/2)
      self%alpha_coef(f, s1) =                                                                                &
        (self%alpha_base%alpha_coef(f, s1) * (weight_opt(f, s1) + weight_opt(f, s1) * weight_opt(f, s1) -     &
         3._R_P * weight_opt(f, s1) * self%alpha_base%alpha_coef(f, s1) + self%alpha_base%alpha_coef(f, s1) * &
         self%alpha_base%alpha_coef(f, s1))) /                                                                &
         (weight_opt(f, s1) * weight_opt(f, s1) + self%alpha_base%alpha_coef(f, s1) *                         &
         (1._R_P - 2._R_P * weight_opt(f, s1)))
      self%alpha_tot(f) = self%alpha_tot(f) + self%alpha_coef(f, s1)
    enddo
  enddo
  endsubroutine compute

  pure function description() result(string)
  !< Return alpha coefficients string-descripition.
  character(len=:), allocatable :: string           !< String-description.
  character(len=1), parameter   :: nl=new_line('a') !< New line character.

  string = 'WENO alpha coefficient'//nl
  string = string//'  Based on the work by Henrick, Aslam and Powers "Mapped weighted essentially non-oscillatory schemes: '// &
                   'Achieving optimal order near critical points", see JCP, 2005, vol. 207, pp. 542--567, '// &
                   'doi:10.1006/jcph.1996.0130'//nl
  string = string//'  The "compute" method has the following public API'//nl
  string = string//'    compute(S, weigt_opt, IS, eps, f1, f2)'//nl
  string = string//'  where:'//nl
  string = string//'    S: integer(I_P), intent(in), the number of the stencils used'//nl
  string = string//'    weight_opt: real(R_P), intent(in), the optimal weight of the actual stencil'//nl
  string = string//'    IS: real(R_P), intent(in), the smoothness indicator of the actual stencil'//nl
  string = string//'    eps: real(R_P), intent(in), the coefficient to avoid zero division used'//nl
  string = string//'    f1, f2: integer(I_P), intent(in), the faces to be computed (1 => left interface, 2 => right interface)'
  endfunction description

  ! overridden methods
  pure subroutine create(self, constructor)
  !< Create alpha coefficients.
  class(alpha_coefficients_m),    intent(inout) :: self        !< Alpha coefficients.
  class(base_object_constructor), intent(in)    :: constructor !< Alpha coefficients constructor.

  call self%destroy
  call self%alpha_coefficients%create(constructor=constructor)
  select type(constructor)
  type is(alpha_coefficients_m_constructor)
    if (allocated(constructor%base_type)) then
      select case(constructor%base_type)
      case('JS')
        if (allocated(self%alpha_base)) deallocate(self%alpha_base)
        allocate(alpha_coefficients_js :: self%alpha_base)
        call self%alpha_base%create(constructor=constructor)
      case('Z')
        if (allocated(self%alpha_base)) deallocate(self%alpha_base)
        allocate(alpha_coefficients_z :: self%alpha_base)
        call self%alpha_base%create(constructor=constructor)
      endselect
    endif
  class default
    ! @TODO add error handling
  endselect
  endsubroutine create

  elemental subroutine destroy(self)
  !< Destroy alpha coefficients.
  class(alpha_coefficients_m), intent(inout) :: self !< Alpha coefficients.

  call self%alpha_coefficients%destroy
  if (allocated(self%alpha_base)) deallocate(self%alpha_base)
  endsubroutine destroy
endmodule wenoof_alpha_coefficients_m


!
! SEISMIC_CPML Version 1.1.1, November 2009.
!
! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
! Contributors: Dimitri Komatitsch, komatitsch aT lma DOT cnrs-mrs DOT fr
!               and Roland Martin, roland DOT martin aT get DOT obs-mip DOT fr
!
! This software is a computer program whose purpose is to solve
! the two-dimensional anisotropic elastic 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".
!
! Author: Sourangshu Ghosh
!
  program seismic_CPML_2D_aniso

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

! Dimitri Komatitsch, University of Pau, France, April 2007.
! Anisotropic implementation by Roland Martin and Dimitri Komatitsch, University of Pau, France, April 2007.

! The second-order staggered-grid formulation of Madariaga (1976) and Virieux (1986) is used:
!
!            ^ y
!            |
!            |
!
!            +-------------------+
!            |                   |
!            |                   |
!            |                   |
!            |                   |
!            |        v_y        |
!   sigma_xy +---------+         |
!            |         |         |
!            |         |         |
!            |         |         |
!            |         |         |
!            |         |         |
!            +---------+---------+  ---> x
!           v_x    sigma_xx
!                  sigma_yy
!

! 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{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{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{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}}
!
! Modified by Sourangshu Ghosh
!
! If you use the anisotropic implementation, please cite this article,
! in which the anisotropic parameters are described, as well:
!
! @ARTICLE{KoBaTr00,
! author = {D. Komatitsch and C. Barnes and J. Tromp},
! title = {Simulation of anisotropic wave propagation based upon a spectral element method},
! journal = {Geophysics},
! year = {2000},
! volume = {65},
! number = {4},
! pages = {1251-1260},
! doi = {10.1190/1.1444816}}
!
! 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

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

! size of a grid cell
  double precision, parameter :: DELTAX = 0.0625d-2
  double precision, parameter :: DELTAY = DELTAX

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

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

! Velocity of qP along horizontal axis  = sqrt(c11/rho)
! Velocity of qP along vertical axis    = sqrt(c22/rho)
! Velocity of qSV along horizontal axis = sqrt(c33/rho)
! Velocity of qSV along vertical axis   = sqrt(c33/rho), same as along horizontal axis

! zinc, from Komatitsch et al. (2000)
! double precision, parameter :: c11 = 16.5d10
! double precision, parameter :: c12 = 5.d10
! double precision, parameter :: c22 = 6.2d10
! double precision, parameter :: c33 = 3.96d10
! double precision, parameter :: rho = 7100.d0
! double precision, parameter :: f0 = 170.d3

! apatite, from Komatitsch et al. (2000)
! double precision, parameter :: c11 = 16.7d10
! double precision, parameter :: c12 = 6.6d10
! double precision, parameter :: c22 = 14.d10
! double precision, parameter :: c33 = 6.63d10
! double precision, parameter :: rho = 3200.d0
! double precision, parameter :: f0 = 300.d3

! isotropic material a bit similar to apatite
! double precision, parameter :: c11 = 16.7d10
! double precision, parameter :: c12 = c11/3.d0
! double precision, parameter :: c22 = c11
! double precision, parameter :: c33 = (c11-c12)/2.d0  ! = c11/3.d0
! double precision, parameter :: rho = 3200.d0
! double precision, parameter :: f0 = 300.d3

! model I from Becache, Fauqueux and Joly, which is stable
  double precision, parameter :: scale_aniso = 1.d10
  double precision, parameter :: c11 = 4.d0 * scale_aniso
  double precision, parameter :: c12 = 3.8d0 * scale_aniso
  double precision, parameter :: c22 = 20.d0 * scale_aniso
  double precision, parameter :: c33 = 2.d0 * scale_aniso
  double precision, parameter :: rho = 4000.d0  ! used to be 1.
  double precision, parameter :: f0 = 200.d3

! model II from Becache, Fauqueux and Joly, which is stable
! double precision, parameter :: scale_aniso = 1.d10
! double precision, parameter :: c11 = 20.d0 * scale_aniso
! double precision, parameter :: c12 = 3.8d0 * scale_aniso
! double precision, parameter :: c22 = c11
! double precision, parameter :: c33 = 2.d0 * scale_aniso
! double precision, parameter :: rho = 4000.d0  ! used to be 1.
! double precision, parameter :: f0 = 200.d3

! model III from Becache, Fauqueux and Joly, which is unstable
! double precision, parameter :: scale_aniso = 1.d10
! double precision, parameter :: c11 = 4.d0 * scale_aniso
! double precision, parameter :: c12 = 4.9d0 * scale_aniso
! double precision, parameter :: c22 = 20.d0 * scale_aniso
! double precision, parameter :: c33 = 2.d0 * scale_aniso
! double precision, parameter :: rho = 4000.d0  ! used to be 1.
! double precision, parameter :: f0 = 250.d3

! model IV from Becache, Fauqueux and Joly, which is unstable
! double precision, parameter :: scale_aniso = 1.d10
! double precision, parameter :: c11 = 4.d0 * scale_aniso
! double precision, parameter :: c12 = 7.5d0 * scale_aniso
! double precision, parameter :: c22 = 20.d0 * scale_aniso
! double precision, parameter :: c33 = 2.d0 * scale_aniso
! double precision, parameter :: rho = 4000.d0  ! used to be 1.
! double precision, parameter :: f0 = 170.d3

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

! time step in seconds
  double precision, parameter :: DELTAT = 50.d-9

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

! source
  integer, parameter :: ISOURCE = NX / 2
  integer, parameter :: JSOURCE = NY / 2
  double precision, parameter :: xsource = (ISOURCE - 1) * DELTAX
  double precision, parameter :: ysource = (JSOURCE - 1) * DELTAY
! angle of source force clockwise with respect to vertical (Y) axis
  double precision, parameter :: ANGLE_FORCE = 0.d0

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

! 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

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

! velocity 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,sigmaxx,sigmayy,sigmaxy

! 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_dsigmaxx_dx, &
      memory_dsigmayy_dy, &
      memory_dsigmaxy_dx, &
      memory_dsigmaxy_dy

  double precision :: &
      value_dvx_dx, &
      value_dvx_dy, &
      value_dvy_dx, &
      value_dvy_dy, &
      value_dsigmaxx_dx, &
      value_dsigmayy_dy, &
      value_dsigmaxy_dx, &
      value_dsigmaxy_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
  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

  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,source_term

  integer :: i,j,it

  double precision :: Courant_number,velocnorm

! for stability estimate
  double precision :: quasi_cp_max,aniso_stability_criterion,aniso2,aniso3

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

  print *
  print *,'2D elastic 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 *

  print *,'Velocity of qP along vertical axis. . . . =',sqrt(c22/rho)
  print *,'Velocity of qP along horizontal axis. . . =',sqrt(c11/rho)
  print *
  print *,'Velocity of qSV along vertical axis . . . =',sqrt(c33/rho)
  print *,'Velocity of qSV along horizontal axis . . =',sqrt(c33/rho)
  print *

! from Becache et al., INRIA report, equation 7 page 5 http://hal.inria.fr/docs/00/07/22/83/PDF/RR-4304.pdf
  if (c11*c22 - c12*c12 <= 0.d0) stop 'problem in definition of orthotropic material'

! check intrinsic mathematical stability of PML model for an anisotropic material
! from E. B\'ecache, S. Fauqueux and P. Joly, Stability of Perfectly Matched Layers, group
! velocities and anisotropic waves, Journal of Computational Physics, 188(2), p. 399-433 (2003)
  aniso_stability_criterion = ((c12+c33)**2 - c11*(c22-c33)) * ((c12+c33)**2 + c33*(c22-c33))
  print *,'PML anisotropy stability criterion from Becache et al. 2003 = ',aniso_stability_criterion
  if (aniso_stability_criterion > 0.d0 .and. (USE_PML_XMIN .or. USE_PML_XMAX .or. USE_PML_YMIN .or. USE_PML_YMAX)) &
     print *,'WARNING: PML model mathematically intrinsically unstable for this anisotropic material for condition 1'
  print *

  aniso2 = (c12 + 2*c33)**2 - c11*c22
  print *,'PML aniso2 stability criterion from Becache et al. 2003 = ',aniso2
  if (aniso2 > 0.d0 .and. (USE_PML_XMIN .or. USE_PML_XMAX .or. USE_PML_YMIN .or. USE_PML_YMAX)) &
     print *,'WARNING: PML model mathematically intrinsically unstable for this anisotropic material for condition 2'
  print *

  aniso3 = (c12 + c33)**2 - c11*c22 - c33**2
  print *,'PML aniso3 stability criterion from Becache et al. 2003 = ',aniso3
  if (aniso3 > 0.d0 .and. (USE_PML_XMIN .or. USE_PML_XMAX .or. USE_PML_YMIN .or. USE_PML_YMAX)) &
     print *,'WARNING: PML model mathematically intrinsically unstable for this anisotropic material for condition 3'
  print *

! to compute d0 below, and for stability estimate
  quasi_cp_max = max(sqrt(c22/rho),sqrt(c11/rho))

!--- 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) * quasi_cp_max * log(Rcoef) / (2.d0 * thickness_PML_x)
  d0_y = - (NPOWER + 1) * quasi_cp_max * 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

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

! check the Courant stability condition for the explicit time scheme
! R. Courant et K. O. Friedrichs et H. Lewy (1928)
  Courant_number = quasi_cp_max * DELTAT * sqrt(1.d0/DELTAX**2 + 1.d0/DELTAY**2)
  print *,'Courant number is ',Courant_number
  print *
  if (Courant_number > 1.d0) stop 'time step is too large, simulation will be unstable'

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

! initialize arrays
  vx(:,:) = ZERO
  vy(:,:) = ZERO
  sigmaxx(:,:) = ZERO
  sigmayy(:,:) = ZERO
  sigmaxy(:,:) = ZERO

! PML
  memory_dvx_dx(:,:) = ZERO
  memory_dvx_dy(:,:) = ZERO
  memory_dvy_dx(:,:) = ZERO
  memory_dvy_dy(:,:) = ZERO
  memory_dsigmaxx_dx(:,:) = ZERO
  memory_dsigmayy_dy(:,:) = ZERO
  memory_dsigmaxy_dx(:,:) = ZERO
  memory_dsigmaxy_dy(:,:) = ZERO

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

  do it = 1,NSTEP

!------------------------------------------------------------
! compute stress sigma and update memory variables for C-PML
!------------------------------------------------------------

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

      value_dvx_dx = (vx(i+1,j) - vx(i,j)) / DELTAX
      value_dvy_dy = (vy(i,j) - vy(i,j-1)) / 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)

      sigmaxx(i,j) = sigmaxx(i,j) + (c11 * value_dvx_dx + c12 * value_dvy_dy) * DELTAT
      sigmayy(i,j) = sigmayy(i,j) + (c12 * value_dvx_dx + c22 * value_dvy_dy) * DELTAT

    enddo
  enddo

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

      value_dvy_dx = (vy(i,j) - vy(i-1,j)) / DELTAX
      value_dvx_dy = (vx(i,j+1) - vx(i,j)) / 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)

      sigmaxy(i,j) = sigmaxy(i,j) + c33 * (value_dvy_dx + value_dvx_dy) * DELTAT

    enddo
  enddo

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

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

      value_dsigmaxx_dx = (sigmaxx(i,j) - sigmaxx(i-1,j)) / DELTAX
      value_dsigmaxy_dy = (sigmaxy(i,j) - sigmaxy(i,j-1)) / DELTAY

      memory_dsigmaxx_dx(i,j) = b_x(i) * memory_dsigmaxx_dx(i,j) + a_x(i) * value_dsigmaxx_dx
      memory_dsigmaxy_dy(i,j) = b_y(j) * memory_dsigmaxy_dy(i,j) + a_y(j) * value_dsigmaxy_dy

      value_dsigmaxx_dx = value_dsigmaxx_dx / K_x(i) + memory_dsigmaxx_dx(i,j)
      value_dsigmaxy_dy = value_dsigmaxy_dy / K_y(j) + memory_dsigmaxy_dy(i,j)

      vx(i,j) = vx(i,j) + (value_dsigmaxx_dx + value_dsigmaxy_dy) * DELTAT / rho

    enddo
  enddo

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

      value_dsigmaxy_dx = (sigmaxy(i+1,j) - sigmaxy(i,j)) / DELTAX
      value_dsigmayy_dy = (sigmayy(i,j+1) - sigmayy(i,j)) / DELTAY

      memory_dsigmaxy_dx(i,j) = b_x_half(i) * memory_dsigmaxy_dx(i,j) + a_x_half(i) * value_dsigmaxy_dx
      memory_dsigmayy_dy(i,j) = b_y_half(j) * memory_dsigmayy_dy(i,j) + a_y_half(j) * value_dsigmayy_dy

      value_dsigmaxy_dx = value_dsigmaxy_dx / K_x_half(i) + memory_dsigmaxy_dx(i,j)
      value_dsigmayy_dy = value_dsigmayy_dy / K_y_half(j) + memory_dsigmayy_dy(i,j)

      vy(i,j) = vy(i,j) + (value_dsigmaxy_dx + value_dsigmayy_dy) * DELTAT / rho

    enddo
  enddo

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

! Gaussian
! source_term = factor * exp(-a*(t-t0)**2)

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

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

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

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

  vx(i,j) = vx(i,j) + force_x * DELTAT / rho
  vy(i,j) = vy(i,j) + force_y * DELTAT / rho

! 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

! 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
    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, &
                         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, &
                         NPOINTS_PML,USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX,2)

  endif

  enddo   ! end of time loop

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

  end program seismic_CPML_2D_aniso

!----
!----  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, &
              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
  logical USE_PML_XMIN,USE_PML_XMAX,USE_PML_YMIN,USE_PML_YMAX

  double precision, dimension(NX,NY) :: image_data_2D

  integer :: ix,iy

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

! 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


C-----------------------------------------------------------------------
C
C    Preconditioner Tools for Reaction-Transport Problems
C    Part I: Block-Diagonal Reaction-Based Factor without Grouping
C                        14 September 1995
C
C The following three subroutines -- DMSET2, DRBDJA, DRBDPS --
C are provided to assist in the generation and solution of
C preconditioner matrices for problems arising from reaction-transport
C systems, as solved with DASPK.  More specifically, they are intended
C as tools for preconditioners that include a contribution from the
C reaction terms of the system.  These are intended as auxiliary
C routines for the user-supplied routines JAC and PSOL called by
C DASPK when the Krylov method is selected.
C
C These routines are intended for a DAE system obtained from a system
C of reaction-transport PDEs, in which some of the PDE variables obey
C evolution equations, and the rest obey algebraic (time-independent)
C equations.  See Ref. 2, Section 4.  It is assumed that the
C right-hand sides of all the equations have the form of a sum of a
C reaction term R and a transport term S, that the transport term
C is discretized by finite differences, and that in the spatial
C discretization the PDE variables at each spatial point are kept
C together.  Thus the DAE system function, in terms of a dependent
C variable vector u, has the form
C     G(t,u,u') = I_d u' - R(t,u) - S(t,u) ,  where
C     I_d = identity matrix with zeros in the positions corresponding
C           to the algebraic components, ones in those for the
C           evolution (differential) components.
C     R(t,u) = the reaction terms (spatial coupling absent), and
C     S(t,u) = the spatial transport terms.
C
C As shown in [2], two possible preconditioners for such a system are:
C (a) P_R = c I_d - dR/du, based on the reaction term R alone, and
C (b) P_SR = (I - (1/c) dS/du) (c I_d - dR/du), the product of two
C     factors (in either order), one being P_R and the other being
C     based on the spatial term S alone.
C Here c is the scalar CJ that is input to the JAC and PSOL routines
C provided by the user (1/c is proportional to the step size H).
C
C The routines given here can be used to provide the reaction-based
C factor P_R.  More precisely, they provide an approximation A_R to
C P_R.  The matrix P_R is block-diagonal, with each block corresponding
C to one spatial point.  In A_R, we compute each block by difference
C quotient approximations, by way of calls to a user-supplied routine,
C subroutine RBLOCK, that evaluates the reaction terms at a single
C spatial point.  A_R has one such block for each spatial point in
C the mesh.  (For a more economical approximation, see Part II,
C on block-grouping in A_R.)
C
C The routines given here are specialized to the case of a 2-D problem
C on a rectangular mesh in the x-y plane.  However, they can be easily
C modified for a different problem geometry.  It is also assumed
C that the PDE variables are ordered so that the differential
C variables appear first, followed by the algebraic variables.
C
C To make use of these routines in a DASPK solution, the user must
C provide:
C (a) a calling program that sets the DASPK input parameters, and calls
C     DMSET2 to set mesh data and mesh-related DASPK inputs;
C (b) a JAC routine, as prescribed by the DASPK instructions, which
C     calls DRBDJA, and does any other Jacobian-related preprocessing
C     needed for preconditioning; and
C (c) a PSOL routine, as prescribed by the DASPK instructions, which
C     calls DRBDPS for the solution of systems A_R x = b, and does
C     any other linear system solving required by the preconditioner.
C Detailed descriptions and instructions are given below.
C
C In addition, the use of these routines requires:
C  * the LINPACK routines DGEFA and DGESL for dense linear sytems, and
C  * the machine constant routine D1MACH for the machine unit roundoff.
C
C (a) The calling program.
C The calling program sets the DASPK inputs and makes calls to DASPK.
C Here the DASPK inputs include
C   INFO(12) = 1 [to signal the Krylov method]
C   INFO(15) = 1 [to signal the presence of a JAC routine]
C
C Also, the use of the DRBDJA/DRBDPS routines in conjunction with
C DASPK requires that certain mesh-related data be set.  This can be
C done with the call
C     CALL DMSET2 (MX, MY, NS, NSD, LID, IWORK)
C The input arguments to DMSET2 are:
C   MX and MY = the mesh dimensions.
C   NS  = number of PDE variables.
C   NSD = number of differential PDE variables.
C   LID = offset in IWORK for array showing the differential and
C         algebraic components on input to DASPK, required if either
C         INFO(11) = 1 or INFO(16) = 1.  Set LID = 0 otherwise.
C         If this array is required, set LID = 40 or 40 + NEQ,
C         depending on the value of the constraint option INFO(10).
C DMSET2 loads mesh data in a COMMON block /DRPRE1/ used by the
C DRBDJA/DRBDPS routines.
C
C DMSET2 also loads the preconditioner work lengths into
C IWORK(27) and IWORK(28), and if LID > 0 it sets the ID array
C in IWORK showing the differential and algebraic components.
C
C (b) The JAC routine.
C The user-supplied JAC routine called by DASPK with the Krylov
C method specified, is to generate and preprocess Jacobian-related
C data as needed for later solution of the preconditioner system
C P x = b.  Assuming that P is to be an approximation of either P_R
C or P_SR, the JAC routine should call DRBDJA for the approximation
C A_R to P_R.  Subroutine DRBDJA generates A_R using difference
C quotients.  It then performs an LU decomposition of each block,
C using the LINPACK routine DGEFA.
C
C In terms of the arguments passed to JAC by DASPK, the call to
C DRBDJA should have the form
C     CALL DRBDJA (T, U, R0, RBLOCK, WK, REWT, CJ, WP, IWP, IER)
C where we use U instead of Y for the dependent variable array.
C The argument R0 is an array assumed to contain the current value
C of the R vector, at the current values (T,U).  This can be done, for
C example, by taking R0 to be RPAR, and loading RPAR with the
C vector R in the last call to the RES routine; in that case, the
C calling program must declare RPAR to have length at least NEQ.
C Alternatively, insert a call to RBLOCK (see below) within the
C loop over mesh points in DRBDJA.
C
C To use DRBDJA, the user must provide the following subroutine,
C which DRBDJA calls to obtain individual blocks of R:
C      SUBROUTINE RBLOCK (T, JX, JY, UXY, RXY)
C The input arguments to RBLOCK are:
C   T     = current time.
C   JX,JY = spatial indices in x- and y-directions.
C   UXY   = block of NS dependent variables at spatial point (JX,JY).
C RBLOCK is to load block (JX,JY) of R(t,u) into the array RXY.
C
C (c) The PSOL routine.
C The user-supplied PSOL routine must solve the linear system P x = b,
C where P is the preconditioner matrix.  For this, the PSOL routine
C should call DRBDPS for the solution of A_R.  Subroutine DRBDPS
C solves a linear system A_R x = b, using the LINPACK backsolve
C routine DGESL.  In terms of the arguments passed to PSOL by DASPK,
C the call to DRBDPS should have the form
C     CALL DRBDPS (B, WP, IWP)
C DRBDPS overwrites the B array (containing b) with the solution x.
C
C-----------------------------------------------------------------------
C
C References
C [1] Peter N. Brown and Alan C. Hindmarsh,
C     Reduced Storage Matrix Methods in Stiff ODE Systems,
C     J. Appl. Math. & Comp., 31 (1989), pp. 40-91.
C [2] Peter N. Brown, Alan C. Hindmarsh, and Linda R. Petzold,
C     Using Krylov Methods in the Solution of Large-Scale Differential-
C     Algebraic Systems, SIAM J. Sci. Comput., 15 (1994), pp. 1467-1488.
C [3] Peter N. Brown, Alan C. Hindmarsh, and Linda R. Petzold,
C     Consistent Initial Condition Calculation for Differential-
C     Algebraic Systems, LLNL Report UCRL-JC-122175, August 1995;
C     submitted to SIAM J. Sci. Comp.
C-----------------------------------------------------------------------

      SUBROUTINE DMSET2 (MX, MY, NS, NSD, LID, IWORK)
C***BEGIN PROLOGUE  DMSET2
C***DATE WRITTEN   950830   (YYMMDD)
C
C***AUTHORS  A. C. Hindmarsh
C            Lawrence Livermore National Laboratory
C            L-316, P.O. Box 808
C            Livermore, CA 94551
C
C***DESCRIPTION
C
C-----------------------------------------------------------------------
C This routine sets mesh parameters needed to use the routines
C DRBDJA and DRBDPS, assuming a 2-D rectangular problem.
C Given the mesh parameters, it loads the COMMON block /DRPRE1/,
C and the lengths LENWP and LENIWP in IWORK.
C Then if LID > 0, it also sets the ID array in IWORK, indicating
C which components are differential and which are algebraic.
C
C The variables in the COMMON block are defined as follows:
C   SRUR   = SQRT(unit roundoff), used in difference quotients.
C            UROUND = D1MACH(4) generates the unit roundoff.
C   MP     = NS = number of PDE variables, the size of each block in
C            the block-diagonal preconditioner matrix P_R.
C   MPD    = NSD = number of differential PDE variables.  In the DAE
C            system, the first MPD variables at each spatial point have
C            time  derivatives, and the remaining (MP - MPD) do not.
C   MPSQ   = MP*MP.
C   MESHX  = MX = x mesh size.
C   MESHY  = MY = y mesh size (the mesh is MESHX by MESHY).
C-----------------------------------------------------------------------
C***ROUTINES CALLED
C   D1MACH
C
C***END PROLOGUE  DMSET2
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION IWORK(*)
      COMMON /DRPRE1/ SRUR, MP, MPD, MPSQ, MESHX, MESHY, MXMP
C
C Load the COMMON block.
      UROUND = D1MACH(4)
      SRUR = SQRT(UROUND)
      MP = NS
      MPD = NSD
      MPSQ = NS*NS
      MESHX = MX
      MESHY = MY
      MXMP = MESHX*MP
C
C Here set the sizes of the preconditioning storage space segments
C in RWORK and IWORK.
      IWORK(27) = MPSQ*MESHX*MESHY
      IWORK(28) = MP*MESHX*MESHY
C
C If LID .GT. 0, set the ID array in IWORK.
      IF (LID .EQ. 0) RETURN
      I0 = LID
      DO 40 JY = 1,MY
        DO 30 JX = 1,MX
          DO 10 I = 1,MPD
 10         IWORK(I0+I) = 1
          DO 20 I = MPD+1,MP
 20         IWORK(I0+I) = -1
          I0 = I0 + MP
 30       CONTINUE
 40     CONTINUE
C
      RETURN
C------------  End of Subroutine DMSET2  -------------------------------
      END

      SUBROUTINE DRBDJA (T, U, R0, RBLOCK, R1, REWT, CJ, BD, IPBD, IER)
C***BEGIN PROLOGUE  DRBDJA
C***DATE WRITTEN   950914   (YYMMDD)
C
C***AUTHORS  A. C. Hindmarsh
C            Lawrence Livermore National Laboratory
C            L-316, P.O. Box 808
C            Livermore, CA 94551
C
C***DESCRIPTION
C
C-----------------------------------------------------------------------
C This routine generates and preprocesses a block-diagonal
C preconditioner matrix, based on the part of the Jacobian corresponding
C to the reaction terms R of the problem.
C It generates a matrix of the form CJ * I_d - dR/du.
C It calls DGEFA to do LU decomposition of each diagonal block.
C The computation of the diagonal blocks uses the mesh information in
C the COMMON block /DRPRE1/.  One block per spatial point is computed.
C The Jacobian elements are generated by difference quotients.
C This routine calls a user routine of the form
C      SUBROUTINE RBLOCK (T, JX, JY, UXY, RXY)
C which is to set RXY to block (JX,JY) of R, as a function of the
C current time T and block UXY of current dependent variable vector U.
C The array R0 is assumed to contain the current value of R at (T,U).
C-----------------------------------------------------------------------
C On input:
C   T      = current value of independent variable.
C   U      = current dependent variable array.
C   R0  = array of current values of the vector R at (T,U)
C   RBLOCK = name of external routine that computes a single block of R.
C   R1     = array of length NEQ for work space.
C   REWT   = reciprocal error weights.
C   CJ     = scalar used in forming the system Jacobian.
C
C On output:
C   BD     = array containing the LU factors of the diagonal blocks.
C   IPBD   = integer array of pivots for the LU factorizations.
C   IER    = integer error flag.  If no error occurred, IER = 0.
C            If a zero pivot was found at stage k in one of the LU
C            factorizations, this routine returns IER = k > 0.
C Here BD is the RWORK segment WP, and IPBD is the IWORK segment IWP.
C-----------------------------------------------------------------------
C***ROUTINES CALLED
C   RBLOCK, DGEFA
C
C***END PROLOGUE  DRBDJA
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      EXTERNAL RES, RBLOCK
      DIMENSION U(*), R0(*), R1(*), REWT(*), BD(*), IPBD(*)
C
      COMMON /DRPRE1/ SRUR, MP, MPD, MPSQ, MESHX, MESHY, MXMP
C
C Make MP calls to RBLOCK to approximate each diagonal block of dR/du.
      DFAC = 1.0D-2
      IBD = 0
      J0 = 0
      DO 40 JY = 1,MESHY
        DO 30 JX = 1,MESHX
C If R0 has not been set previously as an array of length NEQ, it can
C be set here, as an array of length MP, with the call
C         CALL RBLOCK (T, JX, JY, U(J0+1), R0)
C In this case, change R0(J0+I) below to R0(I).
          DO 20 JS = 1,MP
            J = J0 + JS
            UJ = U(J)
            DEL = MAX(SRUR*ABS(UJ),DFAC/REWT(J))
            U(J) = U(J) + DEL
            FAC = -1.0D0/DEL
            CALL RBLOCK (T, JX, JY, U(J0+1), R1)
            DO 10 I = 1,MP
 10           BD(IBD+I) = (R1(I) - R0(J0+I))*FAC
            U(J) = UJ
            IBD = IBD + MP
 20         CONTINUE
          J0 = J0 + MP
 30       CONTINUE
 40     CONTINUE
C
C Add matrix CJ * I_d, and do LU decomposition on blocks. --------------
      IBD = 1
      IIP = 1
      DO 80 J = 1,MESHX*MESHY
        IDIAG = IBD
        DO 70 I = 1,MP
          IF (I .LE. MPD) BD(IDIAG) = BD(IDIAG) + CJ
 70       IDIAG = IDIAG + (MP + 1)
        CALL DGEFA (BD(IBD), MP, MP, IPBD(IIP), IER)
        IF (IER .NE. 0) GO TO 90
        IBD = IBD + MPSQ
        IIP = IIP + MP
 80     CONTINUE
 90   RETURN
C------------  End of Subroutine DRBDJA  -------------------------------
      END

      SUBROUTINE  DRBDPS (B, BD, IPBD)
C***BEGIN PROLOGUE  DRBDPS
C***DATE WRITTEN   950914   (YYMMDD)
C
C***AUTHORS  A. C. Hindmarsh
C            Lawrence Livermore National Laboratory
C            L-316, P.O. Box 808
C            Livermore, CA 94551
C
C***DESCRIPTION
C
C-----------------------------------------------------------------------
C This routine solves a linear system A_R x = b, using the LU factors
C of the diagonal blocks computed in DRBDJA, and mesh parameters
C in the COMMON block /DRPRE1/.
C Here BD is the RWORK segment WP, and IPBD is the IWORK segment IWP.
C The right-hand side vector b, contained in B on entry, is overwritten
C with the solution vector x on return.
C-----------------------------------------------------------------------
C***ROUTINES CALLED
C   DGESL
C
C***END PROLOGUE  DRBDPS
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION B(*), BD(*), IPBD(*)
C
      COMMON /DRPRE1/ SRUR, MP, MPD, MPSQ, MESHX, MESHY, MXMP
C
      IER = 0
      IB = 1
      IBD = 1
      DO 20 JY = 1,MESHY
        DO 10 JX = 1,MESHX
          CALL DGESL (BD(IBD), MP, MP, IPBD(IB), B(IB), 0)
          IB = IB + MP
          IBD = IBD + MPSQ
 10       CONTINUE
 20     CONTINUE
C
      RETURN
C------------  End of Subroutine DRBDPS  -------------------------------
      END


!***************************************************************************************************************************
! This is the code from the section (DYNAMIC == INTEGR) lines 9459 - 9573 of the original CSCAS code.  The names of the
! dummy arguments are the same as in the original CSCAS code and the call statement and are declared here. The variables
! that are not arguments are declared in module YCA_First_Trans_m. Unless identified as by MF, all comments are those of
! the original CSCAS.FOR code.
!
! Subroutine YCA_Out_StoreVars stores variables for sending to CSM summary output routines.
!***************************************************************************************************************************

    SUBROUTINE YCA_Out_StoreVars ( &
        IDETO       , ISWNIT      , STGYEARDOY  &
        )

        USE ModuleDefs                                                                        ! MF 31AU14 Added for access to WEATHER
        USE YCA_First_Trans_m
        USE YCA_Formats_m

        IMPLICIT NONE

        INTEGER :: STGYEARDOY(0:19)

        CHARACTER(LEN=1)  :: IDETO       , ISWNIT

        !-----------------------------------------------------------------------------------------------------------
        !         Store variables for sending to CSM summary output routines
        !-----------------------------------------------------------------------------------------------------------

        ! Store summary labels and values in arrays to send to
        ! CSM OPSUM routine for printing.  Integers are temporarily
        ! saved as real numbers for placement in real array.

        IF (IDETO == 'E'.OR.IDETO == 'N') THEN
            ! Resource productivity calculations
            ! (Nnot done earlier because no Overview called for)
            DMP_Rain = -99.
            GrP_Rain = -99.
            DMP_ET = -99.
            GrP_ET = -99.
            DMP_EP = -99.
            GrP_EP = -99.
            DMP_Irr = -99.
            GrP_Irr = -99.
            DMP_NApp = -99.
            GrP_NApp = -99.
            DMP_NUpt = -99.
            GrP_NUpt = -99.
            IF (RAINCC > 1.E-3) THEN
                DMP_Rain = CWAM / RAINCC
                GrP_Rain = HWAM  / RAINCC
            ENDIF
            IF (ETCC > 1.E-3) THEN
                DMP_ET = CWAM / ETCC
                GrP_ET = HWAM  / ETCC
            ENDIF
            IF (EPCC > 1.E-3) THEN
                DMP_EP = CWAM / EPCC
                GrP_EP = HWAM  / EPCC
            ENDIF
            IF (IRRAMTC > 1.E-3) THEN
                DMP_Irr = CWAM / IRRAMTC
                GrP_Irr = HWAM  / IRRAMTC
            ENDIF
            IF (ISWNIT /= 'N') THEN
                IF (Amtnit > 1.E-3) THEN
                    DMP_NApp = CWAM / Amtnit
                    GrP_NApp = HWAM  / Amtnit
                ENDIF
                IF (NUPAC > 1.E-3) THEN
                    DMP_NUpt = CWAM / NUPAC
                    GrP_NUpt = HWAM  / NUPAC
                ENDIF
            ENDIF ! ISWNIT NE 'N'
        ENDIF

        LABEL(1) = 'ADAT'; VALUE(1) = -99.0
        !IF (stgyeardoy(mstg) < 9999999) THEN                     !LPM  07MAR15 MSTG TO PSX
        !    LABEL(2) = 'MDAT'; VALUE(2) = FLOAT(stgyeardoy(mstg))
        IF (stgyeardoy(PSX) < 9999999) THEN
            LABEL(2) = 'MDAT'; VALUE(2) = FLOAT(stgyeardoy(PSX))
        ELSE
            LABEL(2) = 'MDAT'; VALUE(2) = -99.0
        ENDIF
        LABEL(3) = 'DWAP'; VALUE(3) = sdrate
        LABEL(4) = 'CWAM'; VALUE(4) = cwam
        LABEL(5) = 'HWAM'; VALUE(5) = hwam
        LABEL(6) = 'HWAH '; VALUE(6) = hwam * hpcf/100.0
        LABEL(7) = 'BWAH '; VALUE(7) = vwam * hbpcf/100.0
        LABEL(8) = 'HWUM'; VALUE(8) = hwum
        LABEL(9) = 'H#AM'; VALUE(9) = hnumam
        LABEL(10) = 'H#UM'; VALUE(10) = hnumgm
        LABEL(11) = 'NUCM'; VALUE(11) = nupac
        LABEL(12) = 'CNAM'; VALUE(12) = cnam
        LABEL(13) = 'GNAM'; VALUE(13) = hnam
        LABEL(14) = 'PWAM'; VALUE(14) = -99.0
        LABEL(15) = 'LAIX'; VALUE(15) = laix
        LABEL(16) = 'HIAM'; VALUE(16) = hiam

        LABEL(17) = 'DMPPM'; VALUE(17) = DMP_Rain
        LABEL(18) = 'DMPEM'; VALUE(18) = DMP_ET
        LABEL(19) = 'DMPTM'; VALUE(19) = DMP_EP
        LABEL(20) = 'DMPIM'; VALUE(20) = DMP_Irr
        LABEL(21) = 'DPNAM'; VALUE(21) = DMP_NApp
        LABEL(22) = 'DPNUM'; VALUE(22) = DMP_NUpt

        LABEL(23) = 'YPPM ' ; VALUE(23) = GrP_Rain
        LABEL(24) = 'YPEM ' ; VALUE(24) = GrP_ET
        LABEL(25) = 'YPTM ' ; VALUE(25) = GrP_EP
        LABEL(26) = 'YPIM ' ; VALUE(26) = GrP_Irr
        LABEL(27) = 'YPNAM' ; VALUE(27) = GrP_NApp
        LABEL(28) = 'YPNUM' ; VALUE(28) = GrP_NUpt
        LABEL(29) = 'EDAT ' ; VALUE(29) = FLOAT(EYEARDOY)

        LABEL(30) = 'NDCH ' ; VALUE(30) = FLOAT(CDAYS)
        LABEL(31) = 'TMINA' ; VALUE(31) = TMINCAV
        LABEL(32) = 'TMAXA' ; VALUE(32) = TMAXCAV
        LABEL(33) = 'SRADA' ; VALUE(33) = SRADCAV
        LABEL(34) = 'DAYLA' ; VALUE(34) = DAYLCAV
        LABEL(35) = 'CO2A ' ; VALUE(35) = CO2CAV
        LABEL(36) = 'PRCP ' ; VALUE(36) = RAINCC
        LABEL(37) = 'ETCP ' ; VALUE(37) = ETCC

        IF (FILEIOT(1:2) == 'DS') CALL SUMVALS (SUMNUM, LABEL, VALUE)

    END SUBROUTINE YCA_Out_StoreVars


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!
!!!!   MIT License
!!!!
!!!!   ParaMonte: plain powerful parallel Monte Carlo library.
!!!!
!!!!   Copyright (C) 2012-present, The Computational Data Science Lab
!!!!
!!!!   This file is part of the ParaMonte library.
!!!!
!!!!   Permission is hereby granted, free of charge, to any person obtaining a
!!!!   copy of this software and associated documentation files (the "Software"),
!!!!   to deal in the Software without restriction, including without limitation
!!!!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!!!!   and/or sell copies of the Software, and to permit persons to whom the
!!!!   Software is furnished to do so, subject to the following conditions:
!!!!
!!!!   The above copyright notice and this permission notice shall be
!!!!   included in all copies or substantial portions of the Software.
!!!!
!!!!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
!!!!   EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
!!!!   MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
!!!!   IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
!!!!   DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
!!!!   OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE
!!!!   OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
!!!!
!!!!   ACKNOWLEDGMENT
!!!!
!!!!   ParaMonte is an honor-ware and its currency is acknowledgment and citations.
!!!!   As per the ParaMonte library license agreement terms, if you use any parts of
!!!!   this library for any purposes, kindly acknowledge the use of ParaMonte in your
!!!!   work (education/research/industry/development/...) by citing the ParaMonte
!!!!   library as described on this page:
!!!!
!!!!       https://github.com/cdslaborg/paramonte/blob/master/ACKNOWLEDGMENT.md
!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

module Test_CrossCorr_mod

    use Test_mod, only: Test_type
    use CrossCorr_mod
    implicit none

    private
    public :: test_CrossCorr

    type(Test_type) :: Test

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

contains

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

    subroutine test_CrossCorr()

        use Constants_mod, only: IK, RK
        use Timer_mod, only: Timer_type
        use Err_mod, only: Err_type
        implicit none
        integer(IK)                 :: nd,np,id,ip,fileUnit,nlag,ilag, paddedLen
        integer(IK), allocatable    :: Lag(:), Weight(:)
        real(RK)   , allocatable    :: InputData(:,:), NormedData(:,:), AutoCorr(:,:), InverseSumNormedDataSq(:), Mean(:)
        real(RK)   , allocatable    :: NormedDataFFT1(:,:), NormedDataFFT2(:,:), AutoCorrFFT(:,:)
        type(Timer_type)            :: Timer
        type(Err_type)              :: Err

        Test = Test_type(moduleName=MODULE_NAME)

        blockFirstImage: if (Test%Image%id==1_IK) then

            call Test%testing("AutoCorr")
            Timer = Timer_type(Err)
            call Test%checkForErr(Err)

            ! read input data

            open(newunit=fileUnit,file=Test%inDir//"autoCorrDataWeightedCompact.txt",status="old")
            nd = 1
            np = 9985
            allocate(InputData(nd,np),Weight(np))
            do ip = 1,np
                read(fileUnit,*) Weight(ip), InputData(1:nd,ip)
            end do
            close(fileUnit)

            ! normalize data

            allocate(Mean(nd),NormedData(nd,np))
            Mean = 0._RK
            do id = 1,nd
                do ip = 1,np
                    Mean(id) = Mean(id) + InputData(id,ip)
                end do
                Mean(id) = Mean(id) / np
                NormedData(id,1:np) = InputData(id,1:np) - Mean(id)
            end do

            ! Generate Lags

            nlag = -1
            do
                nlag = nlag + 1
                if (2**nlag<np) cycle
                exit
            end do
            nlag = nlag - 1
            Lag = [(2**ilag,ilag=1,nlag)]
#if defined DBG_ENABLED
            write(*,*) nlag, Lag
#endif

            ! compute AutoCorr using Classic definition

            allocate(AutoCorr(nd,nlag),InverseSumNormedDataSq(nd))
            open(newunit=fileUnit,file=Test%outDir//"autoCorrOutput.txt",status="replace")
            write(*,*) "Computing AutoCorr for lag number using the classical AutoCorr definition..."

            InverseSumNormedDataSq = getInverseSumNormedDataSq(1_IK,np,NormedData)
            call Timer%tic()
            call getAutoCorrSlow(nd,np,NormedData(1:nd,1:np),nlag,Lag,AutoCorr,InverseSumNormedDataSq)
            call Timer%toc()
#if defined DBG_ENABLED
            write(*,*) "Done in ", Timer%Time%delta, " seconds."
#endif
            do ilag = 1,nlag
                write(fileUnit,*) Lag(ilag), AutoCorr(1:nd,ilag)
            end do
            close(fileUnit)

            !***********************************************************************************************************************
            ! compute AutoCorr using FFT
            !***********************************************************************************************************************

            paddedLen = getPaddedLen(np)
            allocate( NormedDataFFT1(paddedLen,nd) &
                    , NormedDataFFT2(paddedLen,nd) &
                    , AutoCorrFFT(paddedLen,nd) )
            do id = 1, nd
                NormedDataFFT1(1:paddedLen,id) = padZero(np,NormedData(id,1:np),paddedLen)
            end do
            NormedDataFFT2 = NormedDataFFT1
            !do id = 1, nd
            !    NormedDataFFT1(1:np,id) = NormedData(id,1:np)
            !    NormedDataFFT1(np+1:paddedLen,id) = 0
            !end do
            open(newunit=fileUnit,file=Test%outDir//"autoCorrOutputFFTCompact.txt",status="replace")
            write(*,*) "Computing AutoCorr for Compact Data number using FFT..."
            call Timer%tic()
            do id = 1,nd
                AutoCorrFFT(1:paddedLen,id) = getCrossCorrFFT( paddedLen                      &
                                                             , NormedDataFFT1(1:paddedLen,id) &
                                                             , NormedDataFFT1(1:paddedLen,id) )
                AutoCorrFFT(1:paddedLen,id) = AutoCorrFFT(1:paddedLen,id) / AutoCorrFFT(1,id)
                ! ensure NormedDataFFT1 does not change upon entering and exiting getCrossCorrFFT()
#if defined DBG_ENABLED
                do ip = 1,paddedLen
                    if (NormedDataFFT2(ip,id)/=NormedDataFFT1(ip,id)) then
                        write(*,*) "nonsense: ", NormedDataFFT1(ip,id), NormedDataFFT2(ip,id)
                    end if
                end do
#endif
            end do
            call Timer%toc()
#if defined DBG_ENABLED
            write(*,*) "Done in ", Timer%Time%delta, " seconds."
#endif
            do ip = 1, paddedLen
                write(fileUnit,*) ip-1, AutoCorrFFT(ip,1)
            end do
            close(fileUnit)

            !***********************************************************************************************************************
            ! compute AutoCorr using FFT with missing Weighted Data
            !***********************************************************************************************************************

            open(newunit=fileUnit,file=Test%outDir//"autoCorrOutputFFTCompactWeightMissing.txt",status="replace")
            write(*,*) "Computing AutoCorr for Compact Data using Weighted FFT Implementation..."
            call Timer%tic()
            do id = 1,nd
                AutoCorrFFT(1:paddedLen,id) = getCrossCorrFFTweighted   ( nData1 = np                   &
                                                                        , nData2 = np                   &
                                                                        , paddedLen = paddedLen         &
                                                                        , Data1 = NormedData(id,1:np)   &
                                                                        , Data2 = NormedData(id,1:np)   &
                                                                        )
                AutoCorrFFT(1:paddedLen,id) = AutoCorrFFT(1:paddedLen,id) / AutoCorrFFT(1,id)
            end do
            call Timer%toc()
#if defined DBG_ENABLED
            write(*,*) "Done in ", Timer%Time%delta, " seconds."
#endif
            do ip = 1, paddedLen
                write(fileUnit,*) ip-1, AutoCorrFFT(ip,1)
            end do
            close(fileUnit)

            !***********************************************************************************************************************
            ! compute AutoCorr using FFT with Weighted Data
            !***********************************************************************************************************************

            ! normalize data

            deallocate(Mean,NormedData,NormedDataFFT1,AutoCorrFFT)
            allocate(Mean(nd),NormedData(np,nd),NormedDataFFT1(np,nd))
            Mean = 0._RK
            do id = 1,nd
                do ip = 1,np
                    Mean(id) = Mean(id) + Weight(ip)*InputData(id,ip)
                end do
                Mean(id) = Mean(id) / sum(Weight)
                NormedData(1:np,id) = InputData(id,1:np) - Mean(id)
            end do
            NormedDataFFT1 = NormedData

            paddedLen = getPaddedLen(sum(Weight))
            allocate(AutoCorrFFT(paddedLen,nd))
            open(newunit=fileUnit,file=Test%outDir//"autoCorrOutputFFTVerbose.txt",status="replace")
            write(*,*) "Computing AutoCorr for Weighted Compact Data using Weighted FFT implementation..."
            call Timer%tic()
            do id = 1,nd
                AutoCorrFFT(1:paddedLen,id) = getCrossCorrFFTweighted   ( nData1 = np                   &
                                                                        , nData2 = np                   &
                                                                        , paddedLen = paddedLen         &
                                                                        , Data1 = NormedData(1:np,id)   &
                                                                        , Data2 = NormedData(1:np,id)   &
                                                                        , Weight1 = Weight(1:np)        &
                                                                        , Weight2 = Weight(1:np)        &
                                                                        )
                AutoCorrFFT(1:paddedLen,id) = AutoCorrFFT(1:paddedLen,id) / AutoCorrFFT(1,id)
                ! ensure NormedData does not change upon entering and exiting getCrossCorrFFT()
#if defined DBG_ENABLED
                do ip = 1,np
                    if (NormedDataFFT1(ip,id)/=NormedData(ip,id)) then
                        write(*,*) "nonsense: ", NormedData(ip,id), NormedDataFFT1(ip,id)
                    end if
                end do
#endif
            end do
            call Timer%toc()
#if defined DBG_ENABLED
            write(*,*) "Done in ", Timer%Time%delta, " seconds."
#endif
            do ip = 1, paddedLen
                write(fileUnit,*) ip-1, AutoCorrFFT(ip,1)
            end do
            close(fileUnit)

            !***********************************************************************************************************************
            ! compute AutoCorr using FFT for a vector of ones
            !***********************************************************************************************************************

            ! normalize data

            nd = 1
            np = 100
            if (allocated(InputData)) deallocate(InputData)
            if (allocated(Weight)) deallocate(Weight)
            allocate(InputData(nd,np),Weight(np))
            deallocate(Mean,NormedData,NormedDataFFT1,AutoCorrFFT)
            allocate(Mean(nd),NormedData(np,nd),NormedDataFFT1(np,nd))
            InputData = 1._RK
            InputData(1,np) = .999999_RK
            Weight = 1_IK
            Mean = 0._RK
            do id = 1,nd
                do ip = 1,np
                    Mean(id) = Mean(id) + Weight(ip)*InputData(id,ip)
                end do
                Mean(id) = Mean(id) / sum(Weight)
                NormedData(1:np,id) = InputData(id,1:np) - Mean(id)
            end do
            NormedDataFFT1 = NormedData

            paddedLen = getPaddedLen(sum(Weight))
            allocate(AutoCorrFFT(paddedLen,nd))
            open(newunit=fileUnit,file=Test%outDir//"autoCorrOutputFFTIdentity.txt",status="replace")
            write(*,*) "Computing AutoCorr for Identity vector using Weighted FFT implementation..."
            call Timer%tic()
            do id = 1,nd
                AutoCorrFFT(1:paddedLen,id) = getCrossCorrFFTweighted   ( nData1 = np                   &
                                                                        , nData2 = np                   &
                                                                        , paddedLen = paddedLen         &
                                                                        , Data1 = NormedData(1:np,id)   &
                                                                        , Data2 = NormedData(1:np,id)   &
                                                                        , Weight1 = Weight(1:np)        &
                                                                        , Weight2 = Weight(1:np)        &
                                                                        )
                AutoCorrFFT(1:paddedLen,id) = AutoCorrFFT(1:paddedLen,id) / AutoCorrFFT(1,id)
                ! ensure NormedData does not change upon entering and exiting getCrossCorrFFT()
#if defined DBG_ENABLED
                do ip = 1,np
                    if (NormedDataFFT1(ip,id)/=NormedData(ip,id)) then
                        write(*,*) "nonsense: ", NormedData(ip,id), NormedDataFFT1(ip,id)
                    end if
                end do
#endif
            end do
            call Timer%toc()
#if defined DBG_ENABLED
            write(*,*) "Done in ", Timer%Time%delta, " seconds."
#endif
            do ip = 1, paddedLen
                write(fileUnit,*) ip-1, AutoCorrFFT(ip,1)
            end do
            close(fileUnit)

        end if blockFirstImage

        !Test%assertion = .true.
        !call Test%verify()
        call Test%skipping()
        call Test%finalize()

    end subroutine test_CrossCorr

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

end module Test_CrossCorr_mod


! { dg-do compile }
!
! Testcases from PR32002.
!
PROGRAM test_pr32002

  CALL test_1()                       ! scalar/vector
  CALL test_2()                       ! vector/vector
  CALL test_3()                       ! matrix/vector
  CALL test_4()                       ! matrix/matrix

CONTAINS
  ELEMENTAL FUNCTION f(x)
    INTEGER, INTENT(in) :: x
    INTEGER :: f
    f = x
  END FUNCTION

  SUBROUTINE test_1()
    INTEGER :: a = 0, b(2) = 0
    a = f(b)                          ! { dg-error "Incompatible ranks" }
    b = f(a)                          ! ok, set all array elements to f(a)
  END SUBROUTINE

  SUBROUTINE test_2()
    INTEGER :: a(2) = 0, b(3) = 0
    a = f(b)                          ! { dg-error "Different shape" }
    a = f(b(1:2))                     ! ok, slice, stride 1
    a = f(b(1:3:2))                   ! ok, slice, stride 2
  END SUBROUTINE

  SUBROUTINE test_3()
    INTEGER :: a(4) = 0, b(2,2) = 0
    a = f(b)                          ! { dg-error "Incompatible ranks" }
    a = f(RESHAPE(b, (/ 4 /)))        ! ok, same shape
  END SUBROUTINE

  SUBROUTINE test_4()
    INTEGER :: a(2,2) = 0, b(3,3) = 0
    a = f(b)                          ! { dg-error "Different shape" }
    a = f(b(1:3, 1:2))                ! { dg-error "Different shape" }
    a = f(b(1:3:2, 1:3:2))            ! ok, same shape
  END SUBROUTINE
END PROGRAM