!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!                                                                                !!
!!  This file is part of SciFT project                                               !!
!!  Copyright (c) 2013-2015 Nestor F. Aguirre (nfaguirrec@gmail.com)                 !!
!!                                                                                !!
!!  Redistribution and use in source and binary forms, with or without               !!
!!  modification, are permitted provided that the following conditions are met:      !!
!!                                                                                !!
!!  1. Redistributions of source code must retain the above copyright notice, this   !!
!!     list of conditions and the following disclaimer.                              !!
!!  2. Redistributions in binary form must reproduce the above copyright notice,     !!
!!     this list of conditions and the following disclaimer in the documentation     !!
!!     and/or other materials provided with the distribution.                        !!
!!  3. Neither the name of the copyright holders nor the names of its contributors   !!
!!     may be used to endorse or promote products derived from this software         !!
!!     without specific prior written permission.                                    !!
!!                                                                                !!
!!  The copyright holders provide no reassurances that the source code provided      !!
!!  does not infringe any patent, copyright, or any other intellectual property      !!
!!  rights of third parties.  The copyright holders disclaim any liability to any    !!
!!  recipient for claims brought against recipient by any third party for            !!
!!  infringement of that parties intellectual property rights.                       !!
!!                                                                                !!
!!  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND  !!
!!  ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED    !!
!!  WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE           !!
!!  DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR  !!
!!  ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES   !!
!!  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;     !!
!!  LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND      !!
!!  ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT       !!
!!  (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS    !!
!!  SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.                     !!
!!                                                                                !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

module FourierTransform2D_
	use FFTW3_
	use GOptions_
	use Math_
	use Grid2D_
	use CNFunction2D_
	use RNFunction2D_
	use RandomUtils_
	use FourierTransform_
	implicit none
	private

	public :: &
		FourierTransform2D_omegaGrid, &
		FourierTransform2D_xyGrid, &
		FourierTransform2D_phase, &
		FourierTransform2D_iphase, &
		FourierTransform2D_shift, &
		FourierTransform2D_ishift, &
		FourierTransform2D_plan, &
		FourierTransform2D_execute, &
		FourierTransform2D_destroyPlan, &
		FourierTransform2D_dft, &
		FourierTransform2D_idft, &
		FourierTransform2D_fft, &
		FourierTransform2D_ifft, &
		FourierTransform2D_nft, &
		FourierTransform2D_inft, &
		FourierTransform2D_test

	type, public :: FourierTransform2D
		class(CNFunction2D), pointer, private :: iFunc
		integer(8), private :: planF, planB

		integer :: nPoints(2)
		type(Grid2D) :: x
		type(Grid2D) :: omega

		contains
			procedure :: init
			final :: destroy
			procedure :: str
			procedure :: show
			procedure :: execute
! 			procedure :: filter
	end type FourierTransform2D

    interface FourierTransform2D_omegaGrid
		module procedure FourierTransform2D_omegaGridFromData
		module procedure FourierTransform2D_omegaGridFromXGrid
    end interface FourierTransform2D_omegaGrid

    interface FourierTransform2D_xyGrid
		module procedure FourierTransform2D_xyGridFromData
		module procedure FourierTransform2D_xyGridFromOmegaGrid
    end interface FourierTransform2D_xyGrid

    interface FourierTransform2D_phase
        module procedure FourierTransform2D_phase_realArray
        module procedure FourierTransform2D_phase_complexArray
        module procedure FourierTransform2D_phase_RNFunction2D
        module procedure FourierTransform2D_phase_CNFunction2D
    end interface FourierTransform2D_phase

    interface FourierTransform2D_iphase
        module procedure FourierTransform2D_iphase_realArray
        module procedure FourierTransform2D_iphase_complexArray
        module procedure FourierTransform2D_iphase_CNFunction2D
    end interface FourierTransform2D_iphase

    interface FourierTransform2D_shift
        module procedure FourierTransform2D_shift_realArray
        module procedure FourierTransform2D_shift_complexArray
        module procedure FourierTransform2D_shift_Grid
        module procedure FourierTransform2D_shift_RNFunction2D
        module procedure FourierTransform2D_shift_CNFunction2D
    end interface FourierTransform2D_shift

    interface FourierTransform2D_ishift
        module procedure FourierTransform2D_ishift_realArray
        module procedure FourierTransform2D_ishift_complexArray
        module procedure FourierTransform2D_ishift_Grid
        module procedure FourierTransform2D_ishift_CNFunction2D
    end interface FourierTransform2D_ishift

    interface FourierTransform2D_plan
        module procedure FourierTransform2D_plan_Array
        module procedure FourierTransform2D_plan_CNFunction2D
    end interface FourierTransform2D_plan

    interface FourierTransform2D_dft
        module procedure FourierTransform2D_dft_CArray
    end interface FourierTransform2D_dft

    interface FourierTransform2D_idft
        module procedure FourierTransform2D_idft_Array
    end interface FourierTransform2D_idft

    interface FourierTransform2D_fft
        module procedure FourierTransform2D_fft_CNFunction2D
    end interface FourierTransform2D_fft

    interface FourierTransform2D_ifft
        module procedure FourierTransform2D_ifft_CNFunction2D
    end interface FourierTransform2D_ifft

    interface FourierTransform2D_nft
        module procedure FourierTransform2D_nft_CNFunction2D
    end interface FourierTransform2D_nft

    interface FourierTransform2D_inft
        module procedure FourierTransform2D_inft_CNFunction2D
    end interface FourierTransform2D_inft

	contains

	!>
	!! @brief Constructor
	!! @todo En algunas ocasiones es importante hacer la transfomada de no todos los puntos
	!!
	subroutine init( this, iFunc, domain, oFunc )
		class(FourierTransform2D) :: this
		class(CNFunction2D), target, intent(in) :: iFunc
		integer(8), intent(in), optional :: domain
		class(CNFunction2D), target, optional, intent(in) :: oFunc

		integer(8) :: effDomain

		integer :: nx, ny

		if( associated(this.iFunc) ) nullify(this.iFunc)
		this.iFunc => iFunc
		this.nPoints = iFunc.nPoints() ! << Hay que cambiar para hacer la transformada de algunos puntos

		nx = this.nPoints(1)
		ny = this.nPoints(2)

		effDomain = FourierTransform_SPATIAL_DOMAIN
		if( present(domain) ) effDomain = domain

		if( present(oFunc) ) call GOptions_error( "oFunc parameter is not implamented yet", "FourierTransform2D.init()" )

		call dfftw_plan_dft_2d( this.planF, nx, ny, this.iFunc.fArray, this.iFunc.fArray, FFTW_FORWARD, FFTW_ESTIMATE )
		call dfftw_plan_dft_2d( this.planB, nx, ny, this.iFunc.fArray, this.iFunc.fArray, FFTW_BACKWARD, FFTW_ESTIMATE )

		if( effDomain == FourierTransform_SPATIAL_DOMAIN ) then

			this.x = this.iFunc.xyGrid ! << Hay que cambiar para hacer la transformada de algunos puntos
			this.omega = FourierTransform2D_omegaGrid( this.x )

		else if( effDomain == FourierTransform_FREQUENCY_DOMAIN ) then

			call GOptions_warning( "FourierTransform_FREQUENCY_DOMAIN have not been tested yet", "FourierTransform.init()" )
			this.omega = this.iFunc.xyGrid ! << Hay que cambiar para hacer la transformada de algunos puntos
			this.x = FourierTransform2D_xyGrid( this.omega )

		end if
	end subroutine init

	!>
	!! @brief Destructor
	!!
	subroutine destroy( this )
		type(FourierTransform2D) :: this

		! Si los activo el programa produce:
		! 	forrtl: error (76): Abort trap signal
! 		call dfftw_destroy_plan( this.planF )
! 		call dfftw_destroy_plan( this.planB )

		nullify(this.iFunc)

		this.nPoints = -1
	end subroutine destroy

	!>
	!! @brief
	!!
	function str( this ) result( output )
		class(FourierTransform2D) :: this
		character(len=200) :: output

		integer :: fmt
		character(len=200) :: strBuffer

		output = ""

		output = trim(output)//"<FourierTransform2D:"

! 		output = trim(output)//"min="
! 		fmt = int(log10(this.min+1.0))+1
! 		write(strBuffer, "(f<fmt+7>.6)") this.min
! 		output = trim(output)//trim(strBuffer)
!
! 		output = trim(output)//",max="
! 		fmt = int(log10(this.max+1.0))+1
! 		write(strBuffer, "(f<fmt+7>.6)") this.max
! 		output = trim(output)//trim(strBuffer)
!
! 		output = trim(output)//",h="
! 		fmt = int(log10(this.h+1.0))+1
! 		write(strBuffer, "(f<fmt+7>.6)") this.h
! 		output = trim(output)//trim(strBuffer)
!
! 		output = trim(output)//",size="
! 		fmt = int(log10(float(this.size+1)))+1
! 		write(strBuffer, "(i<fmt>)") this.size
! 		output = trim(output)//trim(strBuffer)

		output = trim(output)//">"
	end function str

	!>
	!! @brief
	!!
	subroutine show( this, unit )
		class(FourierTransform2D) :: this
		integer, optional, intent(in) :: unit

		integer :: effunit

		if( present(unit) ) then
			effunit = unit
		else
			effunit = 6
		end if

		write(effunit,"(a)") trim(this.str())
	end subroutine show

	!>
	!! @brief
	!!
	subroutine execute( this, sgn, sync, shift )
		class(FourierTransform2D) :: this
		integer, intent(in) :: sgn
		logical, optional, intent(in) :: sync
		logical, optional, intent(in) :: shift

		logical :: effSync
		logical :: effShift

		effSync = .false.
		if( present(sync) ) effSync = sync

		effShift = .false.
		if( present(shift) ) effShift = shift

		if( sgn == FourierTransform_FORWARD ) then

			call dfftw_execute( this.planF )

			if( effSync ) then
				this.iFunc.xyGrid = this.omega

				if( effShift ) then
					call FourierTransform2D_phase( this.iFunc )
					call FourierTransform2D_shift( this.iFunc )
				end if
			end if

		else if ( sgn == FourierTransform_BACKWARD ) then

			if( effSync ) then
				if( effShift ) then
					call FourierTransform2D_ishift( this.iFunc )
					call FourierTransform2D_phase( this.iFunc )
				end if
			end if

			call dfftw_execute( this.planB )

			if( effSync ) then
				this.iFunc.xyGrid = this.x
			end if

			this.iFunc = this.iFunc/real(this.nPoints(1)*this.nPoints(2),8)

		else
			call GOptions_error( "Bad value for sgn", "FourierTransform2D.execute()" )
		end if
	end subroutine execute

	!>
	!! @brief
	!!
	function FourierTransform2D_omegaGridFromData( n, h, order ) result( output )
		integer, intent(in) :: n(2)
		real(8), optional, intent(in) :: h(2)
		integer, optional, intent(in) :: order
		type(Grid2D) :: output

		integer :: i

		do i=1,2
			output.component(i) = FourierTransform_omegaGrid( n(i), h(i), order=order )
		end do
	end function FourierTransform2D_omegaGridFromData

	!>
	!! @brief
	!!
	function FourierTransform2D_omegaGridFromXGrid( xyGrid, order ) result( output )
		type(Grid2D), intent(in) :: xyGrid
		integer, optional, intent(in) :: order
		type(Grid2D) :: output

		output = FourierTransform2D_omegaGridFromData( xyGrid.nPointsVec(), xyGrid.stepSize(), order=order )
	end function FourierTransform2D_omegaGridFromXGrid

	!>
	!! @brief
	!!
	function FourierTransform2D_xyGridFromData( n, h, order ) result( output )
		integer, intent(in) :: n(2)
		real(8), intent(in) :: h(2)
		integer, optional, intent(in) :: order
		type(Grid2D) :: output

		integer :: i

		do i=1,2
			output.component(i) = FourierTransform_xGrid( n(i), h(i), order=order )
		end do
	end function FourierTransform2D_xyGridFromData

	!>
	!! @brief
	!!
	function FourierTransform2D_xyGridFromOmegaGrid( omegaGrid, order ) result( output )
		type(Grid2D), intent(in) :: omegaGrid
		integer, optional, intent(in) :: order
		type(Grid2D) :: output

		real(8) :: dx(2)

		! dx = 2*pi/n/dp
		dx = 2.0_8*MATH_PI/real(omegaGrid.nPoints(),8)/omegaGrid.stepSize()

		output = FourierTransform2D_xyGridFromData( omegaGrid.nPoints(), dx, order=order )
	end function FourierTransform2D_xyGridFromOmegaGrid

	!>
	!! @brief
	!!
	subroutine FourierTransform2D_phase_realArray( iArray, oArray )
		real(8) :: iArray(:,:)
		real(8), optional :: oArray(:,:)

		integer :: i

		do i=1,size(iArray,dim=1)
			call FourierTransform_phase( iArray(i,:), oArray(i,:) )
		end do

		do i=1,size(iArray,dim=2)
			call FourierTransform_phase( iArray(:,i), oArray(:,i) )
		end do
	end subroutine FourierTransform2D_phase_realArray

	!>
	!! @brief
	!!
	subroutine FourierTransform2D_phase_complexArray( iArray, oArray )
		complex(8) :: iArray(:,:)
		complex(8), optional :: oArray(:,:)

		integer :: i

		if( present(oArray) ) then
			do i=1,size(iArray,dim=1)
				call FourierTransform_phase( iArray(i,:), oArray(i,:) )
			end do

			do i=1,size(iArray,dim=2)
				call FourierTransform_phase( iArray(:,i), oArray(:,i) )
			end do
		else
			do i=1,size(iArray,dim=1)
				call FourierTransform_phase( iArray(i,:) )
			end do

			do i=1,size(iArray,dim=2)
				call FourierTransform_phase( iArray(:,i) )
			end do
		end if
	end subroutine FourierTransform2D_phase_complexArray

	!>
	!! @brief
	!!
	subroutine FourierTransform2D_iphase_realArray( iArray, oArray )
		real(8) :: iArray(:)
		real(8), optional :: oArray(:)

		stop "FourierTransform2D_iphase_realArray is not implemented"
! 		integer :: i, j, n, p2
!
! 		n = size( iArray )
! 		p2 = n-floor(n/2.0_8)
!
! 		i = 1
! 		do j=p2,n
! 			if( present(oArray) ) then
! 				oArray(i) = iArray(i)*(-1.0_8)**(j-1)
! 			else
! 				iArray(i) = iArray(i)*(-1.0_8)**(j-1)
! 			end if
!
! 			i = i+1
! 		end do
!
! 		do j=1,p2-1
! 			if( present(oArray) ) then
! 				oArray(i) = iArray(i)*(-1.0_8)**(j-1)
! 			else
! 				iArray(i) = iArray(i)*(-1.0_8)**(j-1)
! 			end if
!
! 			i = i+1
! 		end do
	end subroutine FourierTransform2D_iphase_realArray

	!>
	!! @brief
	!! @deprecated Este metodo será eliminado si no se utiliza Mon Mar  9 16:43:34 CET 2015
	!! @todo Este metodo será eliminado si no se utiliza Mon Mar  9 16:43:34 CET 2015
	!!
	subroutine FourierTransform2D_iphase_complexArray( iArray, oArray )
		complex(8) :: iArray(:)
		complex(8), optional :: oArray(:)

		stop "FourierTransform2D_iphase_complexArray is not implemented"
	end subroutine FourierTransform2D_iphase_complexArray

	!>
	!! @brief
	!!
	subroutine FourierTransform2D_phase_RNFunction2D( iFunc, oFunc )
		class(RNFunction2D) :: iFunc
		class(RNFunction2D), optional :: oFunc

		integer :: i

		if( iFunc.isEquallyspaced() ) then
			call GOptions_warning( &
				"Grid should not be equally spaced", &
				"FourierTransform2D_phase_RNFunction2D()" &
			)
		end if

		if( present(oFunc) ) then
			oFunc = iFunc

			do i=1,iFunc.nPoints(1)
				call FourierTransform_phase( oFunc.fArray(i,:) )
			end do

			do i=1,iFunc.nPoints(2)
				call FourierTransform_phase( oFunc.fArray(:,i) )
			end do
		else
			do i=1,iFunc.nPoints(1)
				call FourierTransform_phase( iFunc.fArray(i,:) )
			end do

			do i=1,iFunc.nPoints(2)
				call FourierTransform_phase( iFunc.fArray(:,i) )
			end do
		end if
	end subroutine FourierTransform2D_phase_RNFunction2D

	!>
	!! @brief
	!!
	subroutine FourierTransform2D_phase_CNFunction2D( iFunc, oFunc )
		class(CNFunction2D) :: iFunc
		class(CNFunction2D), optional :: oFunc

		integer :: i

		if( iFunc.isEquallyspaced() ) then
			call GOptions_warning( &
				"Grid should not be equally spaced", &
				"FourierTransform2D_phase_CNFunction2D()" &
			)
		end if

		if( present(oFunc) ) then
			oFunc = iFunc

			do i=1,iFunc.nPoints(1)
				call FourierTransform_phase( oFunc.fArray(i,:) )
			end do

			do i=1,iFunc.nPoints(2)
				call FourierTransform_phase( oFunc.fArray(:,i) )
			end do
		else
			do i=1,iFunc.nPoints(1)
				call FourierTransform_phase( iFunc.fArray(i,:) )
			end do

			do i=1,iFunc.nPoints(2)
				call FourierTransform_phase( iFunc.fArray(:,i) )
			end do
		end if
	end subroutine FourierTransform2D_phase_CNFunction2D

	!>
	!! @brief
	!! @deprecated Este metodo será eliminado si no se utiliza Mon Mar  9 16:43:34 CET 2015
	!! @todo Este metodo será eliminado si no se utiliza Mon Mar  9 16:43:34 CET 2015
	!!
	subroutine FourierTransform2D_iphase_CNFunction2D( iFunc, oFunc )
		class(CNFunction2D) :: iFunc
		class(CNFunction2D), optional :: oFunc

		stop "FourierTransform2D_shift_RNFunction2D is not implemented"
	end subroutine FourierTransform2D_iphase_CNFunction2D

	!>
	!! @brief
	!!
	subroutine FourierTransform2D_shift_realArray( iArray, oArray )
		real(8) :: iArray(:,:)
		real(8), optional :: oArray(:,:)

		integer :: i

		if( present(oArray) ) then
			oArray = iArray

			do i=1,size(iArray,dim=1)
				call FourierTransform_shift( oArray(i,:) )
			end do

			do i=1,size(iArray,dim=2)
				call FourierTransform_shift( oArray(:,i) )
			end do
		else
			do i=1,size(iArray,dim=1)
				call FourierTransform_shift( iArray(i,:) )
			end do

			do i=1,size(iArray,dim=2)
				call FourierTransform_shift( iArray(:,i) )
			end do
		end if
	end subroutine FourierTransform2D_shift_realArray

	!>
	!! @brief
	!!
	subroutine FourierTransform2D_shift_complexArray( iArray, oArray )
		complex(8) :: iArray(:,:)
		complex(8), optional :: oArray(:,:)

		integer :: i

		if( present(oArray) ) then
			oArray = iArray

			do i=1,size(iArray,dim=1)
				call FourierTransform_shift( oArray(i,:) )
			end do

			do i=1,size(iArray,dim=2)
				call FourierTransform_shift( oArray(:,i) )
			end do
		else
			do i=1,size(iArray,dim=1)
				call FourierTransform_shift( iArray(i,:) )
			end do

			do i=1,size(iArray,dim=2)
				call FourierTransform_shift( iArray(:,i) )
			end do
		end if
	end subroutine FourierTransform2D_shift_complexArray

	!>
	!! @brief
	!!
	subroutine FourierTransform2D_ishift_realArray( iArray, oArray )
		real(8) :: iArray(:,:)
		real(8), optional :: oArray(:,:)

		integer :: i

		if( present(oArray) ) then
			oArray = iArray

			do i=1,size(iArray,dim=1)
				call FourierTransform_ishift( oArray(i,:) )
			end do

			do i=1,size(iArray,dim=2)
				call FourierTransform_ishift( oArray(:,i) )
			end do
		else
			do i=1,size(iArray,dim=1)
				call FourierTransform_ishift( iArray(i,:) )
			end do

			do i=1,size(iArray,dim=2)
				call FourierTransform_ishift( iArray(:,i) )
			end do
		end if
	end subroutine FourierTransform2D_ishift_realArray

	!>
	!! @brief
	!!
	subroutine FourierTransform2D_ishift_complexArray( iArray, oArray )
		complex(8) :: iArray(:,:)
		complex(8), optional :: oArray(:,:)

		integer :: i

		if( present(oArray) ) then
			oArray = iArray

			do i=1,size(iArray,dim=1)
				call FourierTransform_ishift( oArray(i,:) )
			end do

			do i=1,size(iArray,dim=2)
				call FourierTransform_ishift( oArray(:,i) )
			end do
		else
			do i=1,size(iArray,dim=1)
				call FourierTransform_ishift( iArray(i,:) )
			end do

			do i=1,size(iArray,dim=2)
				call FourierTransform_ishift( iArray(:,i) )
			end do
		end if
	end subroutine FourierTransform2D_ishift_complexArray

	!>
	!! @brief
	!!
	subroutine FourierTransform2D_shift_Grid( iGrid, oGrid )
		class(Grid2D) :: iGrid
		class(Grid2D), optional :: oGrid

		integer :: i

		if( iGrid.isEquallyspaced() ) then
			call GOptions_warning( &
				"Grid should not be equally spaced", &
				"FourierTransform2D_shift_Grid()" &
			)
		end if

		if( present(oGrid) ) then
			oGrid = iGrid

			do i=1,2
				call FourierTransform_shift( oGrid.component(i) )
			end do
		else
			do i=1,2
				call FourierTransform_shift( iGrid.component(i) )
			end do
		end if

	end subroutine FourierTransform2D_shift_Grid

	!>
	!! @brief
	!!
	subroutine FourierTransform2D_ishift_Grid( iGrid, oGrid )
		class(Grid2D) :: iGrid
		class(Grid2D), optional :: oGrid

		integer :: i

		if( .not. iGrid.isEquallyspaced() ) then
			call GOptions_warning( &
				"Grid should be equally spaced", &
				"FourierTransform2D_ishift_Grid()" &
			)
		end if

		if( present(oGrid) ) then
			oGrid = iGrid

			do i=1,2
				call FourierTransform_ishift( oGrid.component(i) )
			end do
		else
			do i=1,2
				call FourierTransform_ishift( iGrid.component(i) )
			end do
		end if

	end subroutine FourierTransform2D_ishift_Grid

	!>
	!! @brief
	!!
	subroutine FourierTransform2D_shift_RNFunction2D( iFunc, oFunc )
		class(RNFunction2D) :: iFunc
		class(RNFunction2D), optional :: oFunc

		stop "FourierTransform2D_shift_RNFunction2D is not implemented"
		if( iFunc.isEquallyspaced() ) then
			call GOptions_warning( &
				"Grid should not be equally spaced", &
				"FourierTransform2D_shift_Grid()" &
			)
		end if

		if( present(oFunc) ) then
			oFunc = iFunc

			call FourierTransform2D_shift_realArray( oFunc.fArray )
			call FourierTransform2D_shift( oFunc.xyGrid )
			call oFunc.xyGrid.checkEquallyspaced()
		else
			call FourierTransform2D_shift_realArray( iFunc.fArray )
			call FourierTransform2D_shift( iFunc.xyGrid )
			call iFunc.xyGrid.checkEquallyspaced()
		end if

	end subroutine FourierTransform2D_shift_RNFunction2D

	!>
	!! @brief
	!!
	subroutine FourierTransform2D_shift_CNFunction2D( iFunc, oFunc )
		class(CNFunction2D) :: iFunc
		class(CNFunction2D), optional :: oFunc

		integer :: i

		if( iFunc.isEquallyspaced() ) then
			call GOptions_warning( &
				"Grid should not be equally spaced", &
				"FourierTransform2D_shift_Grid()" &
			)
		end if

		if( present(oFunc) ) then
			oFunc = iFunc

			do i=1,iFunc.nPoints(1)
				call FourierTransform_shift( oFunc.fArray(i,:) )
			end do

			do i=1,iFunc.nPoints(2)
				call FourierTransform_shift( oFunc.fArray(:,i) )
			end do

			call FourierTransform2D_shift( oFunc.xyGrid )
		else
			do i=1,iFunc.nPoints(1)
				call FourierTransform_shift( iFunc.fArray(i,:) )
			end do

			do i=1,iFunc.nPoints(2)
				call FourierTransform_shift( iFunc.fArray(:,i) )
			end do

			call FourierTransform2D_shift( iFunc.xyGrid )
		end if

	end subroutine FourierTransform2D_shift_CNFunction2D

	!>
	!! @brief
	!!
	subroutine FourierTransform2D_ishift_CNFunction2D( iFunc, oFunc )
		class(CNFunction2D) :: iFunc
		class(CNFunction2D), optional :: oFunc

		integer :: i

		if( .not. iFunc.isEquallyspaced() ) then
			call GOptions_warning( &
				"Grid should be equally spaced", &
				"FourierTransform2D_ishift_Grid()" &
			)
		end if

		if( present(oFunc) ) then
			oFunc = iFunc

			do i=1,iFunc.nPoints(1)
				call FourierTransform_ishift( oFunc.fArray(i,:) )
			end do

			do i=1,iFunc.nPoints(2)
				call FourierTransform_ishift( oFunc.fArray(:,i) )
			end do

			call FourierTransform2D_ishift( oFunc.xyGrid )
		else
			do i=1,iFunc.nPoints(1)
				call FourierTransform_ishift( iFunc.fArray(i,:) )
			end do

			do i=1,iFunc.nPoints(2)
				call FourierTransform_ishift( iFunc.fArray(:,i) )
			end do

			call FourierTransform2D_ishift( iFunc.xyGrid )
		end if

	end subroutine FourierTransform2D_ishift_CNFunction2D

	!>
	!! @brief
	!!
	function FourierTransform2D_plan_Array( iArray, sgn, oArray ) result( plan )
		complex(8) :: iArray(:,:)
		integer, intent(in) :: sgn
		complex(8), optional :: oArray(:,:)
		integer(8) :: plan

		if( present(oArray) ) then
			call dfftw_plan_dft_2d( plan, size(iArray), iArray, oArray, sgn, FFTW_ESTIMATE )
		else
			call dfftw_plan_dft_2d( plan, size(iArray), iArray, iArray, sgn, FFTW_ESTIMATE )
		end if
	end function FourierTransform2D_plan_Array

	!>
	!! @brief
	!!
	function FourierTransform2D_plan_CNFunction2D( iFunc, sgn, oFunc ) result( plan )
		type(CNFunction2D) :: iFunc
		integer, intent(in) :: sgn
		type(CNFunction2D), optional :: oFunc
		integer(8) :: plan

		if( present(oFunc) ) then
			call dfftw_plan_dft_2d( plan, iFunc.nPoints(1), iFunc.nPoints(2), iFunc.fArray, oFunc.fArray, sgn, FFTW_ESTIMATE )
		else
			call dfftw_plan_dft_2d( plan, iFunc.nPoints(1), iFunc.nPoints(2), iFunc.fArray, iFunc.fArray, sgn, FFTW_ESTIMATE )
		end if
	end function FourierTransform2D_plan_CNFunction2D

	!>
	!!
	!!
	subroutine FourierTransform2D_execute( plan )
		integer(8), intent(in) :: plan

		call dfftw_execute( plan )
	end subroutine FourierTransform2D_execute

	!>
	!!
	!!
	subroutine FourierTransform2D_destroyPlan( plan )
		integer(8), intent(in) :: plan

		call dfftw_destroy_plan( plan )
	end subroutine FourierTransform2D_destroyPlan

	!>
	!!
	!!
	subroutine FourierTransform2D_dft_CArray( iArray, oArray, sgn )
		complex(8) :: iArray(:,:)
		complex(8), optional :: oArray(:,:)
		integer, optional :: sgn

		integer :: effSgn

		integer(8) :: plan

		effSgn = FourierTransform_FORWARD
		if( present(sgn) ) effSgn = sgn

		if( present(oArray) ) then
			if( size(iArray) /= size(oArray) ) &
				call GOptions_error( "iArray and oArray have not the same size", "FourierTransform2D_dft_CArray" )

			call dfftw_plan_dft_2d( plan, size(iArray,dim=1), size(iArray,dim=2), iArray, oArray, effSgn, FFTW_ESTIMATE )
			call dfftw_execute( plan )
		else
			call dfftw_plan_dft_2d( plan, size(iArray,dim=1), size(iArray,dim=2), iArray, iArray, effSgn, FFTW_ESTIMATE )
			call dfftw_execute( plan )
		end if

		call dfftw_destroy_plan( plan )
	end subroutine FourierTransform2D_dft_CArray

	!>
	!!
	!!
	subroutine FourierTransform2D_idft_Array( iArray, oArray, sgn )
		complex(8) :: iArray(:)
		complex(8), optional :: oArray(:)
		integer, optional :: sgn

		stop "FourierTransform2D_idft_Array is not implemented"
! 		integer :: effSgn
!
! 		integer(8) :: plan
!
! 		effSgn = FourierTransform2D_BACKWARD
! 		if( present(sgn) ) effSgn = sgn
!
! 		if( present(oArray) ) then
! 			if( size(iArray) /= size(oArray) ) &
! 				call GOptions_error( "iArray and oArray have not the same size", "FourierTransform2D_idft_Array" )
!
! 			call dfftw_plan_dft_1d( plan, size(iArray), iArray, oArray, effSgn, FourierTransform2DW_ESTIMATE )
! 			call dfftw_execute( plan )
!
! 			oArray = oArray/real( size(iArray), 8 )
! 		else
! 			call dfftw_plan_dft_1d( plan, size(iArray), iArray, iArray, effSgn, FourierTransform2DW_ESTIMATE )
! 			call dfftw_execute( plan )
!
! 			iArray = iArray/real( size(iArray), 8 )
! 		end if
!
! 		call dfftw_destroy_plan( plan )
	end subroutine FourierTransform2D_idft_Array

	!>
	!!
	!!
	function FourierTransform2D_fft_CNFunction2D( iFunc, sgn ) result( oFunc )
		type(CNFunction2D), intent(in) :: iFunc
		integer, optional :: sgn
		type(CNFunction2D) :: oFunc

		integer :: n(2)
		real(8) :: dx(2), dp(2)
		type(Grid2D) :: xyGrid

		! @todo Check for checkEquallyspaced
		n = iFunc.nPoints()
		dx = iFunc.xyGrid.stepSize()
		dp = 2.0_8*Math_PI/dx/real(n,8)

		oFunc = iFunc
		call FourierTransform2D_dft( iFunc.fArray, oFunc.fArray, sgn=sgn )
		oFunc.xyGrid = FourierTransform2D_omegaGrid( n, dx, order=FourierTransform_SORDER )

		call FourierTransform2D_phase( oFunc )
		call FourierTransform2D_shift( oFunc )

		oFunc = oFunc*dx(1)*dx(2)/(2.0_8*Math_PI)
	end function FourierTransform2D_fft_CNFunction2D

	!>
	!!
	!!
	function FourierTransform2D_ifft_CNFunction2D( iFunc, sgn ) result( oFunc )
		type(CNFunction2D) :: iFunc
		integer, optional :: sgn
		type(CNFunction2D) :: oFunc

		integer :: n(2)
		real(8) :: dx(2), dp(2)
		type(Grid2D) :: xyGrid

		integer :: i

		! @todo Check for checkEquallyspaced
		n = iFunc.nPoints()
		dp = iFunc.xyGrid.stepSize()
		dx = 2.0_8*Math_PI/dp/real(n,8)

		oFunc = iFunc

		call FourierTransform2D_ishift( oFunc )
		call FourierTransform2D_phase( oFunc )

		call FourierTransform2D_dft( oFunc.fArray, oFunc.fArray, sgn=FourierTransform_BACKWARD )
		oFunc.xyGrid = FourierTransform2D_xyGrid( n, dx, order=FourierTransform_NORDER )

		oFunc = oFunc*dp(1)*dp(2)/(2.0_8*Math_PI)
	end function FourierTransform2D_ifft_CNFunction2D

	!>
	!! @brief
	!!
	function FourierTransform2D_nft_CNFunction2D( iFunc, sgn ) result( oFunc )
		type(CNFunction2D), intent(in) :: iFunc
		integer, optional, intent(in) :: sgn
		type(CNFunction2D) :: oFunc

		integer :: effSgn

		integer :: i, j, k, l, n(2)
		real(8) :: dx(2), dp(2)
		type(Grid2D) :: xyGrid

		effSgn = FourierTransform_FORWARD
		if( present(sgn) ) effSgn = sgn

		! @todo Check for checkEquallyspaced
		n = iFunc.nPoints()
		dx = iFunc.xyGrid.stepSize()
		dp = 2.0_8*Math_PI/dx/real(n,8)

		oFunc = iFunc
		oFunc.xyGrid = FourierTransform2D_omegaGrid( n, dx, order=FourierTransform_NORDER )
		call oFunc.xyGrid.show()

		do j=1,n(2); do i=1,n(1)
			oFunc.fArray(i,j) = 0.0_8
			do l=1,n(2); do k=1,n(1)
				oFunc.fArray(i,j) = oFunc.fArray(i,j) &
					+ iFunc.fArray(k,l)*exp( real(effSgn,8)*Math_I*sum( iFunc.xyGrid.at(k,l)*oFunc.xyGrid.at(i,j) ) )
			end do; end do
		end do; end do

		oFunc = oFunc*dx(1)*dx(2)/(2.0_8*Math_PI)
	end function FourierTransform2D_nft_CNFunction2D

	!>
	!! @brief
	!!
	function FourierTransform2D_inft_CNFunction2D( iFunc, sgn ) result( oFunc )
		type(CNFunction2D), intent(in) :: iFunc
		integer, optional, intent(in) :: sgn
		type(CNFunction2D) :: oFunc

		integer :: effSgn

		integer :: i, j, k, l, n(2)
		real(8) :: dx(2), dp(2)
		type(Grid2D) :: xyGrid

		effSgn = FourierTransform_BACKWARD
		if( present(sgn) ) effSgn = sgn

		! @todo Check for checkEquallyspaced
		n = iFunc.nPoints()
		dp = iFunc.xyGrid.stepSize()
		dx = 2.0_8*Math_PI/dp/real(n,8)

		oFunc = iFunc
		oFunc.xyGrid = FourierTransform2D_xyGrid( n, dx, order=FourierTransform_NORDER )

		do j=1,n(2); do i=1,n(1)
			oFunc.fArray(i,j) = 0.0_8
			do l=1,n(2); do k=1,n(1)
				oFunc.fArray(i,j) = oFunc.fArray(i,j) &
					+ iFunc.fArray(k,l)*exp( real(effSgn,8)*Math_I*sum( iFunc.xyGrid.at(k,l)*oFunc.xyGrid.at(i,j) ) )
			end do; end do
		end do; end do

		oFunc = oFunc*dp(1)*dp(2)/(2.0_8*Math_PI)
	end function FourierTransform2D_inft_CNFunction2D

	!>
	!! This is neccesary only for FourierTransform2D_test()
	!!
	function funcRectangular( x, y ) result( output )
		real(8), intent(in) :: x, y
		complex(8) :: output

		real(8) :: a1, a2

		a1 = 0.5_8
		a2 = 1.0_8

		output = Math_ubox( a1*x )*Math_ubox( a2*y )
	end function funcRectangular

	!>
	!! This is neccesary only for FourierTransform2D_test()
	!!
	function FfuncRectangular( omega1, omega2 ) result( output )
		real(8), intent(in) :: omega1, omega2
		complex(8) :: output

		real(8) :: a1, a2

		a1 = 0.5_8
		a2 = 1.0_8

		output = Math_nsinc( omega1/(2.0_8*Math_PI*a1) )*Math_nsinc( omega2/(2.0_8*Math_PI*a2) )/(2.0_8*Math_PI)/a1/a2
	end function FfuncRectangular

	!>
	!! @bief test
	!!
	subroutine FourierTransform2D_test()
		type(Grid2D) :: xyGrid, omegaGrid
		type(CNFunction2D) :: funcA, dFuncA, fftFuncA, fftDFuncA
		type(CNFunction2D) :: funcB, dFuncB, fftFuncB, fftDFuncB
		type(CNFunction2D) :: funcAB, dFuncAB, fftFuncAB, fftDFuncAB
		type(RNFunction2D) :: aSpectrum, pSpectrum
		type(FourierTransform2D) :: fft
		real(8) :: exactValue
		real(8) :: value
		integer :: i, j
		real(8), allocatable :: array(:,:)
		complex(8), allocatable :: cArray(:,:)
		integer(8) :: planF, planB
		character :: cBuffer

		write(*,*) "----------------------------------"
		write(*,*) " Verifing omega Grid constructors "
		write(*,*) "----------------------------------"

		xyGrid = FourierTransform2D_omegaGridFromData( [10,11], [0.1_8,0.2_8], FourierTransform_NORDER )
		call xyGrid.show()
		call xyGrid.save()

		xyGrid = FourierTransform2D_omegaGridFromData( [10,11], [0.1_8,0.2_8], FourierTransform_SORDER )
		call xyGrid.show()
		call xyGrid.save()

		write(*,*) "-------------------------------"
		write(*,*) " Verifing xy Grid constructors "
		write(*,*) "-------------------------------"

		xyGrid = FourierTransform2D_xyGridFromData( [10,11], [0.1_8,0.2_8], FourierTransform_NORDER )
		call xyGrid.show()
		call xyGrid.save()

		xyGrid = FourierTransform2D_xyGridFromData( [10,11], [0.1_8,0.2_8], FourierTransform_SORDER )
		call xyGrid.show()
		call xyGrid.save()

		return
		call GOptions_doYouWantToContinue()

! 		write(*,*) "-------------------------------------------"
! 		write(*,*) " FourierTransform2D of a gaussian function "
! 		write(*,*) "-------------------------------------------"
!
! 		call xyGrid.init( [-2.5_8,-2.5_8], [2.5_8,2.5_8], size=[90,110] )
! 		call funcA.init( xyGrid, funcRectangular )
! 		write(*,"(A)") "input (.func) = "
! 		call funcA.show()
! 		call funcA.save( ".func", format=BLKS_FORMAT )
!
! 		funcB = FourierTransform2D_fft( funcA )
! 		write(*,"(A)") "exact (.Ffunc) = "
! 		call funcB.show()
! 		call funcB.save( ".Ffunc", format=BLKS_FORMAT )
!
! 		call xyGrid.init( [-54.677675_8,-67.241507_8], [55.920349_8,68.486720_8], size=[90,110] )
! 		call funcB.init( xyGrid, FfuncRectangular )
! ! 		funcB = FourierTransform2D_nft( funcA )
! 		write(*,"(A)") "exact (.Fexact) = "
! 		call funcB.show()
! 		call funcB.save( ".Fexact", format=BLKS_FORMAT )
!
! ! 		call system( "echo splot \"//achar(34)//".func\"//achar(34)//" u 1:2:3 w l, \"//achar(34)//"\"//achar(34)//" u 1:2:4 w l | gnuplot -p" )
! ! 		call system( "echo splot \"//achar(34)//".Ffunc\"//achar(34)//" u 1:2:3 w l, \"//achar(34)//"\"//achar(34)//" u 1:2:4 w l | gnuplot -p" )
! ! 		call system( "echo splot \"//achar(34)//".Fexact\"//achar(34)//" u 1:2:3 w l, \"//achar(34)//"\"//achar(34)//" u 1:2:4 w l | gnuplot -p" )
! 		call system( "echo splot \"//achar(34)//".func\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
! 		call system( "echo splot \"//achar(34)//".Ffunc\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
! 		call system( "echo splot \"//achar(34)//".Fexact\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
! 		call GOptions_doYouWantToContinue()
! 		call system( "rm .func .Ffunc .Fexact" )

! 		write(*,*) "-----------------------------"
! 		write(*,*) " iFourierTransform2D of a gaussian function"
! 		write(*,*) "-----------------------------"
!
! 		call xyGrid.init( [-2.5_8,-2.5_8], [2.5_8,2.5_8], size=[90,110] )
! 		call funcA.init( xyGrid, funcRectangular )
! 		funcA = FourierTransform2D_nft( funcA )
! 		write(*,"(A)") "input (.Ffunc) = "
! 		call funcA.show()
! 		call funcA.save( ".Ffunc", format=BLKS_FORMAT )
!
! 		write(*,"(A)") "iFourierTransform2D (.func) = "
! 		funcB = funcA
! 		funcB = FourierTransform2D_ifft( funcB )
! 		call funcB.show()
! 		call funcB.save( ".func", format=BLKS_FORMAT )
!
! 		funcB = FourierTransform2D_inft( funcA )
! 		write(*,"(A)") "exact (.exact) = "
! 		call funcB.show()
! 		call funcB.save( ".exact", format=BLKS_FORMAT )
!
! ! 		call system( "echo splot \"//achar(34)//".Ffunc\"//achar(34)//" u 1:2:3 w l, \"//achar(34)//"\"//achar(34)//" u 1:2:4 w l | gnuplot -p" )
! ! 		call system( "echo splot \"//achar(34)//".func\"//achar(34)//" u 1:2:3 w l, \"//achar(34)//"\"//achar(34)//" u 1:2:4 w l | gnuplot -p" )
! ! 		call system( "echo splot \"//achar(34)//".exact\"//achar(34)//" u 1:2:3 w l, \"//achar(34)//"\"//achar(34)//" u 1:2:4 w l | gnuplot -p" )
! 		call system( "echo splot \"//achar(34)//".Ffunc\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
! 		call system( "echo splot \"//achar(34)//".func\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
! 		call system( "echo splot \"//achar(34)//".exact\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
! 		call GOptions_doYouWantToContinue()
! 		call system( "rm .Ffunc .func .exact" )

! 		write(*,*) "-------------------------------"
! 		write(*,*) " iFourierTransform2D( FourierTransform2D(func) ). CNFunction2D "
! 		write(*,*) "-------------------------------"
!
! 		call xyGrid.init( [-2.5_8,-2.5_8], [2.5_8,2.5_8], size=[90,110] )
! 		call funcA.init( xyGrid, funcRectangular )
!
! 		write(*,"(A)") "input (.func) = "
! 		call funcA.show()
! 		call funcA.save( ".func", format=BLKS_FORMAT )
!
! 		write(*,"(A)") "FourierTransform2D (.Ffunc) = "
! 		funcB = FourierTransform2D_fft( funcA )
! 		call funcB.show()
! 		call funcB.save( ".Ffunc", format=BLKS_FORMAT )
!
! 		write(*,"(A)") "iFourierTransform2D (.iFFfunc) = "
! 		funcA = FourierTransform2D_ifft( funcB )
! 		call funcA.show()
! 		call funcA.save( ".iFFfunc", format=BLKS_FORMAT )
!
! ! 		call system( "echo splot \"//achar(34)//".func\"//achar(34)//" u 1:2:3 w l, \"//achar(34)//"\"//achar(34)//" u 1:2:4 w l | gnuplot -p" )
! ! 		call system( "echo splot \"//achar(34)//".Ffunc\"//achar(34)//" u 1:2:3 w l, \"//achar(34)//"\"//achar(34)//" u 1:2:4 w l | gnuplot -p" )
! ! 		call system( "echo splot \"//achar(34)//".iFFfunc\"//achar(34)//" u 1:2:3 w l, \"//achar(34)//"\"//achar(34)//" u 1:2:4 w l | gnuplot -p" )
! 		call system( "echo splot \"//achar(34)//".func\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
! 		call system( "echo splot \"//achar(34)//".Ffunc\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
! 		call system( "echo splot \"//achar(34)//".iFFfunc\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
! 		call GOptions_doYouWantToContinue()
! 		call system( "rm .func .Ffunc .iFFfunc" )

! 		write(*,*) "--------------------------------"
! 		write(*,*) " FourierTransform2D( iFourierTransform2D(Ffunc) ). CNFunction2D "
! 		write(*,*) "--------------------------------"
!
! 		call xyGrid.init( [-2.5_8,-2.5_8], [2.5_8,2.5_8], size=[90,110] )
! 		call funcA.init( xyGrid, funcRectangular )
! 		funcA = FourierTransform2D_nft( funcA )
!
! 		write(*,"(A)") "input (.Ffunc) = "
! 		call funcA.show()
! 		call funcA.save( ".Ffunc", format=BLKS_FORMAT )
!
! 		write(*,"(A)") "iFourierTransform2D (.iFfunc) = "
! 		funcA = FourierTransform2D_ifft( funcA )
! 		call funcA.show()
! 		call funcA.save( ".iFfunc", format=BLKS_FORMAT )
!
! 		write(*,"(A)") "FourierTransform2D (.FiFfunc) = "
! 		funcA = FourierTransform2D_fft( funcA )
! 		call funcA.show()
! 		call funcA.save( ".FiFfunc", format=BLKS_FORMAT )
!
! 		call system( "echo splot \"//achar(34)//".Ffunc\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
! 		call system( "echo splot \"//achar(34)//".iFfunc\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
! 		call system( "echo splot \"//achar(34)//".FiFfunc\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
! 		call GOptions_doYouWantToContinue()
! 		call system( "rm .Ffunc .iFfunc .FiFfunc" )

		write(*,*) "-----------------------------------------------------"
		write(*,*) " Verifing FourierTransform2D CNFunction2D with plans "
		write(*,*) "-----------------------------------------------------"

		call xyGrid.init( [-2.5_8,-2.5_8], [2.5_8,2.5_8], size=[90,110] )
		call funcA.init( xyGrid, funcRectangular )
		write(*,"(A)") "input (.func) = "
		call funcA.show()
		call funcA.save( ".func", format=BLKS_FORMAT )

		planF = FourierTransform2D_plan( funcA, FourierTransform_FORWARD )
		planB = FourierTransform2D_plan( funcA, FourierTransform_BACKWARD )

		write(*,"(A)") "FourierTransform2D (.Ffunc) = "
		call FourierTransform2D_execute( planF )
		funcA.xyGrid = FourierTransform2D_omegaGrid( funcA.xyGrid, order=FourierTransform_SORDER )
		call FourierTransform2D_phase( funcA )
		call FourierTransform2D_shift( funcA )
		write(*,*) "Entonces 0", xyGrid.stepSize(1)*xyGrid.stepSize(2)/(2.0_8*Math_PI)
		value = xyGrid.stepSize(1)*xyGrid.stepSize(2)/(2.0_8*Math_PI)
		funcA = funcA*value
		write(*,*) "Entonces 1"
		call funcA.show()
		call funcA.save( ".Ffunc", format=BLKS_FORMAT )

! 		write(*,"(A)") "iFourierTransform2D (.iFFfunc) = "
! 		call FourierTransform2D_ishift( funcA )
! 		call FourierTransform2D_phase( funcA )
! 		call FourierTransform2D_execute( planB )
! 		funcA.xyGrid = FourierTransform2D_xyGrid( funcA.xyGrid, order=FourierTransform_NORDER )
! 		funcA = funcA/real( funcA.nPoints(1)*funcA.nPoints(2), 8 )
! 		call funcA.show()
! 		call funcA.save( ".iFFfunc", format=BLKS_FORMAT )

		call system( "echo splot \"//achar(34)//".func\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
		call system( "echo splot \"//achar(34)//".Ffunc\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
! 		call system( "echo splot \"//achar(34)//".iFFfunc\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
		call GOptions_doYouWantToContinue()
		call system( "rm .func .Ffunc .iFFfunc" )

		call FourierTransform2D_destroyPlan( planF )
		call FourierTransform2D_destroyPlan( planB )

! 		write(*,*) "------------------------------------------"
! 		write(*,*) " iFourierTransform2D( FourierTransform2D(func) ). CNFunction2D with plans"
! 		write(*,*) "------------------------------------------"
!
! 		call xyGrid.init( [-2.5_8,-2.5_8], [2.5_8,2.5_8], size=[90,110] )
! 		call funcA.init( xyGrid, funcRectangular )
! 		write(*,"(A)") "input (.func) = "
! 		call funcA.show()
! 		call funcA.save( ".func", format=BLKS_FORMAT )
!
! 		planF = FourierTransform2D_plan( funcA, FourierTransform_FORWARD )
! 		planB = FourierTransform2D_plan( funcA, FourierTransform_BACKWARD )
!
! 		call FourierTransform2D_execute( planF )
! 		call FourierTransform2D_execute( planB )
! 		funcA = funcA/real( funcA.nPoints(1)*funcA.nPoints(2), 8 )
!
! 		call funcA.show()
! 		call funcA.save( ".iFFfunc", format=BLKS_FORMAT )
!
! 		call system( "echo splot \"//achar(34)//".func\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
! 		call system( "echo splot \"//achar(34)//".iFFfunc\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
! 		call GOptions_doYouWantToContinue()
! 		call system( "rm .func .iFFfunc" )
!
! 		call FourierTransform2D_destroyPlan( planF )
! 		call FourierTransform2D_destroyPlan( planB )

		write(*,*) "-----------------------------------------"
		write(*,*) " Verifing FourierTransform2D CNFunction2D oriented object"
		write(*,*) "-----------------------------------------"

		call xyGrid.init( [-2.5_8,-2.5_8], [2.5_8,2.5_8], size=[90,110] )
		call funcA.init( xyGrid, funcRectangular )
		write(*,"(A)") "input (.func) = "
		call funcA.show()
		call funcA.save( ".func", format=BLKS_FORMAT )

		call fft.init( funcA, FourierTransform_SPATIAL_DOMAIN )

		call fft.execute( FourierTransform_FORWARD, sync=.true., shift=.true. )
		write(*,"(A)") "FourierTransform2D (.Ffunc) = "
		call funcA.show()
		call funcA.save( ".Ffunc", format=BLKS_FORMAT )

		call fft.execute( FourierTransform_BACKWARD, sync=.true., shift=.true. )
		write(*,"(A)") "iFourierTransform2D (.iFFfunc) = "
		call funcA.show()
		call funcA.save( ".iFFfunc", format=BLKS_FORMAT )

		call system( "echo splot \"//achar(34)//".func\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
		call system( "echo splot \"//achar(34)//".Ffunc\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
		call system( "echo splot \"//achar(34)//".iFFfunc\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
		call GOptions_doYouWantToContinue()
		call system( "rm .func .Ffunc .iFFfunc" )

! 		write(*,*) "--------------------------------------"
! 		write(*,*) " Second derivative via FourierTransform2D with plans"
! 		write(*,*) "--------------------------------------"
!
! 		call xyGrid.init( -3.0_8*Math_PI, 3.0_8*Math_PI, 1001 )
! 		omegaGrid = FourierTransform2D_omegaGrid( xyGrid )
! 		call funcA.init( xyGrid, funcTest )
! 		write(*,"(A)") "input (.func) = "
! 		call funcA.show()
! 		call funcA.save(".func")
!
! 		planF = FourierTransform2D_plan( funcA, FourierTransform2D_FORWARD )
! 		planB = FourierTransform2D_plan( funcA, FourierTransform2D_BACKWARD )
!
! 		call FourierTransform2D_execute( planF )
!
! 		funcA.yArray = ( Math_I*fft.omega )**2*funcA.yArray
!
! 		write(*,"(A)") "iFourierTransform2D (.dfunc) = "
! 		call FourierTransform2D_execute( planB )
! 		funcA = funcA/real( funcA.nPoints(), 8 )
! 		call funcA.show()
! 		call funcA.save(".dfunc")
!
! 		call funcB.init( xyGrid, d2funcTest )
! 		write(*,"(A)") "exact (.exact) = "
! 		call funcB.show()
! 		call funcB.save(".exact")
!
! ! 		call system( "echo plot \"//achar(34)//".func\"//achar(34)//" u 1:2 w l lw 1.5, \"//achar(34)//"\"//achar(34)//" u 1:3 w l lw 1.5 | gnuplot -p" )
! ! 		call system( "echo plot \"//achar(34)//".dfunc\"//achar(34)//" u 1:2 w l lw 1.5, \"//achar(34)//"\"//achar(34)//" u 1:3 w l lw 1.5 | gnuplot -p" )
! ! 		call system( "echo plot \"//achar(34)//".exact\"//achar(34)//" u 1:2 w l lw 1.5, \"//achar(34)//"\"//achar(34)//" u 1:3 w l lw 1.5 | gnuplot -p" )
! ! 		call GOptions_doYouWantToContinue()
! 		call system( "rm .func .dfunc .exact" )
!
! 		call FourierTransform2D_destroyPlan( planF )
! 		call FourierTransform2D_destroyPlan( planB )
!
! 		write(*,*) "------------------------------------------------------"
! 		write(*,*) " Second derivative via FourierTransform2D CNFunction2D oriented object"
! 		write(*,*) "------------------------------------------------------"
!
! 		call xyGrid.init( -3.0_8*Math_PI, 3.0_8*Math_PI, 1001 )
! 		call funcA.init( xyGrid, funcTest )
! 		write(*,"(A)") "input (.func) = "
! 		call funcA.show()
! 		call funcA.save(".func")
!
! 		call fft.init( funcA, FourierTransform_SPATIAL_DOMAIN )
!
! 		call fft.execute( FourierTransform2D_FORWARD )
!
! 		funcA.yArray = ( Math_I*fft.omega )**2*funcA.yArray
!
! 		call fft.execute( FourierTransform2D_BACKWARD )
!
! 		write(*,"(A)") "iFourierTransform2D (.dfunc) = "
! 		call funcA.show()
! 		call funcA.save(".dfunc")
!
! 		call funcB.init( xyGrid, d2funcTest )
! 		write(*,"(A)") "exact (.exact) = "
! 		call funcB.show()
! 		call funcB.save(".exact")
!
! ! 		call system( "echo plot \"//achar(34)//".func\"//achar(34)//" u 1:2 w l lw 1.5, \"//achar(34)//"\"//achar(34)//" u 1:3 w l lw 1.5 | gnuplot -p" )
! ! 		call system( "echo plot \"//achar(34)//".dfunc\"//achar(34)//" u 1:2 w l lw 1.5, \"//achar(34)//"\"//achar(34)//" u 1:3 w l lw 1.5 | gnuplot -p" )
! ! 		call system( "echo plot \"//achar(34)//".exact\"//achar(34)//" u 1:2 w l lw 1.5, \"//achar(34)//"\"//achar(34)//" u 1:3 w l lw 1.5 | gnuplot -p" )
! ! 		call GOptions_doYouWantToContinue()
! 		call system( "rm .func .dfunc .exact" )
!
! 		write(*,*) "----------"
! 		write(*,*) " Spectrum "
! 		write(*,*) "----------"
!
! ! 		call xyGrid.init( -3.0_8*Math_PI, 3.0_8*Math_PI, 1001 )
! 		call xyGrid.init( -15.0_8, 15.0_8, 1001 )
! 		call funcA.init( xyGrid, funcTest )
! 		write(*,"(A)") "input (.func) = "
! 		call funcA.show()
! 		call funcA.save(".func")
!
! 		aSpectrum = FourierTransform2D_powerSpectrum( funcA )
!
! 		write(*,"(A)") "aspec (.asfunc) = "
! 		call aSpectrum.show()
! 		call aSpectrum.save(".asfunc")
!
! 		pSpectrum = FourierTransform2D_phaseSpectrum( funcA )
!
! 		write(*,"(A)") "pspec (.psfunc) = "
! 		call pSpectrum.show()
! 		call pSpectrum.save(".psfunc")
!
! 		call system( "echo plot \"//achar(34)//".func\"//achar(34)//" u 1:2 w l lw 1.5, \"//achar(34)//"\"//achar(34)//" u 1:3 w l lw 1.5 | gnuplot -p" )
! 		call system( "echo plot \"//achar(34)//".asfunc\"//achar(34)//" u 1:2 w l lw 1.5 | gnuplot -p" )
! 		call system( "echo plot \"//achar(34)//".psfunc\"//achar(34)//" u 1:2 w l lw 1.5 | gnuplot -p" )
! 		call GOptions_doYouWantToContinue()
! 		call system( "rm .func .asfunc .psfunc" )
!
! 		write(*,*) "--------------------------------------------------------"
! 		write(*,*) " Filtering by amplitude. FourierTransform2D CNFunction2D oriented object"
! 		write(*,*) "--------------------------------------------------------"
!
! 		call xyGrid.init( -3.0_8*Math_PI, 3.0_8*Math_PI, 1001 )
! 		call funcA.init( xyGrid, funcTestWithNoise )
! 		write(*,"(A)") "input (.func) = "
! 		call funcA.show()
! 		call funcA.save(".func")
!
! 		call fft.init( funcA, FourierTransform_SPATIAL_DOMAIN )
!
! 		call fft.execute( FourierTransform2D_FORWARD )
!
! 		where( abs( funcA.yArray ) <= 20.0_8 ) funcA.yArray = 0.0_8
!
! 		call fft.execute( FourierTransform2D_BACKWARD )
!
! 		write(*,"(A)") "iFourierTransform2D (.ffunc) = "
! 		call funcA.show()
! 		call funcA.save(".ffunc")
!
! ! 		call system( "echo plot \"//achar(34)//".func\"//achar(34)//" u 1:2 w l lw 1.5, \"//achar(34)//"\"//achar(34)//" u 1:3 w l lw 1.5 | gnuplot -p" )
! ! 		call system( "echo plot \"//achar(34)//".ffunc\"//achar(34)//" u 1:2 w l lw 1.5, \"//achar(34)//"\"//achar(34)//" u 1:3 w l lw 1.5 | gnuplot -p" )
! ! 		call GOptions_doYouWantToContinue()
! 		call system( "rm .func .ffunc" )
!
! 		write(*,*) "--------------------------------------------------------"
! 		write(*,*) " Filtering by frequency. FourierTransform2D CNFunction2D oriented object"
! 		write(*,*) "--------------------------------------------------------"
!
! 		call xyGrid.init( -3.0_8*Math_PI, 3.0_8*Math_PI, 1001 )
! 		call funcA.init( xyGrid, funcTestWithNoise )
! 		write(*,"(A)") "input (.func) = "
! 		call funcA.show()
! 		call funcA.save(".func")
!
! 		call fft.init( funcA, FourierTransform_SPATIAL_DOMAIN )
!
! 		call fft.execute( FourierTransform2D_FORWARD )
!
! 		do i=1,funcA.nPoints()
! 			if( abs( fft.omega(i) ) > 10.0_8 ) then
! 				funcA.yArray(i) = 0.0_8
! 			end if
! 		end do
!
! 		call fft.execute( FourierTransform2D_BACKWARD )
!
! 		write(*,"(A)") "iFourierTransform2D (.ffunc) = "
! 		call funcA.show()
! 		call funcA.save(".ffunc")
!
! ! 		call system( "echo plot \"//achar(34)//".func\"//achar(34)//" u 1:2 w l lw 1.5, \"//achar(34)//"\"//achar(34)//" u 1:3 w l lw 1.5 | gnuplot -p" )
! ! 		call system( "echo plot \"//achar(34)//".ffunc\"//achar(34)//" u 1:2 w l lw 1.5, \"//achar(34)//"\"//achar(34)//" u 1:3 w l lw 1.5 | gnuplot -p" )
! ! 		call GOptions_doYouWantToContinue()
! 		call system( "rm .func .ffunc" )

	end subroutine FourierTransform2D_test

end module FourierTransform2D_


MODULE ex_share
IMPLICIT NONE
CONTAINS
ATTRIBUTES(GLOBAL) SUBROUTINE sumation(a,b,e)
IMPLICIT NONE
INTEGER, PARAMETER :: n=1024
INTEGER,INTENT(in) :: a(n)
INTEGER,INTENT(in) :: b(n)
INTEGER,INTENT(out):: e(n)
INTEGER :: i,j
INTEGER,shared :: d(n)
!INTEGER :: d(n)

i = threadIdx%x
d(i) = a(i)+ b(i)
CALL syncthreads()

IF (i/=n) THEN
    j=i+1
ELSE
    j=1
END IF

e(i) = d(i)+d(j)

END SUBROUTINE sumation
END MODULE ex_share
!!==========================================
PROGRAM ex_presentation
USE cudafor
USE ex_share
IMPLICIT NONE
INTEGER, PARAMETER :: n = 1024
INTEGER :: a(n),b(n),e(n)
INTEGER, device :: a_d(n),b_d(n),e_d(n)

a = 10 ; b = 20
a_d=a ; b_d=b
CALL sumation <<<1,n>>>(a_d,b_d,e_d)
e=e_d
IF(all(e==60)) THEN
      WRITE(* ,*)'**** OK ****'
ELSE
      WRITE(* ,*)'Program Failed'
END IF
END PROGRAM ex_presentation


      SUBROUTINE SROT(N,X,INCX,Y,INCY,C,S)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1994-11-11 SROT  Krogh   Declared all vars.
C>> 1994-10-20 SROT   Krogh  Changes to use M77CON
C>> 1985-08-02 SROT   Lawson  Initial code.
c--S replaces "?": ?ROT
C
C     MULTIPLY THE 2 X 2 MATRIX  ( C S) TIMES THE 2 X N MATRIX (X**T)
C                                (-S C)                        (Y**T)
C     WHERE **T INDICATES TRANSPOSE.    THE ELEMENTS OF X ARE IN
C     X(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE
C     LX = (-INCX)*N, AND SIMILARLY FOR Y USING LY AND INCY.
      INTEGER N, INCX, INCY, NSTEPS, I, KX, KY
      REAL             X,Y,C,S,ZERO,ONE,W,Z
      DIMENSION X(*),Y(*)
C
      DATA ZERO,ONE/0.E0,1.E0/
      IF(N .LE. 0 .OR. (S .EQ. ZERO .AND. C .EQ. ONE)) GO TO 40
      IF(.NOT. (INCX .EQ. INCY .AND. INCX .GT. 0)) GO TO 20
C
           NSTEPS=INCX*N
           DO 10 I=1,NSTEPS,INCX
                W=X(I)
                Z=Y(I)
                X(I)=C*W+S*Z
                Y(I)=-S*W+C*Z
   10           CONTINUE
           GO TO 40
C
   20 CONTINUE
           KX=1
           KY=1
C
           IF(INCX .LT. 0) KX=1-(N-1)*INCX
           IF(INCY .LT. 0) KY=1-(N-1)*INCY
C
           DO 30 I=1,N
                W=X(KX)
                Z=Y(KY)
                X(KX)=C*W+S*Z
                Y(KY)=-S*W+C*Z
                KX=KX+INCX
                KY=KY+INCY
   30           CONTINUE
   40 CONTINUE
C
      RETURN
      END


module timestep_mod

use globals_mod

real(dp), save :: DT_ITER

contains

function calc_timestep(mesh) result(timestep)

    use mesh_mod, only: mesh_t
    use mesh_mod, only: mesh_iterate_cells

    type(mesh_t), intent(inout) :: mesh

    real(dp) :: timestep

    DT_ITER = HUGE(1.0)

    call mesh_iterate_cells(mesh,calc_timestep_cb)

    timestep = DT_ITER

end function

subroutine calc_timestep_cb(cell)

    use mesh_mod, only: cell_t
    use mesh_mod, only: cell_get_delta
    use equations_mod, only: xlambdaMax
    use equations_mod, only: ylambdaMax

    type(cell_t), intent(inout) :: cell

    real(dp) :: delta(N_DIMS)
    real(dp) :: xlmax(N_NODES,N_NODES)
    real(dp) :: ylmax(N_NODES,N_NODES)
    real(dp) :: dtmin

    xlmax = xlambdaMax(cell%state)
    ylmax = ylambdaMax(cell%state)

    delta = cell_get_delta(cell)
    dtmin = min(delta(1)/maxval(xlmax),delta(2)/maxval(ylmax))

    !$omp critical
    DT_ITER = min(DT_ITER,dtmin)
    !$omp end critical

end subroutine

end module


*> \brief \b SDSDOT
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       REAL FUNCTION SDSDOT(N,SB,SX,INCX,SY,INCY)
*
*       .. Scalar Arguments ..
*       REAL SB
*       INTEGER INCX,INCY,N
*       ..
*       .. Array Arguments ..
*       REAL SX(*),SY(*)
*       ..
*
*    PURPOSE
*    =======
*
*    Compute the inner product of two vectors with extended
*    precision accumulation.
*
*    Returns S.P. result with dot product accumulated in D.P.
*    SDSDOT = SB + sum for I = 0 to N-1 of SX(LX+I*INCX)*SY(LY+I*INCY),
*    where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is
*    defined in a similar way using INCY.
*
*    AUTHOR
*    ======
*    Lawson, C. L., (JPL), Hanson, R. J., (SNLA),
*    Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL)
*
*    ARGUMENTS
*    =========
*
*    N      (input) INTEGER
*           number of elements in input vector(s)
*
*    SB     (input) REAL
*           single precision scalar to be added to inner product
*
*    SX     (input) REAL array, dimension (N)
*           single precision vector with N elements
*
*    INCX   (input) INTEGER
*           storage spacing between elements of SX
*
*    SY     (input) REAL array, dimension (N)
*           single precision vector with N elements
*
*    INCY   (input) INTEGER
*           storage spacing between elements of SY
*
*    SDSDOT (output) REAL
*           single precision dot product (SB if N .LE. 0)
*
*    Further Details
*    ===============
*
*    REFERENCES
*
*    C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
*    Krogh, Basic linear algebra subprograms for Fortran
*    usage, Algorithm No. 539, Transactions on Mathematical
*    Software 5, 3 (September 1979), pp. 308-323.
*
*    REVISION HISTORY  (YYMMDD)
*
*    791001  DATE WRITTEN
*    890531  Changed all specific intrinsics to generic.  (WRB)
*    890831  Modified array declarations.  (WRB)
*    890831  REVISION DATE from Version 3.2
*    891214  Prologue converted to Version 4.0 format.  (BAB)
*    920310  Corrected definition of LX in DESCRIPTION.  (WRB)
*    920501  Reformatted the REFERENCES section.  (WRB)
*    070118  Reformat to LAPACK coding style
*
*    =====================================================================
*
*       .. Local Scalars ..
*       DOUBLE PRECISION DSDOT
*       INTEGER I,KX,KY,NS
*       ..
*       .. Intrinsic Functions ..
*       INTRINSIC DBLE
*       ..
*       DSDOT = SB
*       IF (N.LE.0) THEN
*          SDSDOT = DSDOT
*          RETURN
*       END IF
*       IF (INCX.EQ.INCY .AND. INCX.GT.0) THEN
*
*       Code for equal and positive increments.
*
*          NS = N*INCX
*          DO I = 1,NS,INCX
*             DSDOT = DSDOT + DBLE(SX(I))*DBLE(SY(I))
*          END DO
*       ELSE
*
*       Code for unequal or nonpositive increments.
*
*          KX = 1
*          KY = 1
*          IF (INCX.LT.0) KX = 1 + (1-N)*INCX
*          IF (INCY.LT.0) KY = 1 + (1-N)*INCY
*          DO I = 1,N
*             DSDOT = DSDOT + DBLE(SX(KX))*DBLE(SY(KY))
*             KX = KX + INCX
*             KY = KY + INCY
*          END DO
*       END IF
*       SDSDOT = DSDOT
*       RETURN
*       END
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup single_blas_level1
*
*  =====================================================================
      REAL FUNCTION SDSDOT(N,SB,SX,INCX,SY,INCY)
*
*  -- Reference BLAS level1 routine (version 3.4.0) --
*  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      REAL SB
      INTEGER INCX,INCY,N
*     ..
*     .. Array Arguments ..
      REAL SX(*),SY(*)
*     ..
*
*  PURPOSE
*  =======
*
*  Compute the inner product of two vectors with extended
*  precision accumulation.
*
*  Returns S.P. result with dot product accumulated in D.P.
*  SDSDOT = SB + sum for I = 0 to N-1 of SX(LX+I*INCX)*SY(LY+I*INCY),
*  where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is
*  defined in a similar way using INCY.
*
*  AUTHOR
*  ======
*  Lawson, C. L., (JPL), Hanson, R. J., (SNLA),
*  Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL)
*
*  ARGUMENTS
*  =========
*
*  N      (input) INTEGER
*         number of elements in input vector(s)
*
*  SB     (input) REAL
*         single precision scalar to be added to inner product
*
*  SX     (input) REAL array, dimension (N)
*         single precision vector with N elements
*
*  INCX   (input) INTEGER
*         storage spacing between elements of SX
*
*  SY     (input) REAL array, dimension (N)
*         single precision vector with N elements
*
*  INCY   (input) INTEGER
*         storage spacing between elements of SY
*
*  SDSDOT (output) REAL
*         single precision dot product (SB if N .LE. 0)
*
*  Further Details
*  ===============
*
*  REFERENCES
*
*  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
*  Krogh, Basic linear algebra subprograms for Fortran
*  usage, Algorithm No. 539, Transactions on Mathematical
*  Software 5, 3 (September 1979), pp. 308-323.
*
*  REVISION HISTORY  (YYMMDD)
*
*  791001  DATE WRITTEN
*  890531  Changed all specific intrinsics to generic.  (WRB)
*  890831  Modified array declarations.  (WRB)
*  890831  REVISION DATE from Version 3.2
*  891214  Prologue converted to Version 4.0 format.  (BAB)
*  920310  Corrected definition of LX in DESCRIPTION.  (WRB)
*  920501  Reformatted the REFERENCES section.  (WRB)
*  070118  Reformat to LAPACK coding style
*
*  =====================================================================
*
*     .. Local Scalars ..
      DOUBLE PRECISION DSDOT
      INTEGER I,KX,KY,NS
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC DBLE
*     ..
      DSDOT = SB
      IF (N.LE.0) THEN
         SDSDOT = DSDOT
         RETURN
      END IF
      IF (INCX.EQ.INCY .AND. INCX.GT.0) THEN
*
*     Code for equal and positive increments.
*
         NS = N*INCX
         DO I = 1,NS,INCX
            DSDOT = DSDOT + DBLE(SX(I))*DBLE(SY(I))
         END DO
      ELSE
*
*     Code for unequal or nonpositive increments.
*
         KX = 1
         KY = 1
         IF (INCX.LT.0) KX = 1 + (1-N)*INCX
         IF (INCY.LT.0) KY = 1 + (1-N)*INCY
         DO I = 1,N
            DSDOT = DSDOT + DBLE(SX(KX))*DBLE(SY(KY))
            KX = KX + INCX
            KY = KY + INCY
         END DO
      END IF
      SDSDOT = DSDOT
      RETURN
      END


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

 MODULE ConstantsDictionary

  USE ModelPrecision

  !*************************************************************!
  ! --------------------- File I/O Behavior --------------------!
  ! ************************************************************!
  INTEGER, PARAMETER :: nInt4PerChunk=25000000 ! 100 MB file IO resolution
  INTEGER, PARAMETER :: nInt8PerChunk=12500000 ! 100 MB file IO resolution
  INTEGER, PARAMETER :: nReal4PerChunk=25000000 ! 100 MB file IO resolution
  INTEGER, PARAMETER :: nReal8PerChunk=12500000 ! 100 MB file IO resolution

  !*************************************************************!
  ! ------------------ MATHEMATICAL CONSTANTS ------------------!
  ! ************************************************************!
  !                                                             !
  ! ------------------------------------------------------------!
   REAL(prec), PARAMETER :: pi   = 4.0_prec*atan(1.0_prec)
   REAL(prec), PARAMETER :: ZERO = 0.0_prec
   REAL(prec), PARAMETER :: ONE  = 1.0_prec
   REAL(prec), PARAMETER :: TWO  = 2.0_prec
   REAL(prec), PARAMETER :: HALF = 0.5_prec
   REAL(prec), PARAMETER :: TOL  = epsilon(1.0_prec)

   INTEGER, PARAMETER :: kItMax = 50 ! Max iterations for Newton's method.
                                      ! USEd in : MODULE LEGENDRE.f90, S/R LEG_GAUSSQUAD
   REAL(prec), PARAMETER :: fillValue = -999.999_prec
  !*************************************************************!
  ! ----------------- ROOT FINDER CONSTANTS --------------------!
  ! ************************************************************!
  !                                                             !
  ! ------------------------------------------------------------!
   REAL(prec), PARAMETER :: newtonTolerance = 10.0**(-10)
   INTEGER, PARAMETER    :: newtonMax       = 100

  !*************************************************************!
  ! ----------------- TIME STEPPING CONSTANTS ------------------!
  ! ************************************************************!
  !                                                             !
  ! ------------------------------------------------------------!
  ! Runge-Kutta 3rd Order, low storage constants
   REAL(prec), PARAMETER :: rk3_a(1:3) = (/ 0.0_prec, -5.0_prec/9.0_prec, -153.0_prec/128.0_prec /)
   REAL(prec), PARAMETER :: rk3_b(1:3) = (/ 0.0_prec, 1.0_prec/3.0_prec, 3.0_prec/4.0_prec /)
   REAL(prec), PARAMETER :: rk3_g(1:3) = (/ 1.0_prec/3.0_prec, 15.0_prec/16.0_prec, 8.0_prec/15.0_prec /)

  !*************************************************************!
  ! ------------------- PHYSICAL CONSTANTS ---------------------!
  ! ************************************************************!
  !                                                             !
  ! ------------------------------------------------------------!
  ! Time conversion factors
   REAL(prec), PARAMETER   :: secondsToMinutes = 1.0_prec/60.0_prec                   ! conversion for seconds to minutes
   REAL(prec), PARAMETER   :: minutesToHours   = 1.0_prec/60.0_prec                   ! conversion for minutes to hours
   REAL(prec), PARAMETER   :: hoursToDays      = 1.0_prec/24.0_prec                   ! conversion for hours to days
   REAL(prec), PARAMETER   :: daysToMonths     = 12.0_prec/365.25_prec                ! conversion for days to months
   REAL(prec), PARAMETER   :: monthsToYears    = 1.0_prec/12.0_prec                   ! conversion for months to years
   REAL(prec), PARAMETER   :: daysToSeconds    = 86400.0_prec

  !*************************************************************!
  ! ------------------- Package defaults ---------------------!
  ! ************************************************************!
  !                                                             !
  ! ------------------------------------------------------------!
   INTEGER, PARAMETER :: defaultNameLength = 40

  ! Misc. INTEGER and CHARACTER flag definitions
   INTEGER, PARAMETER      :: NONE = 0
   CHARACTER(1), PARAMETER :: nada = ' '

  !*************************************************************!
  ! ------------------------- Model Flags ----------------------!
  ! ************************************************************!
   ! Tracer Models !
   INTEGER, PARAMETER :: DyeModel             = 500
   INTEGER, PARAMETER :: RadionuclideModel    = 501
   INTEGER, PARAMETER :: SettlingModel        = 503
   INTEGER, PARAMETER :: ImpulseField         = 502
   INTEGER, PARAMETER :: ImpulseResponseField = 502
   ! Tracer integration modes
   INTEGER, PARAMETER :: forward     = 600
   INTEGER, PARAMETER :: equilibrium = 601

   ! Integration schemes
   INTEGER, PARAMETER :: Euler = 2000
   INTEGER, PARAMETER :: AB2   = 2001
   INTEGER, PARAMETER :: AB3   = 2002

   ! Stencil Flags
   INTEGER, PARAMETER :: LaxWendroff = 700
   INTEGER, PARAMETER :: LaxWendroffOverlap = 701

   INTEGER, PARAMETER :: PeriodicTripole = 800
   INTEGER, PARAMETER :: Dipole = 801

   INTEGER, PARAMETER :: Normal  = 850
   INTEGER, PARAMETER :: Overlap = 851
   INTEGER, PARAMETER :: Lateral = 852
   INTEGER, PARAMETER :: LateralPlusCorners = 853
   INTEGER, PARAMETER :: Temperature = 1000
   INTEGER, PARAMETER :: Salinity = 1000
   INTEGER, PARAMETER :: Density = 1000

 END MODULE ConstantsDictionary


C FORTRAN test file to test CASE constructs

      PROGRAM MAIN

      IMPLICIT NONE

      CHARACTER*1 :: VAR = 'A'
      INTEGER :: X = 40
      INTEGER :: Y
      INTEGER :: Z = 2

      SELECT CASE(VAR)
        CASE('A')
          Y = X/4
          WRITE(*,*) 'The variable is A and Y is: ', Y, Y*Z
        CASE('G')
          Y = X/10
          WRITE(*,*) 'The variable is G and Y is: ', Y, Y*Z

      END SELECT

      END PROGRAM MAIN


!Write by Liao Yuanda
!
!###############################################################

module dou_ex

contains

    subroutine calcu_p_nearest( p, p_i_pl, p_i_mi, p_j_pl, p_j_mi, p_i_pl_j_mi, p_i_mi_j_pl, L )
        implicit none
        integer :: p, p_i_pl, p_i_mi, p_j_pl, p_j_mi, p_i_pl_j_mi, p_i_mi_j_pl, L
        integer :: i, j, i_pl, j_pl, i_mi, j_mi

        i = int((p-1)/L)
        j = mod(p-1,L)
        i_pl = mod(i+1,L)
        j_pl = mod(j+1,L)
        if (i==0) then
            i_mi = L-1
        else
            i_mi = i-1
        end if
        if (j==0) then
            j_mi = L-1
        else
            j_mi = j-1
        end if

        p_i_pl = i_pl*L+j+1
        p_i_mi = i_mi*L+j+1
        p_j_pl = i*L+j_pl+1
        p_j_mi = i*L+j_mi+1
        p_i_pl_j_mi = i_pl*L+j_mi+1
        p_i_mi_j_pl = i_mi*L+j_pl+1

    end subroutine calcu_p_nearest

    subroutine calcu_H( L, N, M, H, t )

        implicit none
        integer :: L, N, M, i, j
        integer :: p, p_i_pl, p_i_mi, p_j_pl, p_j_mi, p_i_pl_j_mi, p_i_mi_j_pl
        complex*16  :: H(M, M)
		real*8 :: t

        do i = 1, M
            do j = 1, M
                H(i,j) = 0.0
            end do
        end do

        do i = 0, L-1, 1
            do j = 0, L-1, 1
                p = i*L+j+1
                call calcu_p_nearest( p, p_i_pl, p_i_mi, p_j_pl, p_j_mi, p_i_pl_j_mi, p_i_mi_j_pl, L )

                H(p, p_i_pl) = -t
                H(p, p_i_mi) = -t
                H(p, p_j_pl) = -t
                H(p, p_j_mi) = -t
                H(p, p_i_pl_j_mi) = -t
                H(p, p_i_mi_j_pl) = -t

                H(p+N, p_i_pl+N) = -t
                H(p+N, p_i_mi+N) = -t
                H(p+N, p_j_pl+N) = -t
                H(p+N, p_j_mi+N) = -t
                H(p+N, p_i_pl_j_mi+N) = -t
                H(p+N, p_i_mi_j_pl+N) = -t
            end do
        end do
    end subroutine calcu_H

    subroutine pem_sparse( H, val1, val2, colind, rowptr , M, nonzeros)
            implicit none
            integer :: M, nonzeros, colind(nonzeros), rowptr(M+1), i, j, k, num_row
            complex*16 :: H(M, M)
            real*8 :: val1(nonzeros), val2(nonzeros)
            k = 0
            do i = 1, M
                rowptr(i) = k

                do j = 1, M
                    if ( H(i,j) /= (0.0,0.0)) then
                        k = k+1

                        val1(k) = real(H(i,j))
                        val2(k) = aimag(H(i,j))
                        colind(k) = j-1
                    end if
                end do
            end do
            rowptr(M+1) = nonzeros
			write(*,*) k, nonzeros
    end subroutine pem_sparse

	subroutine pem_rescale( H, a, b, M)
		implicit none
		integer :: M, i, j
		complex*16 :: H(M,M)
		real*8 :: a, b
		do i = 1,M
			H(i,i) = H(i,i)-b
        	do j = 1,M
				H(i,j) = H(i,j)/a
        	end do
    	end do
	end subroutine pem_rescale
end module dou_ex

program skyrmionlattice
    use dou_ex
    implicit none
    !#########################################
    !L, size of lattice
    !N = L*L, num of lattice
    !t, J_para, the parameter if H
    !##########################################
    integer, parameter :: L = 60, N = L*L, M = 2*N, nonzeros = 7*M, cutoff = 800, num_x = 100
    real*8, parameter :: t = 1.0
    integer, dimension(nonzeros) :: colind
    integer, dimension(M+1) :: rowptr
    real*8, dimension(nonzeros) :: val1, val2
	real*8, dimension(cutoff) :: miun_pem
	!real*8, dimension(num_x) :: stateden_pem_integral
    !real*8, dimension(cutoff) :: miun_tpem, miun_pem, miun_ev
    !real*8, dimension(M) :: eigv
    !real*8, dimension(num_x) :: stateden_ev, stateden_pem
    integer :: i, j, interval
    real*8 :: Emax, Emin, a, b, weight, beta, miu, t1, t2
    complex*16, dimension(M,M) :: H
    Emax = 3*t
    Emin = -6*t
    a = (Emax-Emin)/2.0
    b = (Emax+Emin)/2.0
	beta = 10.0*t
	miu = 0.7424*t
	!interval = 100
    !##########################
    call cpu_time(t1)
    write(*,*) 'Begin at:', t1
    !######################
	!open(unit = 15, file = 'eigv.in')
    open(unit = 14, file = 'miun_pem.out')
	!open(unit = 13, file = 'dos_ev.out')
	!open(unit = 17, file = 'dos_pem.out')
	!open(unit = 18, file = 'dos_pem_integral.out')
	!do i = 1, M
	!	read(15,*) eigv(i)
	!end do
	!close(15)
    call calcu_H( L, N, M, H, t )
	call pem_rescale( H, a, b, M)
    call pem_sparse( H, val1, val2, colind, rowptr , M, nonzeros)

	!call pem_statedensity( num_x, cutoff, M, nonzeros, val1, val2, colind, rowptr, stateden_pem )
	!call pem_statedensity_integral( num_x, interval, cutoff, M, nonzeros, val1, val2, colind, rowptr, stateden_pem_integral)
	!call pem_particle_density( cutoff, M, nonzeros, val1, val2, colind, rowptr, beta, miu, a, b, weight )
	call pem_moments( cutoff, M, nonzeros, val1, val2, colind, rowptr, miun_pem)
	!call pem_logweight( cutoff, M, nonzeros, val1, val2, colind, rowptr, 0.0, 0.0, a, b, weight )
	!call pem_test( cutoff, M, nonzeros, val1, val2, colind, rowptr, miun_tpem, miun_pem, miun_ev, eigv)
	!call pem_ev_dos( cutoff, num_x, M, eigv, stateden_ev)
	!write(*,*) weight
    !do i = 1, num_x
		!write(13,*) stateden_ev(i)
		!write(17,*) stateden_pem(i)
		!write(18,*) stateden_pem_integral(i)
    !end do
	!write(*,*) weight
    do i = 1, cutoff
		!write(14,*) miun_tpem(i),miun_pem(i),miun_ev(i)
		write(14,*) miun_pem(i)
    end do
    !close(14)
    !close(13)
    !close(17)
    !close(18)
    !##########################
    call cpu_time(t2)
    write(*,*) 'End at:', t2
    !######################
    write(*,*) 'Timecost:', t2-t1
end program skyrmionlattice


      subroutine proj(n,binf,bsup,x)
      implicit double precision (a-h,o-z)
      dimension binf(n),bsup(n),x(n)
      do 1 i=1,n
1     x(i)=max(binf(i),min(x(i),bsup(i)))
      return
      end


c---Note: These routines are not used within this code
c---      to compute the A4;3 amplitude, instead it is
c---      calculated directly
      double complex function A1phiAgQgmppmL(j1,j2,j3,j4,za,zb)
      implicit none
C     implementation of arXiv:0906.0008v1, Eq. 4.27
c--- the function defined in this routine is in fact (-i*A_4),
c---   i.e. complete LHS
      include 'constants.f'
      include 'zprods_decl.f'
      include 'sprods_com.f'
      include 'scale.f'
      include 'epinv.f'
      include 'deltar.f'
      integer j1,j2,j3,j4
      double complex zab2,V2L,l123,l34,l41,lnrat,L0,L1,Lsm1DS,
     . Lsm1_2me,A0phiAgQgmppm
      double precision s123,s234,s412,s341,mhsq
      zab2(j1,j2,j3,j4)=+za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4)

      s412=s(j4,j1)+s(j4,j2)+s(j1,j2)
      s123=s(j1,j2)+s(j1,j3)+s(j2,j3)
      s234=s(j2,j3)+s(j2,j4)+s(j3,j4)
      s341=s(j3,j4)+s(j3,j1)+s(j4,j1)
      mhsq=s(j1,j2)+s(j1,j3)+s(j1,j4)+s(j2,j3)+s(j2,j4)+s(j3,j4)
      l123=lnrat(musq,-s123)
      l34=lnrat(musq,-s(j3,j4))
      l41=lnrat(musq,-s(j4,j1))

      V2L=
     . -epinv**2-epinv*l34-0.5d0*l34**2
     . -epinv**2-epinv*l41-0.5d0*l41**2
     . +13d0/6d0*(epinv+l123)
     . +119d0/18d0-deltar/6d0
     . -Lsm1_2me(s412,s123,s(j1,j2),mhsq)
     . -Lsm1_2me(s123,s234,s(j2,j3),mhsq)

      A1phiAgQgmppmL=
     . +0.5d0*za(j1,j3)**2*zab2(j4,j1,j2,j3)**2/(za(j1,j2)*za(j2,j3))
     .  *L1(-s123,-s(j1,j2))/s(j1,j2)**2
     . -0.5d0*za(j1,j2)*za(j3,j4)**2*zb(j2,j3)**2/za(j2,j3)
     .  *L1(-s234,-s(j3,j4))/s(j3,j4)**2
     . -2d0*za(j1,j4)*zb(j2,j3)*za(j3,j4)/za(j2,j3)
     .  *(L0(-s123,-s(j1,j2))/s(j1,j2)+L0(-s234,-s(j3,j4))/s(j3,j4))
     . +0.5d0*A0phiAgQgmppm(j1,j2,j3,j4,za,zb)*lnrat(-s123,-s(j1,j2))
     . -0.5d0*s341*zb(j2,j3)*zb(j1,j3)
     .  /(zb(j3,j4)*zb(j1,j4)*zab2(j2,j3,j4,j1))
     . -0.5d0*zab2(j4,j1,j3,j2)**2/(s123*zb(j1,j2)*za(j2,j3))
     . -za(j1,j4)*zb(j2,j3)*za(j3,j4)/(s(j1,j2)*za(j2,j3))
     . +0.5d0*za(j1,j4)**2*(s(j1,j3)+s(j2,j3))
     .  /(s(j1,j2)*za(j1,j2)*za(j2,j3))
     . -0.5d0*zb(j2,j3)*za(j3,j4)*zab2(j2,j1,j4,j3)
     .  /(za(j2,j3)*zb(j3,j4)*zab2(j2,j3,j4,j1))

      A1phiAgQgmppmL=A1phiAgQgmppmL
     . +A0phiAgQgmppm(j1,j2,j3,j4,za,zb)*(
     .   V2L
     .  -Lsm1DS(s(j4,j1),s(j1,j2),s412)
     .  -Lsm1DS(s(j2,j3),s(j3,j4),s234))

      return
      end

      double complex function A1phiAgQgmppmR(j1,j2,j3,j4,za,zb)
      implicit none
C     implementation of arXiv:0906.0008v1 reflection relation (4.2.3)
      include 'constants.f'
      include 'zprods_decl.f'
      integer j1,j2,j3,j4
      double complex A1phiAgQgmmppL

      A1phiAgQgmppmR=A1phiAgQgmmppL(j1,j4,j3,j2,za,zb)

      return
      end

      double complex function A1phiAgQgmppmf(j1,j2,j3,j4,za,zb)
      implicit none
C     implementation of arXiv:0906.0008v1, Eq. 4.28
c--- the function defined in this routine is in fact (-i*A_4),
c---   i.e. complete LHS
      include 'constants.f'
      include 'epinv.f'
      include 'scale.f'
      include 'zprods_decl.f'
      include 'sprods_com.f'
      integer j1,j2,j3,j4
      double complex A0phiAgQgmppm,lnrat,l123

      l123=lnrat(musq,-(s(j1,j2)+s(j1,j3)+s(j2,j3)))

      A1phiAgQgmppmf=A0phiAgQgmppm(j1,j2,j3,j4,za,zb)*(
     . -2d0/3d0*(epinv+l123)-10d0/9d0)

      return
      end


      subroutine solp

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine calculates the amount of phosphorus lost from the soil
!!    profile in runoff and the movement of soluble phosphorus from the first
!!    to the second layer via percolation

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name          |units        |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    conv_wt(:,:)  |none         |factor which converts kg/kg soil to kg/ha
!!    curyr         |none         |current year of simulation
!!    hru_dafr(:)   |none         |fraction of watershed area located in HRU
!!    ihru          |none         |HRU number
!!    nyskip        |none         |number of years to skip output summarization
!!                                |and printing
!!    phoskd        |none         |Phosphorus soil partitioning coefficient
!!                                |Ratio of phosphorus attached to sediment to
!!                                |phosphorus dissolved in soil water
!!    pperco        |none         |phosphorus percolation coefficient (0-1)
!!                                |0:concentration of soluble P in surface
!!                                |  runoff is zero
!!                                |1:percolate has same concentration of soluble
!!                                |  P as surface runoff
!!    sol_bd(:,:)   |Mg/m**3      |bulk density of the soil
!!    sol_nly(:)    |none         |number of layers in soil profile
!!    sol_prk(:,:)  |mm H2O       |percolation from soil layer on current day
!!    sol_solp(:,:) |kg P/ha      |amount of phosohorus stored in solution
!!    sol_z(:,:)    |mm           |depth to bottom of soil layer
!!    surfq(:)      |mm H2O       |surface runoff generated on day in HRU
!!    wshd_plch     |kg P/ha      |average annual amount of phosphorus leached
!!                                |into second soil layer
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name          |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    sol_solp(:,:) |kg P/ha       |amount of phosohorus stored in solution
!!    surqsolp(:)   |kg P/ha       |amount of soluble phosphorus in surface
!!                                 |runoff in HRU for the day
!!    wshd_plch     |kg P/ha       |average annual amount of phosphorus leached
!!                                 |into second soil layer
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    j           |none          |HRU number
!!    vap         |kg P/ha       |amount of P leached from soil layer
!!    xx          |none          |variable to hold intermediate calculation
!!                               |result
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Min, Max

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use parm

      integer :: j
      real :: xx, vap, vap_tile

      j = 0
      j = ihru
      vap_tile = 0

!! compute soluble P lost in surface runoff
      xx = 0.
      xx = sol_bd(1,j) * sol_z(1,j) * phoskd(j)
      surqsolp(j) = sol_solp(1,j) * surfq(j) / xx
        !!units ==> surqsolp = [kg/ha * mm] / [t/m^3 * mm * m^3/t] = kg/ha
!     if (surfq(j) > 0.001) then
!     write (17,77) i, iyr, sol_bd(1,j), sol_z(1,j), phoskd(j), surfq(j),  &
!    &              sol_solp(1,j), surqsolp(j)
!     end if
! 77  format(2i6,6f10.3)
      surqsolp(j) = Min(surqsolp(j), sol_solp(1,j))
      surqsolp(j) = Max(surqsolp(j), 0.)
      sol_solp(1,j) = sol_solp(1,j) - surqsolp(j)

!! compute soluble P leaching
      vap = 0.
      vap = sol_solp(1,j) * sol_prk(1,j) / ((conv_wt(1,j) / 1000.)
     &                                            * pperco_sub(1,j))
      vap = Min(vap, .5 * sol_solp(1,j))
      sol_solp(1,j) = sol_solp(1,j) - vap

      !! estimate soluble p in tiles due to crack flow
      if (ldrain(j) > 0) then
        xx = Min(1., sol_crk(j) / 3.0)
        vap_tile = xx * vap
        vap = vap - vap_tile
      end if

      if (sol_nly(j) >= 2) then
        sol_solp(2,j) = sol_solp(2,j) + vap
      end if

      do ii = 2, sol_nly(j)
        vap = 0.
	 if (ii /= i_sep(j)) then
         vap = sol_solp(ii,j) * sol_prk(ii,j) / ((conv_wt(ii,j)
     &	   / 1000.) * pperco_sub(ii,j))
	   vap = Min(vap, .2 * sol_solp(ii,j))
	   sol_solp(ii,j) = sol_solp(ii,j) - vap
	   if (ii == sol_nly(j)) then
           sol_solp(ii+1,j) = sol_solp(ii+1,j) + vap
         end if
!         if (ii == ldrain(j)) then
!           vap = sol_solp(ii,j) * qtile / (conv_wt(ii,j) / 1000.
!     *                                         * pperco_sub(ii,j))
!           sol_solp(ii,j) = sol_solp(ii,j) - vap
!           tilep = vap
!         endif
	 endif
	end do
	percp(j) = vap

      !! summary calculation
      if (curyr > nyskip) then
        wshd_plch = wshd_plch + vap * hru_dafr(j)
        wshd_ptile = wshd_ptile + vap_tile * hru_dafr(j)
      end if

      return
      end