	SUBROUTINE getgrid(Nx,Lx,pi,name_config,x,kx)
	!--------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This subroutine gets grid points and fourier frequencies for a
	! pseudospectral simulation of the 1D nonlinear Klein-Gordon equation
	!
	! u_{tt}-u_{xx}+u=Es*u^3
	!
	! The boundary conditions are u(x=0)=u(2*Lx*\pi)
	!
	! INPUT
	!
	! .. Scalars ..
	!  Nx				= number of modes in x - power of 2 for FFT
	!  pi				= 3.142....
	!  Lx				= width of box in x direction
	! OUTPUT
	!
	! .. Vectors ..
	!  kx				= fourier frequencies in x direction
	!  x				= x locations
	!
	! LOCAL VARIABLES
	!
	! .. Scalars ..
	!  i				= loop counter in x direction
	!
	! REFERENCES
	!
	! ACKNOWLEDGEMENTS
	!
	! ACCURACY
	!
	! ERROR INDICATORS AND WARNINGS
	!
	! FURTHER COMMENTS
	! Check that the initial iterate is consistent with the
	! boundary conditions for the domain specified
	!--------------------------------------------------------------------
	! External routines required
	!
	! External libraries required
        IMPLICIT NONE
	! Declare variables
	INTEGER(KIND=4), INTENT(IN)			        :: Nx
	REAL(kind=8), INTENT(IN)			        :: Lx,pi
	REAL(KIND=8), DIMENSION(1:NX), INTENT(OUT) 	        :: x
	COMPLEX(KIND=8), DIMENSION(1:NX/2 + 1), INTENT(OUT)	:: kx
	CHARACTER*100, INTENT(OUT)			        :: name_config
	INTEGER(kind=4)					        :: i

	DO i=1,1+Nx/2
		kx(i)= cmplx(0.0d0,1.0d0,kind(0d0))*REAL(i-1,kind(0d0))/Lx
	END DO
	kx(1+Nx/2)=0.0d0

	DO i=1,Nx
		x(i)=(-1.0d0 + 2.0d0*REAL(i-1,kind(0d0))/REAL(Nx,kind(0d0)))*pi*Lx
	END DO
	! Save x grid points in text format
	name_config = 'xcoord.dat'
	OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	REWIND(11)
	DO i=1,Nx
		WRITE(11,*) x(i)
	END DO
	CLOSE(11)

	END SUBROUTINE getgrid


real(kind=8) function burger (t, x ,nu) result(burg)
    implicit none

    real(kind=8), intent(in) :: t, x, nu
    real(kind=8) :: pi = 4 * atan(1.0_8)

    burg = -2 * nu * (-(-8 * t + 2 * x) * exp(-(-4 * t + x)** 2 / &
		(4 * nu * (t + 1))) / (4 * nu * (t + 1)) - &
		(-8 * t + 2 * x - 4 * pi) * exp(-(-4 * t + x - 2 * pi)** 2 / &
		(4 * nu * (t + 1))) / (4 * nu * (t + 1))) / &
			(exp(-(-4 * t + x - 2 * pi)** 2 / (4 * nu * (t + 1))) + &
				exp(-(-4 * t + x)** 2 / (4 * nu * (t + 1)))) + 4

end function burger

subroutine spaceevenly(start, finish, number, arrayout)
    implicit none

    integer, intent(in) :: start, finish
    real(kind=8), intent(in) :: number
    real(kind=8) :: div
    real(kind=8), dimension(0:finish), intent(out) :: arrayout
    integer :: i

    div = number / ((finish-1) - (start-1))

    do i=start, finish
        arrayout(i) = div * i
    end do

end subroutine spaceevenly

!subroutine copy_real_array(source, destination, size)
    !implicit none


! This program will numerically compute the integral of
!                  4/(1+x*x)
! from 0 to 1.  The value of this integral is pi -- which
! is great since it gives us an easy way to check the answer.

! The program was parallelized using OpenMP by adding just
! four lines

! (1) A line to include omp.h -- the include file that
! contains OpenMP's function prototypes and constants.

! (2) A pragma that tells OpenMP to create a team of threads

! (3) A pragma to cause one of the threads to print the
! number of threads being used by the program.

! (4) A pragma to split up loop iterations among the team
! of threads.  This pragma includes 2 clauses to (1) create a
! private variable and (2) to cause the threads to compute their
! sums locally and then combine their local sums into a
! single global value.

! History: C Code written by Tim Mattson, 11/1999
!          Adapted to Fortran code by Helen He, 09/2017
!          Changed to Fortran90 code by Helen He, 11/2020

  PROGRAM MAIN
  USE OMP_LIB
  IMPLICIT NONE

  INTEGER :: i, id, nthreads
  INTEGER, PARAMETER :: num_steps = 100000000
  REAL*8 :: x, pi, sum, step
  REAL*8 :: start_time, run_time

  DO id = 1, 4
     sum = 0.0

     step = 1.0 / num_steps

     CALL OMP_SET_NUM_THREADS(id)
     start_time = OMP_GET_WTIME()

!$OMP PARALLEL PRIVATE(i,x)
!$OMP SINGLE
     nthreads = OMP_GET_NUM_THREADS()
!$OMP END SINGLE NOWAIT
!$OMP DO REDUCTION(+:sum)
     DO i = 1, num_steps
        x = (i - 0.5) * step
        sum = sum + 4.0 / (1.0 + x * x)
     ENDDO
!$OMP END DO
!$OMP END PARALLEL

     pi = step * sum
     run_time = OMP_GET_WTIME() - start_time
     WRITE(*,100) pi, run_time, nthreads
100  FORMAT('pi is ',f15.8,' in ',f8.3,'secs and ',i3,' threads')

  ENDDO

  END PROGRAM MAIN


PROGRAM main

  IMPLICIT NONE

  REAL :: sd1, sd2, av, scale_fac
  REAL :: x_min, x_max, dx, x
  REAL :: sum_of_diffs, sum_of_vals, sum_of_sqs
  REAL :: offset
  INTEGER :: i, n_bins

  n_bins = 1000

  ! Using a variable for this is clearer, and slightly more efficient
  scale_fac = 2.0 * 3.14159
  ! I use a variable here too for clarity and ease of changing
  offset = 0.0

  ! We can make the x-axis several ways.
  ! Finding dx and incrementing x in the loop is one.
  ! Another is to use the loop index itself and do  e.g. REAL(i)/REAL(n_bins-1)

  x_min = 0.0
  x_max = 2.0
  dx = (x_max - x_min) / REAL(n_bins + 1)

  ! Initialise all the running sums to 0
  sum_of_diffs = 0.0
  sum_of_vals = 0.0
  sum_of_sqs = 0.0

  x = x_min

  !Calculate average, and 1-pass SD running vals
  DO i = 1, n_bins

    sum_of_vals = sum_of_vals + (offset + sin(scale_fac * x))

    sum_of_sqs = sum_of_sqs + (offset + sin(scale_fac * x))**2

    x = x + dx

  END DO

  !Finish calc of average as it is needed for the 2-pass SD
  av = sum_of_vals / REAL(n_bins)

  x = x_min

  ! Calculate 2-pass SD running val
  DO i = 1, n_bins

    sum_of_diffs = sum_of_diffs + (offset + sin(scale_fac * x) - av)**2

    x = x + dx

  END DO

  !Finish calcs and print

  sd2 = sqrt(1.0/REAL(n_bins -1) * sum_of_diffs)

  sd1 = sqrt(1.0/REAL(n_bins -1) * (sum_of_sqs - REAL(n_bins) * av*av))

  PRINT'(A, I5, A, F8.3, A, F8.3)', "Number of bins: ",  n_bins, " Offset: ", &
       offset, " Average Value: ", av
  PRINT'(A, F8.3, A, F8.3)', "Two-pass SD: ", sd2, " One-pass SD: ", sd1

END PROGRAM


subroutine compute_flux (lo, hi, domlo, domhi, phi, philo, phihi, &
                         fluxx, fxlo, fxhi, fluxy, fylo, fyhi, &
                         dx, bc) bind(C, name="compute_flux")

  use amrex_fort_module, only : amrex_real
  use amrex_bc_types_module
  implicit none

  integer lo(2), hi(2), domlo(2), domhi(2)
  integer philo(2), phihi(2), fxlo(2), fxhi(2), fylo(2), fyhi(2)
  real(amrex_real), intent(in)    :: phi  (philo(1):phihi(1),philo(2):phihi(2))
  real(amrex_real), intent(inout) :: fluxx( fxlo(1): fxhi(1), fxlo(2): fxhi(2))
  real(amrex_real), intent(inout) :: fluxy( fylo(1): fyhi(1), fylo(2): fyhi(2))
  real(amrex_real), intent(in)    :: dx(2)
  integer, intent(in)             :: bc(2,2,1) ! (dim,lohi,ncomp)

  ! local variables
  integer i,j

  ! x-fluxes
  do j = lo(2), hi(2)
  do i = lo(1), hi(1)+1
     fluxx(i,j) = ( phi(i,j) - phi(i-1,j) ) / dx(1)
  end do
  end do

  ! y-fluxes
  do j = lo(2), hi(2)+1
  do i = lo(1), hi(1)
     fluxy(i,j) = ( phi(i,j) - phi(i,j-1) ) / dx(2)
  end do
  end do

  ! lo-x boundary, ghost cell contains value on boundary
  if (domlo(1) .eq. lo(1) .and. &
       (bc(1,1,1) .eq. amrex_bc_foextrap .or. bc(1,1,1) .eq. amrex_bc_ext_dir) ) then
     i = lo(1)
     do j = lo(2), hi(2)
        fluxx(i,j) = ( phi(i,j) - phi(i-1,j) ) / (0.5d0*dx(1))
     end do
  end if

  ! hi-x boundary, ghost cell contains value on boundary
  if (domhi(1) .eq. hi(1) .and. &
       (bc(1,2,1) .eq. amrex_bc_foextrap .or. bc(1,2,1) .eq. amrex_bc_ext_dir) ) then
     i = hi(1)+1
     do j = lo(2), hi(2)
        fluxx(i,j) = ( phi(i,j) - phi(i-1,j) ) / (0.5d0*dx(1))
     end do
  end if

  ! lo-y boundary, ghost cell contains value on boundary
  if (domlo(2) .eq. lo(2) .and. &
       (bc(2,1,1) .eq. amrex_bc_foextrap .or. bc(2,1,1) .eq. amrex_bc_ext_dir) ) then
     j = lo(2)
     do i = lo(1), hi(1)
        fluxy(i,j) = ( phi(i,j) - phi(i,j-1) ) / (0.5d0*dx(2))
     end do
  end if

  ! lo-y boundary, ghost cell contains value on boundary
  if (domhi(2) .eq. hi(2) .and. &
       (bc(2,2,1) .eq. amrex_bc_foextrap .or. bc(2,2,1) .eq. amrex_bc_ext_dir) ) then
     j = hi(2)+1
     do i = lo(1), hi(1)
        fluxy(i,j) = ( phi(i,j) - phi(i,j-1) ) / (0.5d0*dx(2))
     end do
  end if

end subroutine compute_flux

subroutine update_phi (lo, hi, phiold, polo, pohi, phinew, pnlo, pnhi, &
                       fluxx, fxlo, fxhi, fluxy, fylo, fyhi, &
                       dx, dt) bind(C, name="update_phi")

  use amrex_fort_module, only : amrex_real
  implicit none

  integer lo(2), hi(2), polo(2), pohi(2), pnlo(2), pnhi(2), fxlo(2), fxhi(2), fylo(2), fyhi(2)
  real(amrex_real), intent(in)    :: phiold(polo(1):pohi(1),polo(2):pohi(2))
  real(amrex_real), intent(inout) :: phinew(pnlo(1):pnhi(1),pnlo(2):pnhi(2))
  real(amrex_real), intent(in   ) :: fluxx (fxlo(1):fxhi(1),fxlo(2):fxhi(2))
  real(amrex_real), intent(in   ) :: fluxy (fylo(1):fyhi(1),fylo(2):fyhi(2))
  real(amrex_real), intent(in)    :: dx(2)
  real(amrex_real), intent(in)    :: dt

  ! local variables
  integer i,j
  real(amrex_real) :: dtdx(2)

  dtdx = dt/dx

  do j = lo(2), hi(2)
  do i = lo(1), hi(1)

     phinew(i,j) = phiold(i,j) &
          + dtdx(1) * (fluxx(i+1,j  ) - fluxx(i,j)) &
          + dtdx(2) * (fluxy(i  ,j+1) - fluxy(i,j))

  end do
  end do

end subroutine update_phi


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! z_poly_roots
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes the roots of a polynomial expressed in the monomial
! basis. The vector of COEFFS is in descending order by degree:
!
! p(x) = COEFFS(1)*x^N + COEFFS(2)*x^N-1 + ... + COEFFS(N)*x + COEFFS(N+1)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  N               INTEGER
!                    degree of the polynomial
!
!  COEFFS          COMPLEX(8) array of dimension (N+1)
!                    coefficients of polynomial ordered from highest
!                    degree coefficient to lowest degree
!
! OUTPUT VARIABLES:
!
!  ROOTS           COMPLEX(8) array of dimension (N)
!                    computed roots
!
!  RESIDUALS       COMPLEX(8) array of dimension (N)
!                    residuals of the computed roots
!
!  INFO            INTEGER
!                    INFO = 1 implies companion QZ algorithm failed
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine z_poly_roots(N,COEFFS,ROOTS,RESIDUALS,INFO)

  implicit none

  ! input variables
  integer, intent(in) :: N
  integer, intent(inout) :: INFO
  complex(8), intent(in) :: COEFFS(N+1)
  complex(8), intent(inout) :: ROOTS(N)
  real(8), intent(inout) :: RESIDUALS(N)

  ! compute variables
  integer :: ii
  real(8) :: scl
  logical, allocatable :: P(:)
  integer, allocatable :: ITS(:)
  real(8), allocatable :: Q(:),D1(:),C1(:),B1(:)
  real(8), allocatable :: D2(:),C2(:),B2(:)
  real(8) :: normc
  complex(8) :: sclc
  complex(8), allocatable :: V(:),W(:)
  interface
    function l_upr1fact_hess(m,flags)
      logical :: l_upr1fact_hess
      integer, intent(in) :: m
      logical, dimension(m-2), intent(in) :: flags
    end function l_upr1fact_hess
  end interface
  interface
    function l_upr1fact_inversehess(m,flags)
      logical :: l_upr1fact_inversehess
      integer, intent(in) :: m
      logical, dimension(m-2), intent(in) :: flags
    end function l_upr1fact_inversehess
  end interface
  interface
    function l_upr1fact_cmv(m,flags)
      logical :: l_upr1fact_cmv
      integer, intent(in) :: m
      logical, dimension(m-2), intent(in) :: flags
    end function l_upr1fact_cmv
  end interface
  interface
    function l_upr1fact_random(m,flags)
      logical :: l_upr1fact_random
      integer, intent(in) :: m
      logical, dimension(m-2), intent(in) :: flags
    end function l_upr1fact_random
  end interface

  ! allocate memory
  allocate(P(N-2),ITS(N-1),Q(3*(N-1)),D1(2*(N+1)),C1(3*N),B1(3*N))
  allocate(V(N),W(N),D2(2*(N+1)),C2(3*N),B2(3*N))

  ! initialize INFO
  INFO = 0

  ! fill P
  P = .FALSE.

  ! compute the norm of the monic polynomial
  normc = 0d0
  do ii=1,N
    normc = normc + abs(COEFFS(ii+1)/COEFFS(1))**2
  end do
  normc = sqrt(normc)

  ! our latest analysis shows that using QR (on the equivalent monic polynomial)
  ! is as accurate as using QZ with abs(COEFFS(1)) < 1, but faster
  ! for very large normc the QZ is still advantegous, hence
  ! we choose conservatievly 1e4
  if (normc.LT.1e8) then
    ! use QR

    ! fill V
    sclc = COEFFS(1)
    V(N) = ((-1d0)**(N))*COEFFS(N+1)/sclc
    do ii=1,(N-1)
      V(ii) = -COEFFS(N+1-ii)/sclc
    end do

    ! factor companion matrix
    call z_compmat_compress(N,P,V,Q,D1,C1,B1)

    ! call z_upr1fpen_qz
    call z_upr1fact_qr(.FALSE.,.FALSE.,l_upr1fact_hess,N,P,Q,D1,C1,B1,N,V,ITS,INFO)

    if (INFO.NE.0) then
      INFO = 1
    end if

    ! extract roots
    call z_upr1utri_decompress(.TRUE.,N,D1,C1,B1,ROOTS)

  else
    ! use QZ

    ! fill V and W
    scl = maxval(abs(COEFFS))
    V(N) = ((-1d0)**(N))*COEFFS(N+1)/scl
    do ii=1,(N-1)
      V(ii) = -COEFFS(N+1-ii)/scl
    end do
    W = cmplx(0d0,0d0,kind=8)
    W(N) = COEFFS(1)/scl

    ! factor companion matrix
    call z_comppen_compress(N,P,V,W,Q,D1,C1,B1,D2,C2,B2)

    ! call z_upr1fpen_qz
    call z_upr1fpen_qz(.FALSE.,.FALSE.,l_upr1fact_hess,N,P,Q,D1,C1,B1,D2,C2,B2,N,V,W,ITS,INFO)

    if (INFO.NE.0) then
      INFO = 1
    end if

    ! extract roots
    call z_upr1utri_decompress(.TRUE.,N,D1,C1,B1,V)
    call z_upr1utri_decompress(.TRUE.,N,D2,C2,B2,W)
    do ii=1,N
      ROOTS(ii) = V(ii)/W(ii)
    end do

  end if

  ! compute residuals
  call z_poly_residuals(N,COEFFS,ROOTS,0,RESIDUALS)

  ! free memory
  deallocate(P,ITS,Q,D1,C1,B1,D2,C2,B2,V,W)

end subroutine z_poly_roots


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                          Spherepack                           *
!     *                                                               *
!     *       A Package of Fortran77 Subroutines and Programs         *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!
! ... file helmsph.f
!
!     this file contains a program for solving the Helmholtz
!     equation with constant 1.0 on a ten degree grid on the full sphere
!
! ... required spherepack files
!
!     islapec.f, shaec.f, shsec.f, sphcom.f, hrfft.f
!
! ... description
!
!     let theta be latitude and phi be east longitude in radians.
!     and let
!
!
!       x = cos(theta)*sin(phi)
!       y = cos(theta)*cos(phi)
!       z = sint(theta)
!
!     be the cartesian coordinates corresponding to theta and phi.
!     on the unit sphere.  The exact solution
!
!        ue(theta, phi) = (1.+x*y)*exp(z)
!
!     is used to set the right hand side and compute error.
!
!
! **********************************************************************
!
! OUTPUT FROM EXECUTING THE PROGRAM BELOW
! WITH 32 AND 64 BIT FLOATING POINT ARITHMETIC
!
! Helmholtz approximation on a ten degree grid
! nlat = 19   nlon = 36
! xlmbda =  1.00   pertrb =  0.000E+00
! maximum error =  0.715E-06 *** (32 BIT)
! maximum error =  0.114E-12 *** (64 BIT)
!
! ***********************************************
! ***********************************************
program helmsph
use spherepack
    !
    !     set grid size with parameter statements
    !
    implicit none
    integer nnlat, nnlon, nn15, llsave, llwork, lldwork
    parameter (nnlat=19, nnlon=36)
    !
    !     set saved and unsaved workspace lengths in terms of nnlat, nnlon
    !     (see documentation for shaec, shsec, islapec)
    !
    parameter (nn15=nnlon+15)
    parameter (llsave=nnlat*(nnlat+1)+3*((nnlat-2)*(nnlat-1)+nn15))
    parameter (llwork=nnlat*(2*nnlon+3*(nnlat+1)+2*nnlat+1))
    !
    !     set real workspace length for initializations
    !
    parameter (lldwork = nnlat+1)
    !
    !     dimension arrays
    !
    real u(nnlat, nnlon), r(nnlat, nnlon)
    real sint(nnlat), cost(nnlat), sinp(nnlon), cosp(nnlon)
    real work(llwork), wshaec(llsave), wshsec(llsave)

    real a(nnlat, nnlat), b(nnlat, nnlat)
    integer nlat, nlon, i, j, lshaec, lshsec, lwork, ierror, isym, nt
    integer ldwork
    real x, y, z, dlat, dlon, theta, phi, xlmbda(1), pertrb(1), ez, ue, errm

    !
    !     set helmholtz constant
    !
    xlmbda = 1.0
    !
    !     set workspace length arguments
    !
    lwork = llwork
    ldwork = lldwork
    lshaec = llsave
    lshsec = llsave
    !
    !     set grid size arguments
    !
    nlat = nnlat
    nlon = nnlon
    !
    !     set sine and cosine vectors
    !
    dlat = pi/(nlat-1)
    dlon = (pi+pi)/nlon
    do i=1, nlat
        theta = -0.5*pi+(i-1)*dlat
        sint(i) = sin(theta)
        cost(i) = cos(theta)
    end do

    do j=1, nlon
        phi = (j-1)*dlon
        sinp(j) = sin(phi)
        cosp(j) = cos(phi)
    end do
    !
    !     set right hand side as helmholtz operator
    !     applied to ue = (1.+x*y)*exp(z)
    !
    do j=1, nlon
        do i=1, nlat
            x = cost(i)*cosp(j)
            y = cost(i)*sinp(j)
            z = sint(i)
            r(i, j) = -(x*y*(z*z+6.*(z+1.))+z*(z+2.))*exp(z)
        end do
    end do
    !
    !     initialize saved workspace arrays for scalar harmonic
    !     analysis and Helmholtz inversion of r
    !
    call shaeci(nlat, nlon, wshaec, ierror)
    if (ierror > 0) then
        write (6, 200) ierror
200     format(' shaeci, ierror = ', i2)
        call exit(0)
    end if
    call shseci(nlat, nlon, wshsec, ierror)
    if (ierror > 0) then
        write (6, 201) ierror
201     format(' shseci, ierror = ', i2)
        call exit(0)
    end if
    !
    !     set no symmetry and one array
    !
    isym = 0
    nt = 1
    !
    !     compute coefficients of r for input to islapec
    !
    call shaec(nlat, nlon, isym, nt, r, nlat, nlon, a, b, nlat, nlat, &
        wshaec, ierror)
    if (ierror > 0) then
        write (*, 202) ierror
202     format(' shaec , ierror = ', i2)
        call exit(0)
    end if
    !
    !     solve Helmholtz equation on the sphere in u
    !
    write (6, 100) nlat, nlon
100 format(' helmholtz approximation on a ten degree grid' &
        /' nlat = ', i3, 2x, ' nlon = ', i3)
    call islapec(nlat, nlon, isym, nt, xlmbda, u, nlat, nlon, a, b, nlat, nlat, &
        wshsec, pertrb, ierror)
    if (ierror /= 0) then
        write (6, 103) ierror
103     format(' islapec, ierror = ', i2)
        if (ierror > 0) call exit(0)
    end if
    !
    !     compute and print maximum error in u
    !
    errm = 0.0
    do j=1, nlon
        do i=1, nlat
            x = cost(i)*cosp(j)
            y = cost(i)*sinp(j)
            z = sint(i)
            ez = exp(z)
            ue = (1.+x*y)*ez
                errm = max(errm, abs(u(i, j)-ue))
        end do
    end do
    write (*, 204) xlmbda, pertrb, errm
204 format(' xlmbda = ', f5.2, 2x, ' pertrb = ' , e10.3, &
        /' maximum error = ', e10.3)
end program helmsph


module m
implicit none
contains
pure function twice(vec) result(vec2)
! result size depends on argument size
integer, intent(in) :: vec(:)
integer             :: vec2(size(vec))
vec2 = 2*vec
end function twice
!
pure function fibonacci(n) result(vec)
! result size is an argument
integer, intent(in) :: n
integer             :: vec(n)
integer             :: i
if (n < 1) return
vec(1) = 0
if (n < 2) return
vec(2) = 1
do i=3,n
   vec(i) = vec(i-1) + vec(i-2)
end do
end function fibonacci
!
pure function even(vec) result(even_num)
! If the size of the function RESULT depends on the input
! in a more complicated way, it can be an allocatable array
! return the even elements in vec(:)
integer, intent(in)  :: vec(:)
integer, allocatable :: even_num(:)
even_num = pack(vec, mod(vec,2)==0) ! allocation on assignment
end function even
end module m
!
program array_func
use m, only: twice, fibonacci, even
implicit none
character (len=*), parameter :: fmt="(*(i0,:,1x))"
print fmt,twice([1,4]) ! 2 8
print fmt,fibonacci(6) ! 0 1 1 2 3 5
print fmt,even([1,4,9,16]) ! 4 16
end program array_func


! Las variables de tipo real son aquellas que almacenan numeros de punto flotante, como 0.2, 1222.22222, -123.45
! Anteriormente sólo habían dos tipos de números reales: el tipo por defecto y el tipo de doble precisión

! Las versiones  más modernas de Fortran (90/95) nos permiten tener mayor control sobre la precisión de
! datos de tipo real e integer mediante el especificador kind.

program tipos_reales
! Declaración de variables
real :: var_real
real(kind=4) :: real_4bytes
real(kind=8) :: real_8bytes
real(kind=16) :: real_16bytes

integer :: int
integer(kind=2) :: int_2bytes
integer(kind=4) :: int_4bytes
integer(kind=8) :: int_8bytes
integer(kind=16) :: int_16bytes

var_real = 12.5

!En la programación científica, uno usualmente necesita saber el rango y precisión de los datos
!del hardware en el que se está trabajando.

!La función intrinseca kind() nos permite consultar los detalles de la representación de datos del hardware
!en el que se está trabajando.

print *, "¿Cuántos bytes puede almacenar una variable de tipo real por defecto?: ", kind(var_real)
print *, "Hasta qué número positivo llega?: ", huge(var_real)

print *, "¿Cuántos bytes almacena real_4bytes?: ", kind(real_4bytes)
print *, "Hasta qué número positivo llega?: ", huge(real_4bytes)

print *, "¿Cuántos bytes almacena real_8bytes?: ", kind(real_8bytes)
print *, "Hasta qué número positivo llega?: ", huge(real_8bytes)

print *, "¿Cuántos bytes almacena real_16bytes?: ", kind(real_16bytes)
print *, "Hasta qué número positivo llega?: ", huge(real_16bytes)

print *, "¿Cuántos bytes almacena int?: ", kind(int)
print *, "Hasta qué número positivo llega?: ", huge(int)

print *, "¿Cuántos bytes almacena int_2bytes?: ", kind(int_2bytes)
print *, "Hasta qué número positivo llega?: ", huge(int_2bytes)

print *, "¿Cuántos bytes almacena int_4bytes?: ", kind(int_4bytes)
print *, "Hasta qué número positivo llega?: ", huge(int_4bytes)

print *, "¿Cuántos bytes almacena int_8bytes?: ", kind(int_8bytes)
print *, "Hasta qué número positivo llega?: ", huge(int_8bytes)

print *, "¿Cuántos bytes almacena int_16bytes?: ", kind(int_16bytes)
print *, "Hasta qué número positivo llega?: ", huge(int_16bytes)
!El tipo real cumple con todas las operaciones posibles en el conjunto de los números reales.

end program tipos_reales

Constantes, variables y tipos de datos/tipos_reales.f90


module mandelbrot

use, intrinsic :: iso_fortran_env, only : dp=>real64,i64=>int64, stderr=>error_unit
use perf, only: sysclock2ms
Implicit None
integer, parameter :: wp=dp

contains

elemental integer function mandel(z0) result(r)

complex(wp), intent(in) :: z0
complex(wp) :: c, z
integer :: n
integer, parameter :: maxiter = 80

z = z0
c = z0

do n = 1, maxiter
  if (abs(z) > 2) then
    r = n-1
    return
  end if
  z = z**2 + c
end do

r = maxiter

end function mandel

pure integer function mandelperf() result(mandel_sum)

integer :: re, im, img, Nimg,msum
!integer :: msum[*] = 0

mandel_sum = 0
msum=0 ! must have this line!

!   img = this_image()
!   Nimg = num_images()
Nimg=1
img=1

do re=img-21, 5, Nimg !re=-20,5
  do im = -10,10
    msum = msum + mandel(cmplx(re/10.0_wp, im/10.0_wp, wp))
  end do
end do

!  call co_sum(msum)

mandel_sum = msum

end function mandelperf

Real(dp) function mandeltest(N,Nrun) result(t)
integer, intent(in) :: N,Nrun
integer(i64) :: tic,toc,tmin
integer :: i,k,f
f = 0
tmin = huge(0_i64)

do i = 1, Nrun
  call system_clock(tic)
  do k = 1, N
    f = mandelperf()
  end do
  call system_clock(toc)
  if (toc-tic < tmin) tmin = toc-tic
end do

if (f /= 14791) error stop 'mandelbrot: unexpected final value'

t = sysclock2ms(tmin) / 1000

end function mandeltest

end module mandelbrot

program m

use mandelbrot, only: mandeltest, dp
implicit none

integer :: N=1000, Nrun=10, argc, Ni
character(16) :: argv

real(dp) :: t

!  Ni = num_images()
Ni=1

argc = command_argument_count()
if (argc>0) then
  call get_command_argument(1,argv)
  read(argv,*) N
endif

if (argc>1) then
  call get_command_argument(2,argv)
  read(argv,*) Nrun
endif

t = mandeltest(N,Nrun)

print '(A,ES12.4,A)', 'Mandelbrot:',t,' sec.'

end program


program prog01
implicit none

double precision :: pi, r, area, volume
character (len = 1) :: c

pi = 3.14

write(*,*) "O que vc deseja calcular? Digite (a) para calcular a área e (v) para calcular o volume"
read(*,*)c

if (c .eq. "a") then
    write(*,*)"Digite o valor do raio da circunferencia"
    read(*,*)r
    area = pi*(r**2)
    write(*,*)"A área da circunferência é",area
else if (c .eq. "v") then
    write(*,*)"Digite o valor do raio da esfera"
    read(*,*)r
    volume = (4d0/3d0)*pi*r**3
    write(*,*)"O volume da esfera é",volume
else
    write(*,*) "Você não digitou um caractér válido"
end if

end program prog01


************************************************************************
!   Collections of Subroutines related to Table operations
!
!   Author: Zhi Qiu (qiu@mps.ohio-state.edu)
!   -- For changes, see ChangeLogsInputFun.txt
************************************************************************

************************************************************************
      Subroutine interpCubic(table,tableSize,var0,dVar,varX,varResult)
!     Purpose:
!       Return the interpolated value at varX from table, using cubic polynomial interpolation.
!       -- table: 1d array, stores values corresponding to var0+index*dVar
!       -- tableSize: size of the talbe
!       -- var0: start of the independent variable
!       -- dVar: step of the independent variable
!       -- varX: the value of the varibale to be interpolated at
!       -- varResult: the return interpolated value

      Implicit None

!     declare input parameters
      Integer tableSize
      Double Precision table(0:tableSize-1)
      Double Precision var0, dVar, varX, varResult

!     declare local variables
      Integer idx ! varX is between var0+idx*dVar and var0+(idx+1)*dVar
      Double Precision A0,A1,A2,A3,varD ! varD=delta-var

      If ((varX-var0)<dVar*1e-15) Then
        varResult = table(0)
        Return
      End If

      idx = floor((varX-var0)/dVar)

      If (idx<0 .OR. idx>tableSize-1) Then
        Print *, "Subroutine interpCubic: varX out of bounds"
        Print *, "varX=",varX,"var0=",var0,"dVar=",dVar,"idx=",idx
        call exit(1)
      End If

      If (idx==0) Then ! use quadratic interpolation
        A0 = table(0)
        A1 = table(1)
        A2 = table(2)
        varD = varX - var0
        varResult =
     &    (A0-2*A1+A2)/(2*dVar*dVar)*varD*varD
     &  - (3*A0-4*A1+A2)/(2*dVar)*varD
     &  + A0
        Return
      Else If (idx==tableSize-2) Then ! use quadratic interpolation
        A0 = table(tableSize-3)
        A1 = table(tableSize-2)
        A2 = table(tableSize-1)
        varD = varX - (var0 + (idx-1)*dVar)
        varResult =
     &    (A0-2*A1+A2)/(2*dVar*dVar)*varD*varD
     &  - (3*A0-4*A1+A2)/(2*dVar)*varD
     &  + A0
        Return
      Else ! use cubic interpolation
        A0 = table(idx-1)
        A1 = table(idx)
        A2 = table(idx+1)
        A3 = table(idx+2)
        varD = varX - (var0 + idx*dVar)
        varResult =
     &    (-A0+3*A1-3*A2+A3)/(6*dVar*dVar*dVar)*varD*varD*varD
     &  + (A0-2*A1+A2)/(2*dVar*dVar)*varD*varD
     &  - (2*A0+3*A1-6*A2+A3)/(6*dVar)*varD
     &  + A1
        Return
      End If

      End Subroutine
!-----------------------------------------------------------------------

************************************************************************
      Subroutine interpLinear(table,tableSize,var0,dVar,varX,varResult)
!     Purpose:
!       Return the interpolated value at varX from table, using linear interpolation.
!       -- table: 1d array, stores values corresponding to var0+index*dVar
!       -- tableSize: size of the talbe
!       -- var0: start of the independent variable
!       -- dVar: step of the independent variable
!       -- varX: the value of the varibale to be interpolated at
!       -- varResult: the return interpolated value

      Implicit None

!     declare input parameters
      Integer tableSize
      Double Precision table(0:tableSize-1)
      Double Precision var0, dVar, varX, varResult

!     declare local variables
      Integer idx ! varX is between var0+idx*dVar and var0+(idx+1)*dVar
      Double Precision varD  ! varD=delta-var

      If ((varX-var0)<dVar*1e-15) Then
        varResult = table(0)
        Return
      End If

      idx = floor((varX-var0)/dVar)

      If (idx<0 .OR. idx>tableSize-1) Then
        Print *, "Subroutine interpLinear: varX out of bounds"
        Print *, "varX=",varX,"var0=",var0,"dVar=",dVar,"idx=",idx
        call exit(1)
      End If

      varD = varX - (var0 + idx*dVar)
      varResult = (table(idx)*(dVar-varD) + table(idx+1)*varD)/dVar

      End Subroutine
!-----------------------------------------------------------------------

************************************************************************
      Subroutine invertFunction_binary(
     &           func,varL,varR,absacc,relacc,varY,varResult)
!     Purpose:
!       Return the varResult=func^-1(varY) using binary search when either
!       absolute error or relative error is reached
!       -- func: double precision 1-argument function to be inverted
!       -- varL: left boundary
!       -- varR: right boundary
!       -- absacc: absolute error
!       -- relacc: relative error
!       -- varY: the value of the variable to be inverted
!       -- varResult: the return inverted value
!
!   Solve: f(x)=0 with f(x)=table(x)-varY => f'(x)=table'(x)
!
      Implicit None

!     declare input parameters
      Double Precision func
      Double Precision varL, varR, varM, absacc, relacc
      Double Precision xL, xR
      Double Precision yL, yR, yM
      double precision varY, varResult

!     pre-fixed parameters
      Integer tolerance, itol

!     initialize parameters
      varM = (varR + varL)/2.
      xL = varL
      xR = varR
      tolerance = 60

      yL = func(xL)
      yR = func(xR)
      if(abs(yL - varY) < 1d-15) then
         varResult = varL
         return
      endif
      if(abs(yR - varY) < 1d-15) then
         varResult = varR
         return
      endif

      if((yL - varY)*(yR - varY) .gt. 0) then
          Print*, "Error: Invertfunction_binary: no unique solution!"
          Print*, "yL = ", yL, ", yR = ", yR
          Print*, "varL = ", varL, ", varR = ", varR, ", varY = ", varY
          call exit(1)
      endif

      itol = 0
      Do While ((abs(xR - xL) > absacc .and.
     &           abs(xR - xL)/((xR + xL)/2.) > relacc)
     &          .and. itol < tolerance)
        yM = func(varM)
        if((yL - varY)*(yM - varY) .lt. 0) then
           xR = varM
           yR = yM
        else
           xL = varM
           yL = yM
        endif
        varM = (xL + xR)/2.
        itol = itol + 1
      enddo

      varResult = varM
      End Subroutine
!-----------------------------------------------------------------------

************************************************************************
      Subroutine invertFunctionD(func,varL,varR,acc,varI,varX,varResult)
!     Purpose:
!       Return the varResult=func^-1(varX) using Newton method.
!       -- func: double precision 1-argument function to be inverted
!       -- varL: left boundary (for numeric derivative)
!       -- varR: right boundary (for numeric derivative)
!       -- dd: step (for numeric derivative)
!       -- varI: initial value
!       -- varX: the value of the varibale to be inverted
!       -- varResult: the return inverted value
!
!   Solve: f(x)=0 with f(x)=table(x)-varX => f'(x)=table'(x)
!
      Implicit None

!     declare input parameters
      Double Precision func
      Double Precision varL, varR, acc, varI, varX, varResult
      Double precision dd

!     pre-fixed parameters
      Double Precision accuracy
      Integer tolerance

!     declare local variables
      Double Precision XX1, XX2 ! used in iterations
      Double Precision F0, F1, F2, F3, X1, X2 ! intermediate variables
      Integer impatience ! number of iterations

!     initialize parameters
      accuracy = acc
      dd = DMAX1(1D-6,1D-3*abs(varR - varL))

      tolerance = 60
      impatience = 0

!     initial value, left point and middle point
      XX2 = varI
      XX1 = XX2-10*accuracy ! this value 10*accuracy is meanless, just to make sure the check in the while statement goes through

      Do While (abs(XX2-XX1)>accuracy)
        XX1 = XX2 ! copy values

!       value of function at XX!
        F0 = func(XX1)  - varX ! the value of the function at this point

!     decide X1 and X2 for differentiation
        If (XX1>varL+dd) Then
          X1 = XX1 - dd
        Else
          X1 = varL
        End If

        If (XX1<varR-dd) Then
          X2 = XX1 + dd
        Else
          X2 = varR
        End If

!     get values at X1 and X2
        F1 = func(X1)
        F2 = func(X2)
        F3 = (F1-F2)/(X1-X2) ! derivative at XX1

        XX2 = XX1 - F0/F3 ! Newton's mysterious method
!     maintain XX2 in the boundary
        if(XX2.lt.varL) XX2=varL
        if(XX2.gt.varR) XX2=varR

        impatience = impatience + 1
        If (impatience>tolerance) Then
          Print *, "Subroutine invertFunctionD: ",
     &                "max number of iterations reached!"
          call exit(1)
          !Print*, XX1, XX2
        End If
        dd = abs(XX2 - XX1)*0.05
      End Do ! <=> abs(XX2-XX1)>accuracy

      if(XX2 .lt. varL) then
         varResult = varL
      else if(XX2 .gt. varR) then
         varResult = varR
      else
         varResult = XX2
      endif

      End Subroutine
!-----------------------------------------------------------------------

************************************************************************
      Subroutine invertFunctionH(func,varL,varR,yy,acc,varResult)
!     Newton/Bisect hybrid root search algorithm.
!     Adapted from W.Press et.al. Numerical Recipies in C.
!     Purpose:
!       Return the varResult=func^-1(varX) using Newton method and Bisection.
!
!       -- func: double precision 1-argument function to be inverted
!       -- varL: left boundary (for numeric derivative)
!       -- varR: right boundary (for numeric derivative)
!       -- varResult: the return inverted value
!
!   Solve: f(x)=yy with f(x)=table(x)-varX => f'(x)=table'(x)
!
      Implicit None

!     declare input parameters
      Double Precision func
      Double Precision varL, varR, acc, varResult, yy
      Double Precision dd ! step size of numerical derivative

!     pre-fixed parameters
      Double Precision accuracy
      Integer tolerance

!     declare local variables
      Double Precision df, dx, dxold, f, fh, fl
      Double Precision temp, xh, xl, rts ! intermedia variables
      Integer impatience ! number of iterations
      Double Precision numericalZero

!     initialize parameters
      accuracy = acc
      tolerance = 60
      impatience = 0
      numericalZero = 1D-18
      dd = DMAX1(1D-6,1D-3*abs(varR - varL))

!     initial value, left and right point
      fl = func(varL) - yy
      fh = func(varR) - yy
      if(fl*fh>0) then
        print*, "invertFunctionH error!"
        print*, "No solution at given boundary!"
        call exit(1)
      EndIf

!     Check initial value is solution
      if(abs(fl)<numericalZero) then
        varResult = varL
        return
      elseif (abs(fh)<numericalZero) then
        varResult = varR
        return
      endif

!     maintain f(xl)<0
      if(fl < 0.0) then
        xl = varL
        xh = varR
      else
        xh = varL
        xl = varR
      EndIf

!     Initial guess
      rts = (xl+xh)/2.0
      dxold = abs(varR-varL)
      dx=dxold
      f = func(rts) - yy
      df = (func(rts+dd) - func(rts-dd))/(2.0*dd)

      Do While (impatience<tolerance)
!     Apply Bisection if Newton shoots out of boundary or converges too slow
        if((((rts-xh)*df-f)*((rts-xl)*df-f).ge.0.0)
     &    .or. (abs(2.0*f) > abs(dxold*df))) then
          dxold = dx
          dx = 0.5*(xh-xl)
          rts= xl+dx
          if(abs(xl-rts)<numericalZero) then
            varResult = rts
            return
          EndIf
        else
          dxold = dx
          dx = f/df
          temp = rts
          rts = rts-dx
          if(abs(temp-rts)<numericalZero) then
            varResult = rts
            return
          EndIf
        EndIf

!       Converge criteria
        if(abs(dx)<accuracy) then
          varResult = rts
          return
        EndIf
!       if not converge, calculate function and its derivative again
        dd = (xh - xl)/20.0
        f = func(rts) - yy
        df = (func(rts+dd) - func(rts-dd))/(2.0*dd)
!       maintain the bracket on the root
        if(f<0.0) then
          xl=rts
        else
          xh=rts
        endif

        impatience = impatience+1
      EndDo

      print*, "invertFunctionH error!"
      print*, "reached maximum iteration but hadn't found root!"
      call exit(1)

      End Subroutine
!-----------------------------------------------------------------------

************************************************************************
      Subroutine QShasta2(U,vX,vY,S,NX0,NX,NY0,NY,NZ0,NZ,
     &  DT,DX,DY, NXPhy0,NYPhy0, NXPhy,NYPhy, AntiX,AntiY)
!     Purpose:
!       Return U(t=n+1) using 2D Shasta algorithm.
!       -- U: The quantitiy to be propogated
!       -- S: Source term

      Implicit None

!     declare input parameters
      Integer NX0,NX,NY0,NY,NZ0,NZ
      Integer NXPhy0,NYPhy0, NXPhy,NYPhy
      Double Precision DT,DX,DY, antiX, antiY
      Double Precision U(NX0:NX,NY0:NY,NZ0:NZ)
      Double Precision vX(NX0:NX,NY0:NY,NZ0:NZ)
      Double Precision vY(NX0:NX,NY0:NY,NZ0:NZ)
      Double Precision S(NX0:NX,NY0:NY,NZ0:NZ)

!     declare local variables
      Double Precision UtX(NX0:NX,NY0:NY,NZ0:NZ) ! \tilde{U}^x
      Double Precision UtY(NX0:NX,NY0:NY,NZ0:NZ) ! \tilde{U}^y
      Double Precision Ut(NX0:NX,NY0:NY,NZ0:NZ) ! \tilde{U}
      Double Precision DelX(NX0:NX,NY0:NY,NZ0:NZ) ! \Delta^x
      Double Precision DelY(NX0:NX,NY0:NY,NZ0:NZ)
      Double Precision QPX(NX0:NX,NY0:NY,NZ0:NZ) ! Q_{+}^x
      Double Precision QMX(NX0:NX,NY0:NY,NZ0:NZ) ! Q_{-}^x
      Double Precision QPY(NX0:NX,NY0:NY,NZ0:NZ)
      Double Precision QMY(NX0:NX,NY0:NY,NZ0:NZ)
      Double Precision ilX, ilY ! 1/\lambda^x
      Double Precision DelTX(NX0:NX,NY0:NY,NZ0:NZ) ! \tilde{\Delta}^x
      Double Precision DelTY(NX0:NX,NY0:NY,NZ0:NZ)
      Double Precision AX(NX0:NX,NY0:NY,NZ0:NZ) ! A_{ad}^X
      Double Precision AY(NX0:NX,NY0:NY,NZ0:NZ)
      Double Precision sigmaX(NX0:NX,NY0:NY,NZ0:NZ) ! \sigma^x
      Double Precision sigmaY(NX0:NX,NY0:NY,NZ0:NZ)
      Double Precision ATX(NX0:NX,NY0:NY,NZ0:NZ) ! \tilde{A}^x
      Double Precision ATY(NX0:NX,NY0:NY,NZ0:NZ)
      Double Precision UTMin(NX0:NX,NY0:NY,NZ0:NZ) ! \tilde{U}^{min}
      Double Precision UTMax(NX0:NX,NY0:NY,NZ0:NZ)
      Double Precision AIn(NX0:NX,NY0:NY,NZ0:NZ) ! A^{in}
      Double Precision AOut(NX0:NX,NY0:NY,NZ0:NZ)
      Double Precision FIn(NX0:NX,NY0:NY,NZ0:NZ) ! F^{in}
      Double Precision FOut(NX0:NX,NY0:NY,NZ0:NZ)
      Double Precision PFilter(NX0:NX,NY0:NY,NZ0:NZ) ! positive filter
      Double Precision NFilter(NX0:NX,NY0:NY,NZ0:NZ) ! negative filter
      Double Precision AHatX(NX0:NX,NY0:NY,NZ0:NZ) ! \hat{A}^x
      Double Precision AHatY(NX0:NX,NY0:NY,NZ0:NZ)
      Double Precision Q1(NX0:NX,NY0:NY,NZ0:NZ) ! tmp var

      Common /R0Bdry/ R0Bdry
      Double Precision R0Bdry

!     initialization to zeros
      UtX = 0D0
      UtY = 0D0
      Ut = 0D0
      DelX = 0D0
      DelY = 0D0
      QPX = 0.5D0
      QMX = 0.5D0
      QPY = 0.5D0
      QMY = 0.5D0
      ilX = 0D0
      ilY = 0D0
      DelTX = 0D0
      DelTY = 0D0
      UTMin = 0D0
      UTMax = 0D0
      AIn = 1D-30
      AOut = 1D-30
      FIn = 0D0
      FOut = 0D0
      AHatX = 0D0
      AHatY = 0D0

!     1/\lambda^x
      ilX = DX/DT ! should <=0.5
      ilY = DY/DT

!     prepare x direction
      DelX(NX0:NX-1,:,:) = U(NX0+1:NX,:,:)-U(NX0:NX-1,:,:)
      QPX(NX0:NX-1,:,:) = (ilX/2D0-vX(NX0:NX-1,:,:))
     &                  / (ilX+(vX(NX0+1:NX,:,:)-vX(NX0:NX-1,:,:)))
      QMX(NX0+1:NX,:,:) = (ilX/2D0+vX(NX0+1:NX,:,:))
     &                  / (ilX-(vX(NX0:NX-1,:,:)-vX(NX0+1:NX,:,:)))
      UtX(NX0+1:NX,:,:) = 0.5D0*(
     &   QPX(NX0+1:NX,:,:)**2*DelX(NX0+1:NX,:,:)
     & - QMX(NX0+1:NX,:,:)**2*DelX(NX0:NX-1,:,:))
     & + (QPX(NX0+1:NX,:,:)+QMX(NX0+1:NX,:,:))*U(NX0+1:NX,:,:)

!     prepare y direction
      DelY(:,NY0:NY-1,:) = U(:,NY0+1:NY,:)-U(:,NY0:NY-1,:)
      QPY(:,NY0:NY-1,:) = (ilY/2D0-vY(:,NY0:NY-1,:))
     &                  / (ilY+(vY(:,NY0+1:NY,:)-vY(:,NY0:NY-1,:)))
      QMY(:,NY0+1:NY,:) = (ilY/2D0+vY(:,NY0+1:NY,:))
     &                  / (ilY-(vY(:,NY0:NY-1,:)-vY(:,NY0+1:NY,:)))
      UtY(:,NY0+1:NY,:) = 0.5D0*(
     &   QPY(:,NY0+1:NY,:)**2*DelY(:,NY0+1:NY,:)
     & - QMY(:,NY0+1:NY,:)**2*DelY(:,NY0:NY-1,:))
     & + (QPY(:,NY0+1:NY,:)+QMY(:,NY0+1:NY,:))*U(:,NY0+1:NY,:)

!     1st order propagating
      Ut = UtX + UtY - U + DT*S

!     anti-diffusing preparation
      DelTX(NX0:NX-1,:,:) = Ut(NX0+1:NX,:,:) - Ut(NX0:NX-1,:,:)
      DelTY(:,NY0:NY-1,:) = Ut(:,NY0+1:NY,:) - Ut(:,NY0:NY-1,:)
      AX = antiX*DelTX/8D0
      AY = antiY*DelTY/8D0
      sigmaX = sign(1D0, AX)
      sigmaY = sign(1D0, AY)
      ATX(NX0+1:NX-1,:,:) = sigmaX(NX0+1:NX-1,:,:)*max(0D0, min(
     &      sigmaX(NX0+1:NX-1,:,:)*DelTX(NX0+2:NX,:,:),
     &      abs(AX(NX0+1:NX-1,:,:)),
     &      sigmaX(NX0+1:NX-1,:,:)*DelTX(NX0:NX-2,:,:)))
      ATY(:,NY0+1:NY-1,:) = sigmaY(:,NY0+1:NY-1,:)*max(0D0, min(
     &      sigmaY(:,NY0+1:NY-1,:)*DelTY(:,NY0+2:NY,:),
     &      abs(AY(:,NY0+1:NY-1,:)),
     &      sigmaY(:,NY0+1:NY-1,:)*DelTY(:,NY0:NY-2,:)))

!     more anti-diffusing preparation
      UTMin(NX0+1:NX-1,NY0+1:NY-1,:) = min(
     &    Ut(NX0+1:NX-1,NY0:NY-2,:), Ut(NX0:NX-2,NY0+1:NY-1,:),
     &    Ut(NX0+1:NX-1,NY0+1:NY-1,:), Ut(NX0+2:NX,NY0+1:NY-1,:),
     &    Ut(NX0+1:NX-1,NY0+2:NY,:))
      UTMax(NX0+1:NX-1,NY0+1:NY-1,:) = max(
     &    Ut(NX0+1:NX-1,NY0:NY-2,:), Ut(NX0:NX-2,NY0+1:NY-1,:),
     &    Ut(NX0+1:NX-1,NY0+1:NY-1,:), Ut(NX0+2:NX,NY0+1:NY-1,:),
     &    Ut(NX0+1:NX-1,NY0+2:NY,:))
      AIn(NX0+1:NX,NY0+1:NY,:) =
     &   max(0D0, ATX(NX0:NX-1,NY0+1:NY,:))
     & - min(0D0, ATX(NX0+1:NX,NY0+1:NY,:))
     & + max(0D0, ATY(NX0+1:NX,NY0:NY-1,:))
     & - min(0D0, ATY(NX0+1:NX,NY0+1:NY,:))
      AOut(NX0+1:NX,NY0+1:NY,:) =
     &   max(0D0, ATX(NX0+1:NX,NY0+1:NY,:))
     & - min(0D0, ATX(NX0:NX-1,NY0+1:NY,:))
     & + max(0D0, ATY(NX0+1:NX,NY0+1:NY,:))
     & - min(0D0, ATY(NX0+1:NX,NY0:NY-1,:))
      AIn = max(1D-30, AIn)
      AOut = max(1D-30, AOut)
      FIn = (UTMax - Ut) / AIn
      FOut = (Ut - UTMin) / AOut

      Q1 = sign(1D0,ATX) ! sign
      PFilter = (Q1 + abs(ATX))/2D0 ! positive part only
      NFilter = PFilter - Q1 ! negative part only
      AHatX(NX0:NX-1,:,:) = ATX(NX0:NX-1,:,:) * (
     &   min(1D0, FIn(NX0+1:NX,:,:), FOut(NX0:NX-1,:,:))*PFilter
     & + min(1D0, FIn(NX0:NX-1,:,:), FOut(NX0+1:NX,:,:))*NFilter )
      Q1 = sign(1D0,ATY) ! sign
      PFilter = (Q1 + abs(ATY))/2D0 ! positive part only
      NFilter = PFilter - Q1 ! negative part only
      AHatY(:,NY0:NY-1,:) = ATY(:,NY0:NY-1,:) * (
     &   min(1D0, FIn(:,NY0+1:NY,:), FOut(:,NY0:NY-1,:))*PFilter
     & + min(1D0, FIn(:,NY0:NY-1,:), FOut(:,NY0+1:NY,:))*NFilter )

!     anti-diffusing!!
      Ut(NX0+1:NX,NY0+1:NY,:) = Ut(NX0+1:NX,NY0+1:NY,:)
     &  - AHatX(NX0+1:NX,NY0+1:NY,:) - AHatY(NX0+1:NX,NY0+1:NY,:)
     &  + AHatX(NX0:NX-1,NY0+1:NY,:) + AHatY(NX0+1:NX,NY0:NY-1,:)

!     smearing
      !DO K=NZ0,NZ
      !DO J=NY0,NY
      !DO I=NX0,NX
      !
      !xx=DX*I
      !yy=DY*J
      !rr=sqrt(xx**2+yy**2)
      !ff=1.0/(Dexp((rr-R0Bdry)/0.4D0)+1.0)
      !
      !U(I,J,K) = ff*U(I,J,K)
      !
      !EndDo
      !EndDo
      !EndDo

!     boundary killer
      Ut(NX0:NXPhy0+2,:,:) = 0D0
      Ut(NXPhy+2:NX,:,:) = 0D0
      Ut(:,NY0:NYPhy0+2,:) = 0D0
      Ut(:,NYPhy+2:NY,:) = 0D0

!     return value
      U = Ut

      End Subroutine
!-----------------------------------------------------------------------

**********************************************************************
      Function qiu_simpsons(f, a, b, epsilon, maxRecursionDepth)
!     My version of the adaptive simpsons integration method.
!     -- f: the function that needs to be integrated
!     -- a,b: range for the integration
!     -- epsilon: accuracy
!     -- maxRecursionDepth: number of recursions will not exceed this number
      Implicit None
!     declare input parameters
      Double Precision qiu_simpsons
      External f
      Double Precision f
      Double Precision a, b, epsilon
      Integer maxRecursionDepth

!     declare local variables
      Double Precision f_1, f_2, f_4 ! sum of values of f(x) that will be weighted by 1, 2, 4 respectively, depending on where x is
      Double Precision sum_previous, sum_current
      Integer count ! how many new mid-points are there
      Double Precision length, step ! half length of the interval; mid-points are located at a+(i+0.5)*step, i=0..count-1
      Integer currentRecursionDepth
      Integer i

      f_1=f(a)+f(b)
      f_2=0D0
      f_4=0D0
      sum_previous = 0D0
      sum_current = 0D0

      count = 1
      length = (b-a)
      step = length/count

      currentRecursionDepth = 1
      f_4 = f(a+0.5*step) ! mid point of [a,b]
      sum_current = (length/6)*(f_1 + f_2*2. + f_4*4.) ! get the current sum

      Do
        sum_previous = sum_current ! record the old sum
        f_2 = f_2 + f_4 ! old mid-points with weight 4 will be new mid-points with weight 2

        count = count * 2 ! increase number of mid-points
        step = step/2.0 ! decrease jumping step by half
        f_4 = 0D0 ! prepare to sum up f_4
        Do i=0,count-1
          f_4 = f_4 + f(a+step*(i+0.5)) ! sum up f_4
        EndDo

        sum_current = (length/6/count)*(f_1 + f_2*2D0 + f_4*4D0) ! calculate current sum

        If (currentRecursionDepth>maxRecursionDepth) Then
          Print*, "Warning: maximum recursion depth reached!"
          Exit
        EndIf
        currentRecursionDepth = currentRecursionDepth+1
        If (abs(sum_current-sum_previous)<epsilon) Then
          Exit
        EndIf
      EndDo

      qiu_simpsons = sum_current
      End Function